summaryrefslogtreecommitdiff
path: root/test-suite/tests/syntax.test
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-05-29 16:01:43 +0200
committerAndy Wingo <wingo@pobox.com>2009-05-29 16:01:43 +0200
commit938d46a35d39ec5d7b5fa858a8783136ce24d10d (patch)
tree17153f062515c4ae74815f65c4aa1f30a92e1ce4 /test-suite/tests/syntax.test
parent1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 (diff)
parente3c5df539640a36eb1493f581087d54a4714f337 (diff)
downloadguile-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.test414
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)))