* lib.scm (exception:missing-expression): New.

* tests/dynamic-scope.test, tests/eval.test,
	tests/r5rs_pitfall.test, tests/srfi-17.test, tests/syncase.test:
	Wrap tests in module (test-suite test-<file-name without .test>),
	following a practice that was used on a couple of files already.

	* tests/dynamic-scope.test (exception:duplicate-binding,
	exception:bad-binding): New.

	* tests/dynamic-scope.test, tests/srfi-17.test, tests/syntax.test:
	Execute syntactically wrong tests using eval.  With the upcoming
	new memoizer this is necessary in order to postpone the syntax
	check to the actual evaluation of the syntactically wrong form.

	* tests/syntax.test: Added some test cases and modified one test
	case.

test-suite/ChangeLog

@@ -1,3 +1,23 @@
+2003-10-07  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* lib.scm (exception:missing-expression): New.
+
+	* tests/dynamic-scope.test, tests/eval.test,
+	tests/r5rs_pitfall.test, tests/srfi-17.test, tests/syncase.test:
+	Wrap tests in module (test-suite test-<file-name without .test>),
+	following a practice that was used on a couple of files already.
+
+	* tests/dynamic-scope.test (exception:duplicate-binding,
+	exception:bad-binding): New.
+
+	* tests/dynamic-scope.test, tests/srfi-17.test, tests/syntax.test:
+	Execute syntactically wrong tests using eval.  With the upcoming
+	new memoizer this is necessary in order to postpone the syntax
+	check to the actual evaluation of the syntactically wrong form.
+
+	* tests/syntax.test: Added some test cases and modified one test
+	case.
+
 2003-10-02  Kevin Ryde  <user42@zip.com.au>
 
 	* tests/ports.test (call-with-output-string): Test proc closing port.

test-suite/lib.scm

@@ -22,6 +22,7 @@
   :export (
 
  ;; Exceptions which are commonly being tested for.
+ exception:missing-expression
  exception:out-of-range exception:unbound-var
  exception:wrong-num-args exception:wrong-type-arg
 
@@ -32,14 +33,14 @@
 
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
+ format-test-name
 
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
  make-count-reporter print-counts
  make-log-reporter
  full-reporter
- user-reporter
+ user-reporter))
- format-test-name))
 
 
 ;;;; If you're using Emacs's Scheme mode:
@@ -232,6 +233,8 @@
 ;;;;
 
 ;;; Define some exceptions which are commonly being tested for.
+(define exception:missing-expression
+  (cons 'misc-error "^missing or extra expression"))
 (define exception:out-of-range
   (cons 'out-of-range "^Argument .*out of range"))
 (define exception:unbound-var

test-suite/tests/dynamic-scope.test

@@ -18,7 +18,14 @@
 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 ;;;; Boston, MA 02111-1307 USA
 
-(use-modules (test-suite lib))
+(define-module (test-suite test-dynamic-scope)
+  :use-module (test-suite lib))
+
+
+(define exception:duplicate-binding
+  (cons 'misc-error "^duplicate bindings"))
+(define exception:bad-binding
+  (cons 'misc-error "^bad bindings"))
 
 (define global-a 0)
 (define (fetch-global-a) global-a)
@@ -35,20 +42,24 @@
       (= global-a 0)))
 
   (pass-if-exception "duplicate @binds"
-    (cons 'misc-error "^duplicate bindings")
+    exception:duplicate-binding
-    (@bind ((a 1) (a 2)) (+ a a)))
+    (eval '(@bind ((a 1) (a 2)) (+ a a))
+	  (interaction-environment)))
 
   (pass-if-exception "@bind missing expression"
-    (cons 'misc-error "^missing or extra expression")
+    exception:missing-expression
-    (@bind ((global-a 1))))
+    (eval '(@bind ((global-a 1)))
+	  (interaction-environment)))
 
   (pass-if-exception "@bind bad bindings"
-    (cons 'misc-error "^bad bindings")
+    exception:bad-binding
-    (@bind (a) #f))
+    (eval '(@bind (a) #f)
+	  (interaction-environment)))
 
   (pass-if-exception "@bind bad bindings"
-    (cons 'misc-error "^bad bindings")
+    exception:bad-binding
-    (@bind ((a)) #f))
+    (eval '(@bind ((a)) #f)
+	  (interaction-environment)))
 
   (pass-if "@bind and dynamic-wind"
     (letrec ((co-routine #f)

test-suite/tests/eval.test

@@ -15,7 +15,9 @@
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 
-(use-modules (ice-9 documentation))
+(define-module (test-suite test-eval)
+  :use-module (test-suite lib)
+  :use-module (ice-9 documentation))
 
 
 ;;;

test-suite/tests/r5rs_pitfall.test

@@ -5,9 +5,9 @@
 ;; http://sisc.sourceforge.net/r5rs_pitfal.scm and the 'should-be'
 ;; macro has been modified to fit into our test suite machinery.
 ;;
-;; Tests 1.1 and 2.1 fail, but we expect that.
+;; Test 1.1 fails, but we expect that.
 
-(define-module (r5rs-pitfall-test)
+(define-module (test-suite test-r5rs-pitfall)
   :use-syntax (ice-9 syncase)
   :use-module (test-suite lib))
 

test-suite/tests/srfi-17.test

@@ -17,7 +17,10 @@
 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 ;;;; Boston, MA 02111-1307 USA
 
-(use-modules (srfi srfi-17))
+(define-module (test-suite test-srfi-17)
+  :use-module (test-suite lib)
+  :use-module (srfi srfi-17))
+
 
 (with-test-prefix "set!"
 
@@ -29,4 +32,4 @@
 
     (pass-if-exception "(set! '#f 1)"
       exception:wrong-type-arg
-      (set! '#f 1))))
+      (eval '(set! '#f 1) (interaction-environment)))))

test-suite/tests/syncase.test

@@ -20,18 +20,17 @@
 ;; These tests are in a module so that the syntax transformer does not
 ;; affect code outside of this file.
 ;;
-(define-module (syncase-test))
+(define-module (test-suite test-syncase)
-
+  :use-module (test-suite lib))
-(use-modules (test-suite lib))
 
 (pass-if "(ice-9 syncase) loads"
-	 (false-if-exception
+  (false-if-exception
-	  (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
+   (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
-		 #t)))
+          #t)))
 
 (define-syntax plus
   (syntax-rules ()
     ((plus x ...) (+ x ...))))
 
 (pass-if "basic syncase macro"
-	 (= (plus 1 2 3) (+ 1 2 3)))
+  (= (plus 1 2 3) (+ 1 2 3)))

test-suite/tests/syntax.test

@@ -40,6 +40,20 @@
 
 (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:
@@ -51,7 +65,8 @@
     ;; Fixed on 2001-3-3
     (pass-if-exception "empty parentheses \"()\""
       exception:missing/extra-expr
-      ())))
+      (eval '()
+	    (interaction-environment)))))
 
 (with-test-prefix "quote"
   #t)
@@ -87,15 +102,18 @@
 
     (pass-if-exception "(lambda)"
       exception:bad-formals
-      (lambda))
+      (eval '(lambda)
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda . \"foo\")"
       exception:bad-formals
-      (lambda . "foo"))
+      (eval '(lambda . "foo")
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda \"foo\")"
       exception:bad-formals
-      (lambda "foo"))
+      (eval '(lambda "foo")
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda \"foo\" #f)"
       exception:bad-formals
@@ -104,37 +122,44 @@
 
     (pass-if-exception "(lambda (x 1) 2)"
       exception:bad-formals
-      (lambda (x 1) 2))
+      (eval '(lambda (x 1) 2)
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda (1 x) 2)"
       exception:bad-formals
-      (lambda (1 x) 2))
+      (eval '(lambda (1 x) 2)
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda (x \"a\") 2)"
       exception:bad-formals
-      (lambda (x "a") 2))
+      (eval '(lambda (x "a") 2)
+	    (interaction-environment)))
 
     (pass-if-exception "(lambda (\"a\" x) 2)"
       exception:bad-formals
-      (lambda ("a" x) 2)))
+      (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))
+      (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)))
+      (eval '(lambda (x x x) 1)
+	    (interaction-environment))))
 
   (with-test-prefix "bad body"
 
     (pass-if-exception "(lambda ())"
       exception:bad-body
-      (lambda ()))))
+      (eval '(lambda ())
+	    (interaction-environment)))))
 
 (with-test-prefix "let"
 
@@ -148,33 +173,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
@@ -185,17 +217,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"
 
@@ -209,17 +244,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*"
 
@@ -237,27 +275,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
@@ -278,11 +322,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"
 
@@ -297,27 +343,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
@@ -338,17 +390,20 @@
 
     (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"
 
@@ -370,42 +425,57 @@
 
     (pass-if-exception "(cond)"
       exception:bad/missing-clauses
-      (cond))
+      (eval '(cond)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond #t)"
       exception:bad/missing-clauses
-      (cond #t))
+      (eval '(cond #t)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond 1)"
       exception:bad/missing-clauses
-      (cond 1))
+      (eval '(cond 1)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond 1 2)"
       exception:bad/missing-clauses
-      (cond 1 2))
+      (eval '(cond 1 2)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond 1 2 3)"
       exception:bad/missing-clauses
-      (cond 1 2 3))
+      (eval '(cond 1 2 3)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond 1 2 3 4)"
       exception:bad/missing-clauses
-      (cond 1 2 3 4))
+      (eval '(cond 1 2 3 4)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond ())"
       exception:bad/missing-clauses
-      (cond ()))
+      (eval '(cond ())
+	    (interaction-environment)))
 
     (pass-if-exception "(cond () 1)"
       exception:bad/missing-clauses
-      (cond () 1))
+      (eval '(cond () 1)
+	    (interaction-environment)))
 
     (pass-if-exception "(cond (1) 1)"
       exception:bad/missing-clauses
-      (cond (1) 1))))
+      (eval '(cond (1) 1)
+	    (interaction-environment)))))
 
 (with-test-prefix "cond =>"
 
+  (with-test-prefix "cond is hygienic"
+
+    (expect-fail "bound '=> is handled correctly"
+      (false-if-exception
+       (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok))))
+
   (with-test-prefix "else is handled correctly"
 
     (pass-if "else =>"
@@ -416,11 +486,11 @@
       (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)"
+    (pass-if-exception "=> (lambda (x y) #t)"
-      exception:bad-formals
+      exception:wrong-num-args
-      (cond (1 => (lambda (x 1) 2))))))
+      (cond (1 => (lambda (x y) #t))))))
 
 (with-test-prefix "case"
 
@@ -428,35 +498,43 @@
 
     (pass-if-exception "(case)"
       exception:bad/missing-clauses
-      (case))
+      (eval '(case)
+	    (interaction-environment)))
 
     (pass-if-exception "(case . \"foo\")"
       exception:bad/missing-clauses
-      (case . "foo"))
+      (eval '(case . "foo")
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1)"
       exception:bad/missing-clauses
-      (case 1))
+      (eval '(case 1)
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1 . \"foo\")"
       exception:bad/missing-clauses
-      (case 1 . "foo"))
+      (eval '(case 1 . "foo")
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1 \"foo\")"
       exception:bad/missing-clauses
-      (case 1 "foo"))
+      (eval '(case 1 "foo")
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1 ())"
       exception:bad/missing-clauses
-      (case 1 ()))
+      (eval '(case 1 ())
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1 (\"foo\"))"
       exception:bad/missing-clauses
-      (case 1 ("foo")))
+      (eval '(case 1 ("foo"))
+	    (interaction-environment)))
 
     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
       exception:bad/missing-clauses
-      (case 1 ("foo" "bar")))
+      (eval '(case 1 ("foo" "bar"))
+	    (interaction-environment)))
 
     ;; According to R5RS, the following one is syntactically correct.
     ;; (pass-if-exception "(case 1 (() \"bar\"))"
@@ -465,19 +543,23 @@
 
     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
       exception:bad/missing-clauses
-      (case 1 ((2) "bar") . "foo"))
+      (eval '(case 1 ((2) "bar") . "foo")
+	    (interaction-environment)))
 
-    (pass-if-exception "(case 1 (else #f) ((1) #t))"
+    (pass-if-exception "(case 1 ((2) \"bar\") (else))"
       exception:bad/missing-clauses
-      (case 1 ((2) "bar") (else)))
+      (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"))
+      (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)))))
+      (eval '(case 1 (else #f) ((1) #t))
+	    (interaction-environment)))))
 
 (with-test-prefix "define"
 
@@ -491,7 +573,8 @@
 
     (pass-if-exception "(define)"
       exception:missing/extra-expr
-      (define))))
+      (eval '(define)
+	    (interaction-environment)))))
 
 (with-test-prefix "set!"
 
@@ -558,10 +641,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.
@@ -578,7 +657,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)))
@@ -594,7 +673,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)