diff options
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/srfi-13.test | 12 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 77 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 19 |
3 files changed, 75 insertions, 33 deletions
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index 5575a700f..de6df8e52 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -1,7 +1,7 @@ ;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-07 ;;;; -;;;; Copyright (C) 2001, 2004, 2005, 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2004, 2005, 2006, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -561,13 +561,15 @@ (with-test-prefix "substring/shared" (pass-if "empty string" - (eq? "" (substring/shared "" 0))) + (let ((s "")) + (eq? s (substring/shared s 0)))) - (pass-if "non-empty string" + (pass-if "non-empty string, not eq?" (string=? "foo" (substring/shared "foo-bar" 0 3))) - (pass-if "non-empty string, not eq?" - (string=? "foo-bar" (substring/shared "foo-bar" 0 7)))) + (pass-if "shared copy of non-empty string is eq?" + (let ((s "foo-bar")) + (eq? s (substring/shared s 0 7))))) (with-test-prefix "string-copy!" diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 5163bac00..e55cba11e 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -648,11 +648,13 @@ (pass-if-syntax-error "missing recipient" '(cond . "wrong number of receiver expressions") - (cond (#t identity =>))) + (eval '(cond (#t identity =>)) + (interaction-environment))) (pass-if-syntax-error "extra recipient" '(cond . "wrong number of receiver expressions") - (cond (#t identity => identity identity)))) + (eval '(cond (#t identity => identity identity)) + (interaction-environment)))) (with-test-prefix "bad or missing clauses" @@ -662,43 +664,48 @@ (interaction-environment))) (pass-if-syntax-error "(cond #t)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond #t) (interaction-environment))) (pass-if-syntax-error "(cond 1)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond 1) (interaction-environment))) (pass-if-syntax-error "(cond 1 2)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond 1 2) (interaction-environment))) (pass-if-syntax-error "(cond 1 2 3)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond 1 2 3) (interaction-environment))) (pass-if-syntax-error "(cond 1 2 3 4)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-syntax-error "(cond ())" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond ()) (interaction-environment))) (pass-if-syntax-error "(cond () 1)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond () 1) (interaction-environment))) (pass-if-syntax-error "(cond (1) 1)" - exception:generic-syncase-error + '(cond . "invalid clause") (eval '(cond (1) 1) + (interaction-environment))) + + (pass-if-syntax-error "(cond (else #f) (#t #t))" + '(cond . "else must be the last clause") + (eval '(cond (else #f) (#t #t)) (interaction-environment)))) (with-test-prefix "wrong number of arguments" @@ -712,10 +719,46 @@ (pass-if "clause with empty labels list" (case 1 (() #f) (else #t))) + (with-test-prefix "case handles '=> correctly" + + (pass-if "(1 2 3) => list" + (equal? (case 1 ((1 2 3) => list)) + '(1))) + + (pass-if "else => list" + (equal? (case 6 + ((1 2 3) 'wrong) + (else => list)) + '(6))) + + (with-test-prefix "bound '=> is handled correctly" + + (pass-if "(1) => 'ok" + (let ((=> 'foo)) + (eq? (case 1 ((1) => 'ok)) 'ok))) + + (pass-if "else =>" + (let ((=> 'foo)) + (eq? (case 1 (else =>)) 'foo))) + + (pass-if "else => list" + (let ((=> 'foo)) + (eq? (case 1 (else => identity)) identity)))) + + (pass-if-syntax-error "missing recipient" + '(case . "wrong number of receiver expressions") + (eval '(case 1 ((1) =>)) + (interaction-environment))) + + (pass-if-syntax-error "extra recipient" + '(case . "wrong number of receiver expressions") + (eval '(case 1 ((1) => identity identity)) + (interaction-environment)))) + (with-test-prefix "case is hygienic" (pass-if-syntax-error "bound 'else is handled correctly" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -742,22 +785,22 @@ (interaction-environment))) (pass-if-syntax-error "(case 1 \"foo\")" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(case 1 "foo") (interaction-environment))) (pass-if-syntax-error "(case 1 ())" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(case 1 ()) (interaction-environment))) (pass-if-syntax-error "(case 1 (\"foo\"))" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(case 1 ("foo" "bar")) (interaction-environment))) @@ -767,7 +810,7 @@ (interaction-environment))) (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))" - exception:generic-syncase-error + '(case . "invalid clause") (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) @@ -777,7 +820,7 @@ (interaction-environment))) (pass-if-syntax-error "(case 1 (else #f) ((1) #t))" - exception:generic-syncase-error + '(case . "else must be the last clause") (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 1e0b8c179..1f3d4e91c 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1162,24 +1162,21 @@ (case foo ((3 2 1) 'a) (else 'b)) - (if (let (t) (_) ((toplevel foo)) - (if (primcall eqv? (lexical t _) (const 3)) + (let (key) (_) ((toplevel foo)) + (if (if (primcall eqv? (lexical key _) (const 3)) (const #t) - (if (primcall eqv? (lexical t _) (const 2)) + (if (primcall eqv? (lexical key _) (const 2)) (const #t) - (primcall eqv? (lexical t _) (const 1))))) - (const a) - (const b))) + (primcall eqv? (lexical key _) (const 1)))) + (const a) + (const b)))) (pass-if-peval - ;; Memv with non-constant key, empty list, test context. Currently - ;; doesn't fold entirely. + ;; Memv with non-constant key, empty list, test context. (case foo (() 'a) (else 'b)) - (if (seq (toplevel foo) (const #f)) - (const a) - (const b))) + (seq (toplevel foo) (const 'b))) ;; ;; Below are cases where constant propagation should bail out. |