* libguile/eval.c (s_bad_formals, s_bad_formal, s_duplicate_formal):

[bpt/guile.git] / test-suite / tests / syntax.test

diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 6aa33ee..9bde520 100644 (file)
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -17,6 +17,21 @@
 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 ;;;; Boston, MA 02111-1307 USA
 
+(define-module (test-suite test-syntax)
+  :use-module (test-suite lib))
+
+
+(define exception:bad-expression
+  (cons 'syntax-error "Bad expression"))
+
+(define exception:missing/extra-expr
+  (cons 'misc-error "^missing or extra expression"))
+(define exception:missing/extra-expr-syntax
+  (cons 'syntax-error "missing or extra expression"))
+(define exception:missing-expr
+  (cons 'syntax-error "Missing expression"))
+(define exception:extra-expr
+  (cons 'syntax-error "Extra expression"))
 
 (define exception:bad-bindings
   (cons 'misc-error "^bad bindings"))
@@ -25,19 +40,43 @@
 (define exception:bad-body
   (cons 'misc-error "^bad body"))
 (define exception:bad-formals
-  (cons 'misc-error "^bad formals"))
-(define exception:duplicate-formals
-  (cons 'misc-error "^duplicate formals"))
+  (cons 'syntax-error "Bad formals"))
+(define exception:bad-formal
+  (cons 'syntax-error "Bad formal"))
+(define exception:duplicate-formal
+  (cons 'syntax-error "Duplicate formal"))
+
+(define exception:missing-clauses
+  (cons 'syntax-error "Missing clauses"))
+(define exception:misplaced-else-clause
+  (cons 'syntax-error "Misplaced else clause"))
+(define exception:bad-case-clause
+  (cons 'syntax-error "Bad case clause"))
+(define exception:bad-case-labels
+  (cons 'syntax-error "Bad case labels"))
+(define exception:bad-cond-clause
+  (cons 'syntax-error "Bad cond clause"))
+
 (define exception:bad-var
   (cons 'misc-error "^bad variable"))
-(define exception:bad/missing-clauses
-  (cons 'misc-error "^bad or missing clauses"))
-(define exception:missing/extra-expr
-  (cons 'misc-error "^missing or extra expression"))
 
 
 (with-test-prefix "expressions"
 
+  (with-test-prefix "Bad argument list"
+
+    (pass-if-exception "improper argument list of length 1"
+      exception:wrong-num-args
+      (eval '(let ((foo (lambda (x y) #t)))
+              (foo . 1))
+           (interaction-environment)))
+
+    (pass-if-exception "improper argument list of length 2"
+      exception:wrong-num-args
+      (eval '(let ((foo (lambda (x y) #t)))
+              (foo 1 . 2))
+           (interaction-environment))))
+
   (with-test-prefix "missing or extra expression"
 
     ;; R5RS says:
@@ -49,7 +88,8 @@
     ;; Fixed on 2001-3-3
     (pass-if-exception "empty parentheses \"()\""
       exception:missing/extra-expr
-      ())))
+      (eval '()
+           (interaction-environment)))))
 
 (with-test-prefix "quote"
   #t)
@@ -84,16 +124,19 @@
   (with-test-prefix "bad formals"
 
     (pass-if-exception "(lambda)"
-      exception:bad-formals
-      (lambda))
+      exception:missing-expr
+      (eval '(lambda)
+           (interaction-environment)))
 
     (pass-if-exception "(lambda . \"foo\")"
-      exception:bad-formals
-      (lambda . "foo"))
+      exception:bad-expression
+      (eval '(lambda . "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(lambda \"foo\")"
-      exception:bad-formals
-      (lambda "foo"))
+      exception:missing-expr
+      (eval '(lambda "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(lambda \"foo\" #f)"
       exception:bad-formals
@@ -101,38 +144,45 @@
            (interaction-environment)))
 
     (pass-if-exception "(lambda (x 1) 2)"
-      exception:bad-formals
-      (lambda (x 1) 2))
+      exception:bad-formal
+      (eval '(lambda (x 1) 2)
+           (interaction-environment)))
 
     (pass-if-exception "(lambda (1 x) 2)"
-      exception:bad-formals
-      (lambda (1 x) 2))
+      exception:bad-formal
+      (eval '(lambda (1 x) 2)
+           (interaction-environment)))
 
     (pass-if-exception "(lambda (x \"a\") 2)"
-      exception:bad-formals
-      (lambda (x "a") 2))
+      exception:bad-formal
+      (eval '(lambda (x "a") 2)
+           (interaction-environment)))
 
     (pass-if-exception "(lambda (\"a\" x) 2)"
-      exception:bad-formals
-      (lambda ("a" x) 2)))
+      exception:bad-formal
+      (eval '(lambda ("a" x) 2)
+           (interaction-environment))))
 
   (with-test-prefix "duplicate formals"
 
     ;; Fixed on 2001-3-3
     (pass-if-exception "(lambda (x x) 1)"
-      exception:duplicate-formals
-      (lambda (x x) 1))
+      exception:duplicate-formal
+      (eval '(lambda (x x) 1)
+           (interaction-environment)))
 
     ;; Fixed on 2001-3-3
     (pass-if-exception "(lambda (x x x) 1)"
-      exception:duplicate-formals
-      (lambda (x x x) 1)))
+      exception:duplicate-formal
+      (eval '(lambda (x x x) 1)
+           (interaction-environment))))
 
   (with-test-prefix "bad body"
 
     (pass-if-exception "(lambda ())"
-      exception:bad-body
-      (lambda ()))))
+      exception:missing-expr
+      (eval '(lambda ())
+           (interaction-environment)))))
 
 (with-test-prefix "let"
 
@@ -146,33 +196,40 @@
 
     (pass-if-exception "(let)"
       exception:bad-bindings
-      (let))
+      (eval '(let)
+           (interaction-environment)))
 
     (pass-if-exception "(let 1)"
       exception:bad-bindings
-      (let 1))
+      (eval '(let 1)
+           (interaction-environment)))
 
     (pass-if-exception "(let (x))"
       exception:bad-bindings
-      (let (x)))
+      (eval '(let (x))
+           (interaction-environment)))
 
     ;; FIXME:  Wouldn't one rather expect a 'bad bindings' error?
     ;; (Even although the body is bad as well...)
     (pass-if-exception "(let ((x)))"
       exception:bad-body
-      (let ((x))))
+      (eval '(let ((x)))
+           (interaction-environment)))
 
     (pass-if-exception "(let (x) 1)"
       exception:bad-bindings
-      (let (x) 1))
+      (eval '(let (x) 1)
+           (interaction-environment)))
 
     (pass-if-exception "(let ((x)) 3)"
       exception:bad-bindings
-      (let ((x)) 3))
+      (eval '(let ((x)) 3)
+           (interaction-environment)))
 
     (pass-if-exception "(let ((x 1) y) x)"
       exception:bad-bindings
-      (let ((x 1) y) x))
+      (eval '(let ((x 1) y) x)
+           (interaction-environment)))
 
     (pass-if-exception "(let ((1 2)) 3)"
       exception:bad-var
@@ -183,17 +240,20 @@
 
     (pass-if-exception "(let ((x 1) (x 2)) x)"
       exception:duplicate-bindings
-      (let ((x 1) (x 2)) x)))
+      (eval '(let ((x 1) (x 2)) x)
+           (interaction-environment))))
 
   (with-test-prefix "bad body"
 
     (pass-if-exception "(let ())"
       exception:bad-body
-      (let ()))
+      (eval '(let ())
+           (interaction-environment)))
 
     (pass-if-exception "(let ((x 1)))"
       exception:bad-body
-      (let ((x 1))))))
+      (eval '(let ((x 1)))
+           (interaction-environment)))))
 
 (with-test-prefix "named let"
 
@@ -207,17 +267,20 @@
 
     (pass-if-exception "(let x (y))"
       exception:bad-bindings
-      (let x (y))))
+      (eval '(let x (y))
+           (interaction-environment))))
 
   (with-test-prefix "bad body"
 
     (pass-if-exception "(let x ())"
       exception:bad-body
-      (let x ()))
+      (eval '(let x ())
+           (interaction-environment)))
 
     (pass-if-exception "(let x ((y 1)))"
       exception:bad-body
-      (let x ((y 1))))))
+      (eval '(let x ((y 1)))
+           (interaction-environment)))))
 
 (with-test-prefix "let*"
 
@@ -235,27 +298,33 @@
 
     (pass-if-exception "(let*)"
       exception:bad-bindings
-      (let*))
+      (eval '(let*)
+           (interaction-environment)))
 
     (pass-if-exception "(let* 1)"
       exception:bad-bindings
-      (let* 1))
+      (eval '(let* 1)
+           (interaction-environment)))
 
     (pass-if-exception "(let* (x))"
       exception:bad-bindings
-      (let* (x)))
+      (eval '(let* (x))
+           (interaction-environment)))
 
     (pass-if-exception "(let* (x) 1)"
       exception:bad-bindings
-      (let* (x) 1))
+      (eval '(let* (x) 1)
+           (interaction-environment)))
 
     (pass-if-exception "(let* ((x)) 3)"
       exception:bad-bindings
-      (let* ((x)) 3))
+      (eval '(let* ((x)) 3)
+           (interaction-environment)))
 
     (pass-if-exception "(let* ((x 1) y) x)"
       exception:bad-bindings
-      (let* ((x 1) y) x))
+      (eval '(let* ((x 1) y) x)
+           (interaction-environment)))
 
     (pass-if-exception "(let* x ())"
       exception:bad-bindings
@@ -276,11 +345,13 @@
 
     (pass-if-exception "(let* ())"
       exception:bad-body
-      (let* ()))
+      (eval '(let* ())
+           (interaction-environment)))
 
     (pass-if-exception "(let* ((x 1)))"
       exception:bad-body
-      (let* ((x 1))))))
+      (eval '(let* ((x 1)))
+           (interaction-environment)))))
 
 (with-test-prefix "letrec"
 
@@ -295,27 +366,33 @@
 
     (pass-if-exception "(letrec)"
       exception:bad-bindings
-      (letrec))
+      (eval '(letrec)
+           (interaction-environment)))
 
     (pass-if-exception "(letrec 1)"
       exception:bad-bindings
-      (letrec 1))
+      (eval '(letrec 1)
+           (interaction-environment)))
 
     (pass-if-exception "(letrec (x))"
       exception:bad-bindings
-      (letrec (x)))
+      (eval '(letrec (x))
+           (interaction-environment)))
 
     (pass-if-exception "(letrec (x) 1)"
       exception:bad-bindings
-      (letrec (x) 1))
+      (eval '(letrec (x) 1)
+           (interaction-environment)))
 
     (pass-if-exception "(letrec ((x)) 3)"
       exception:bad-bindings
-      (letrec ((x)) 3))
+      (eval '(letrec ((x)) 3)
+           (interaction-environment)))
 
     (pass-if-exception "(letrec ((x 1) y) x)"
       exception:bad-bindings
-      (letrec ((x 1) y) x))
+      (eval '(letrec ((x 1) y) x)
+           (interaction-environment)))
 
     (pass-if-exception "(letrec x ())"
       exception:bad-bindings
@@ -336,29 +413,32 @@
 
     (pass-if-exception "(letrec ((x 1) (x 2)) x)"
       exception:duplicate-bindings
-      (letrec ((x 1) (x 2)) x)))
+      (eval '(letrec ((x 1) (x 2)) x)
+           (interaction-environment))))
 
   (with-test-prefix "bad body"
 
     (pass-if-exception "(letrec ())"
       exception:bad-body
-      (letrec ()))
+      (eval '(letrec ())
+           (interaction-environment)))
 
     (pass-if-exception "(letrec ((x 1)))"
       exception:bad-body
-      (letrec ((x 1))))))
+      (eval '(letrec ((x 1)))
+           (interaction-environment)))))
 
 (with-test-prefix "if"
 
   (with-test-prefix "missing or extra expressions"
 
     (pass-if-exception "(if)"
-      exception:missing/extra-expr
+      exception:missing/extra-expr-syntax
       (eval '(if)
            (interaction-environment)))
 
     (pass-if-exception "(if 1 2 3 4)"
-      exception:missing/extra-expr
+      exception:missing/extra-expr-syntax
       (eval '(if 1 2 3 4)
            (interaction-environment)))))
 
@@ -367,43 +447,60 @@
   (with-test-prefix "bad or missing clauses"
 
     (pass-if-exception "(cond)"
-      exception:bad/missing-clauses
-      (cond))
+      exception:missing-clauses
+      (eval '(cond)
+           (interaction-environment)))
 
     (pass-if-exception "(cond #t)"
-      exception:bad/missing-clauses
-      (cond #t))
+      exception:bad-cond-clause
+      (eval '(cond #t)
+           (interaction-environment)))
 
     (pass-if-exception "(cond 1)"
-      exception:bad/missing-clauses
-      (cond 1))
+      exception:bad-cond-clause
+      (eval '(cond 1)
+           (interaction-environment)))
 
     (pass-if-exception "(cond 1 2)"
-      exception:bad/missing-clauses
-      (cond 1 2))
+      exception:bad-cond-clause
+      (eval '(cond 1 2)
+           (interaction-environment)))
 
     (pass-if-exception "(cond 1 2 3)"
-      exception:bad/missing-clauses
-      (cond 1 2 3))
+      exception:bad-cond-clause
+      (eval '(cond 1 2 3)
+           (interaction-environment)))
 
     (pass-if-exception "(cond 1 2 3 4)"
-      exception:bad/missing-clauses
-      (cond 1 2 3 4))
+      exception:bad-cond-clause
+      (eval '(cond 1 2 3 4)
+           (interaction-environment)))
 
     (pass-if-exception "(cond ())"
-      exception:bad/missing-clauses
-      (cond ()))
+      exception:bad-cond-clause
+      (eval '(cond ())
+           (interaction-environment)))
 
     (pass-if-exception "(cond () 1)"
-      exception:bad/missing-clauses
-      (cond () 1))
+      exception:bad-cond-clause
+      (eval '(cond () 1)
+           (interaction-environment)))
 
     (pass-if-exception "(cond (1) 1)"
-      exception:bad/missing-clauses
-      (cond (1) 1))))
+      exception:bad-cond-clause
+      (eval '(cond (1) 1)
+           (interaction-environment)))))
 
 (with-test-prefix "cond =>"
 
+  (with-test-prefix "cond is hygienic"
+
+    (pass-if "bound 'else is handled correctly"
+      (eq? (let ((else 'ok)) (cond (else))) 'ok))
+
+    (pass-if "bound '=> is handled correctly"
+      (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))
+
   (with-test-prefix "else is handled correctly"
 
     (pass-if "else =>"
@@ -414,68 +511,85 @@
       (let* ((=> 'foo))
        (eq? (cond (else => identity)) identity))))
 
-  (with-test-prefix "bad formals"
+  (with-test-prefix "wrong number of arguments"
 
-    (pass-if-exception "=> (lambda (x 1) 2)"
-      exception:bad-formals
-      (cond (1 => (lambda (x 1) 2))))))
+    (pass-if-exception "=> (lambda (x y) #t)"
+      exception:wrong-num-args
+      (cond (1 => (lambda (x y) #t))))))
 
 (with-test-prefix "case"
 
+  (pass-if "clause with empty labels list"
+    (case 1 (() #f) (else #t)))
+
+  (with-test-prefix "case is hygienic"
+
+    (pass-if-exception "bound 'else is handled correctly"
+      exception:bad-case-labels
+      (eval '(let ((else #f)) (case 1 (else #f)))
+            (interaction-environment))))
+
   (with-test-prefix "bad or missing clauses"
 
     (pass-if-exception "(case)"
-      exception:bad/missing-clauses
-      (case))
+      exception:missing-clauses
+      (eval '(case)
+           (interaction-environment)))
 
     (pass-if-exception "(case . \"foo\")"
-      exception:bad/missing-clauses
-      (case . "foo"))
+      exception:bad-expression
+      (eval '(case . "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(case 1)"
-      exception:bad/missing-clauses
-      (case 1))
+      exception:missing-clauses
+      (eval '(case 1)
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 . \"foo\")"
-      exception:bad/missing-clauses
-      (case 1 . "foo"))
+      exception:bad-expression
+      (eval '(case 1 . "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 \"foo\")"
-      exception:bad/missing-clauses
-      (case 1 "foo"))
+      exception:bad-case-clause
+      (eval '(case 1 "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 ())"
-      exception:bad/missing-clauses
-      (case 1 ()))
+      exception:bad-case-clause
+      (eval '(case 1 ())
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 (\"foo\"))"
-      exception:bad/missing-clauses
-      (case 1 ("foo")))
+      exception:bad-case-clause
+      (eval '(case 1 ("foo"))
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
-      exception:bad/missing-clauses
-      (case 1 ("foo" "bar")))
-
-    ;; According to R5RS, the following one is syntactically correct.
-    ;; (pass-if-exception "(case 1 (() \"bar\"))"
-    ;;   exception:bad/missing-clauses
-    ;;   (case 1 (() "bar")))
+      exception:bad-case-labels
+      (eval '(case 1 ("foo" "bar"))
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
-      exception:bad/missing-clauses
-      (case 1 ((2) "bar") . "foo"))
+      exception:bad-expression
+      (eval '(case 1 ((2) "bar") . "foo")
+           (interaction-environment)))
 
-    (pass-if-exception "(case 1 (else #f) ((1) #t))"
-      exception:bad/missing-clauses
-      (case 1 ((2) "bar") (else)))
+    (pass-if-exception "(case 1 ((2) \"bar\") (else))"
+      exception:bad-case-clause
+      (eval '(case 1 ((2) "bar") (else))
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 (else #f) . \"foo\")"
-      exception:bad/missing-clauses
-      (case 1 (else #f) . "foo"))
+      exception:bad-expression
+      (eval '(case 1 (else #f) . "foo")
+           (interaction-environment)))
 
     (pass-if-exception "(case 1 (else #f) ((1) #t))"
-      exception:bad/missing-clauses
-      (case 1 (else #f) ((1) #t)))))
+      exception:misplaced-else-clause
+      (eval '(case 1 (else #f) ((1) #t))
+           (interaction-environment)))))
 
 (with-test-prefix "define"
 
@@ -488,8 +602,9 @@
   (with-test-prefix "missing or extra expressions"
 
     (pass-if-exception "(define)"
-      exception:missing/extra-expr
-      (define))))
+      exception:missing-expr
+      (eval '(define)
+           (interaction-environment)))))
 
 (with-test-prefix "set!"
 
@@ -556,10 +671,6 @@
   (define (unreachable)
     (error "unreachable code has been reached!"))
   
-  ;; an environment with no bindings at all
-  (define empty-environment
-    (make-module 1))
-  
   ;; Return a new procedure COND which when called (COND) will return #t the
   ;; first N times, then #f, then any further call is an error.  N=0 is
   ;; allowed, in which case #f is returned by the first call.
@@ -576,7 +687,7 @@
   
 
   (pass-if-exception "too few args" exception:wrong-num-args
-    (while))
+    (eval '(while) (interaction-environment)))
   
   (with-test-prefix "empty body"
     (do ((n 0 (1+ n)))
@@ -592,7 +703,11 @@
     #t)
   
   (with-test-prefix "in empty environment"
-    
+
+    ;; an environment with no bindings at all
+    (define empty-environment
+      (make-module 1))
+      
     (pass-if "empty body"
       (eval `(,while #f)
            empty-environment)