diff options
author | Andy Wingo <wingo@pobox.com> | 2009-05-29 16:01:43 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-05-29 16:01:43 +0200 |
commit | 938d46a35d39ec5d7b5fa858a8783136ce24d10d (patch) | |
tree | 17153f062515c4ae74815f65c4aa1f30a92e1ce4 /test-suite/tests/syntax.test | |
parent | 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 (diff) | |
parent | e3c5df539640a36eb1493f581087d54a4714f337 (diff) | |
download | guile-938d46a35d39ec5d7b5fa858a8783136ce24d10d.tar.gz |
Merge branch 'syncase-in-boot-9'
Conflicts:
module/Makefile.am
Diffstat (limited to 'test-suite/tests/syntax.test')
-rw-r--r-- | test-suite/tests/syntax.test | 414 |
1 files changed, 195 insertions, 219 deletions
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 1277e5204..aa2e05127 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -21,6 +21,11 @@ :use-module (test-suite lib)) +(define exception:generic-syncase-error + (cons 'syntax-error "source expression failed to match")) +(define exception:unexpected-syntax + (cons 'syntax-error "unexpected syntax")) + (define exception:bad-expression (cons 'syntax-error "Bad expression")) @@ -29,22 +34,32 @@ (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:missing-body-expr - (cons 'syntax-error "Missing body expression")) + (cons 'syntax-error "no expressions in body")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination (cons 'syntax-error "Illegal empty combination")) +(define exception:bad-lambda + '(syntax-error . "bad lambda")) +(define exception:bad-let + '(syntax-error . "bad let ")) +(define exception:bad-letrec + '(syntax-error . "bad letrec ")) +(define exception:bad-set! + '(syntax-error . "bad set!")) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding (cons 'syntax-error "Bad binding")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate bound variable")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'syntax-error "Bad formals")) + '(syntax-error . "invalid parameter list")) (define exception:bad-formal (cons 'syntax-error "Bad formal")) (define exception:duplicate-formal @@ -67,13 +82,13 @@ (with-test-prefix "Bad argument list" (pass-if-exception "improper argument list of length 1" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo . 1)) (interaction-environment))) (pass-if-exception "improper argument list of length 2" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo 1 . 2)) (interaction-environment)))) @@ -88,7 +103,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:illegal-empty-combination + exception:unexpected-syntax (eval '() (interaction-environment))))) @@ -106,28 +121,32 @@ (with-test-prefix "unquote-splicing" (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) + '(syntax-error . "unquote-splicing takes exactly one argument") + (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment))))) (with-test-prefix "begin" (pass-if "legal (begin)" - (begin) - #t) + (eval '(begin (begin) #t) (interaction-environment))) (with-test-prefix "unmemoization" + ;; FIXME. I have no idea why, but the expander is filling in (if #f + ;; #f) as the second arm of the if, if the second arm is missing. I + ;; thought I made it not do that. But in the meantime, let's adapt, + ;; since that's not what we're testing. + (pass-if "normal begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))) - (foo) ; make sure, memoization has been performed + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) (pass-if "redundant nested begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))) + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) (pass-if "redundant begin at start of body" (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized @@ -135,10 +154,20 @@ (equal? (procedure-source foo) '(lambda () (begin (+ 1) (+ 2))))))) - (expect-fail-exception "illegal (begin)" - exception:bad-body - (if #t (begin)) - #t)) + (pass-if-exception "illegal (begin)" + exception:generic-syncase-error + (eval '(begin (if #t (begin)) #t) (interaction-environment)))) + +(define-syntax matches? + (syntax-rules (_) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x _) #t) + ((_ x pat) (equal? x 'pat)))) (with-test-prefix "lambda" @@ -146,30 +175,28 @@ (pass-if "normal lambda" (let ((foo (lambda () (lambda (x y) (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) (+ _ _)))))) (pass-if "lambda with documentation" (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) "docstring" (+ x y))))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) "docstring" (+ _ _))))))) (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:missing-expr + exception:bad-lambda (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-expression + exception:bad-lambda (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:missing-expr + exception:bad-lambda (eval '(lambda "foo") (interaction-environment))) @@ -179,22 +206,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -202,20 +229,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:missing-expr + exception:bad-lambda (eval '(lambda ()) (interaction-environment))))) @@ -225,9 +252,8 @@ (pass-if "normal let" (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -238,42 +264,42 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:missing-expr + exception:bad-let (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:missing-expr + exception:bad-let (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:missing-expr + exception:bad-let (eval '(let (x)) (interaction-environment))) (pass-if-exception "(let ((x)))" - exception:missing-expr + exception:bad-let (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-binding + exception:bad-let (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-binding + exception:bad-let (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-binding + exception:bad-let (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-variable + exception:bad-let (eval '(let ((1 2)) 3) (interaction-environment)))) @@ -287,12 +313,12 @@ (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:missing-expr + exception:bad-let (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:missing-expr + exception:bad-let (eval '(let ((x 1))) (interaction-environment))))) @@ -307,19 +333,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:missing-expr + exception:bad-let (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:missing-expr + exception:bad-let (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:missing-expr + exception:bad-let (eval '(let x ((y 1))) (interaction-environment))))) @@ -329,19 +355,16 @@ (pass-if "normal let*" (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let* ((x 1) (y 2)) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) (pass-if "let* without bindings" (let ((foo (lambda () (let ((x 1) (y 2)) (let* () (and (= x 1) (= y 2))))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((x 1) (y 2)) - (let* () - (and (= x 1) (= y 2))))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) + (if (= _ 1) (= _ 2) #f))))))) (with-test-prefix "bindings" @@ -361,59 +384,59 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:missing-expr + exception:generic-syncase-error (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:missing-expr + exception:generic-syncase-error (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let* x ())" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x ()) (interaction-environment))) (pass-if-exception "(let* x (y))" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x (y)) (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-variable + exception:generic-syncase-error (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ((x 1))) (interaction-environment))))) @@ -423,9 +446,8 @@ (pass-if "normal letrec" (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (letrec ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -437,47 +459,47 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:missing-expr + exception:bad-letrec (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:missing-expr + exception:bad-letrec (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:missing-expr + exception:bad-letrec (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-binding + exception:bad-letrec (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x 1) y) x) (interaction-environment))) (pass-if-exception "(letrec x ())" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x ()) (interaction-environment))) (pass-if-exception "(letrec x (y))" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x (y)) (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-variable + exception:bad-letrec (eval '(letrec ((1 2)) 3) (interaction-environment)))) @@ -491,12 +513,12 @@ (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:missing-expr + exception:bad-letrec (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:missing-expr + exception:bad-letrec (eval '(letrec ((x 1))) (interaction-environment))))) @@ -508,17 +530,17 @@ (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (if x (+ 1) (+ 2)))))) + (matches? (procedure-source foo) + (lambda (_) (if _ (+ 1) (+ 2)))))) - (pass-if "if without else" + (expect-fail "if without else" (let ((foo (lambda (x) (if x (+ 1))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed (equal? (procedure-source foo) '(lambda (x) (if x (+ 1)))))) - (pass-if "if #f without else" + (expect-fail "if #f without else" (let ((foo (lambda () (if #f #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) @@ -527,12 +549,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if 1 2 3 4) (interaction-environment))))) @@ -594,78 +616,77 @@ (eq? 'ok (cond (#t identity =>) (else #f))))) (pass-if-exception "missing recipient" - '(syntax-error . "Missing recipient") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity =>))) (pass-if-exception "extra recipient" - '(syntax-error . "Extra expression") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity => identity identity)))) (with-test-prefix "unmemoization" + ;; FIXME: the (if #f #f) is a hack! (pass-if "normal clauses" - (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed + (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) (equal? (procedure-source foo) - '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) + '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) (pass-if "else" (let ((foo (lambda () (cond (else 'bar))))) - (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (cond (else 'bar)))))) + '(lambda () 'bar)))) + ;; FIXME: the (if #f #f) is a hack! (pass-if "=>" (let ((foo (lambda () (cond (#t => identity))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (cond (#t => identity))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ #t)) + (if _ (identity _) (if #f #f)))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:missing-clauses + exception:generic-syncase-error (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond (1) 1) (interaction-environment)))) @@ -683,7 +704,7 @@ (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" - exception:bad-case-labels + exception:generic-syncase-error (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -691,79 +712,83 @@ (pass-if "normal clauses" (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '(2)) + 'baz + 'foobar)))))) (pass-if "empty labels" (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '()) + 'baz + 'foobar))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad-case-labels + exception:generic-syncase-error (eval '(case 1 ("foo" "bar")) (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:misplaced-else-clause + exception:generic-syncase-error (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) @@ -780,14 +805,6 @@ (eval '(define round round) m) (eq? (module-ref m 'round) round))) - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (eval '(begin - (define ((foo)) #t) - ((foo))) - (interaction-environment)))) - (with-test-prefix "unmemoization" (pass-if "definition unmemoized without prior execution" @@ -809,7 +826,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing-expr + exception:generic-syncase-error (eval '(define) (interaction-environment))))) @@ -886,34 +903,10 @@ 'ok) (bar)) (foo) - (equal? + (matches? (procedure-source foo) - '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) - (interaction-environment)))) - -(with-test-prefix "do" - - (with-test-prefix "unmemoization" - - (pass-if "normal case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i)))))) - - (pass-if "reduced case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here - ((> i 9) (+ i j)) - (identity i)))))))) + (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))) + (current-module)))) (with-test-prefix "set!" @@ -922,50 +915,50 @@ (pass-if "normal set!" (let ((foo (lambda (x) (set! x (+ 1 x))))) (foo 1) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (set! x (+ 1 x))))))) + (matches? (procedure-source foo) + (lambda (_) (set! _ (+ 1 _))))))) (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:bad-set! (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-variable + exception:bad-set! (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-variable + exception:bad-set! (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-variable + exception:bad-set! (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\\space #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #\space #f) (interaction-environment))))) @@ -974,12 +967,12 @@ (with-test-prefix "missing or extra expression" (pass-if-exception "(quote)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote) (interaction-environment))) (pass-if-exception "(quote a b)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote a b) (interaction-environment))))) @@ -1010,46 +1003,27 @@ (do ((n 0 (1+ n))) ((> n 5)) (pass-if n - (let ((cond (make-iterations-cond n))) - (while (cond))) - #t))) + (eval `(letrec ((make-iterations-cond + (lambda (n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) (pass-if "initially false" (while #f (unreachable)) #t) - (with-test-prefix "in empty environment" - - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - - ;; these tests are 'unresolved because to work with ice-9 syncase it was - ;; necessary to drop the unquote from `do' in the implementation, and - ;; unfortunately that makes `while' depend on its evaluation environment - - (pass-if "empty body" - (throw 'unresolved) - (eval `(,while #f) - empty-environment) - #t) - - (pass-if "initially false" - (throw 'unresolved) - (eval `(,while #f - #f) - empty-environment) - #t) - - (pass-if "iterating" - (throw 'unresolved) - (let ((cond (make-iterations-cond 3))) - (eval `(,while (,cond) - 123 456) - empty-environment)) - #t)) - (with-test-prefix "iterations" (do ((n 0 (1+ n))) ((> n 5)) @@ -1063,8 +1037,9 @@ (with-test-prefix "break" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (break 1))) + (eval '(while #t + (break 1)) + (interaction-environment))) (with-test-prefix "from cond" (pass-if "first" @@ -1135,8 +1110,9 @@ (with-test-prefix "continue" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (continue 1))) + (eval '(while #t + (continue 1)) + (interaction-environment))) (with-test-prefix "from cond" (do ((n 0 (1+ n))) |