From d6e04e7c4a01d0981b102cb028a11dc019ea22dd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 7 Oct 2003 22:00:05 +0000 Subject: [PATCH] * 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-), 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 | 20 +++ test-suite/lib.scm | 7 +- test-suite/tests/dynamic-scope.test | 29 ++-- test-suite/tests/eval.test | 4 +- test-suite/tests/r5rs_pitfall.test | 4 +- test-suite/tests/srfi-17.test | 7 +- test-suite/tests/syncase.test | 13 +- test-suite/tests/syntax.test | 231 +++++++++++++++++++--------- 8 files changed, 218 insertions(+), 97 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f8334e13a..26d166b00 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,23 @@ +2003-10-07 Dirk Herrmann + + * 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-), + 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 * tests/ports.test (call-with-output-string): Test proc closing port. diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 90b0837e4..bf27d9621 100644 --- a/test-suite/lib.scm +++ b/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 - format-test-name)) + user-reporter)) ;;;; 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 diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index bb7e1adda..89f43ae6f 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/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") - (@bind ((a 1) (a 2)) (+ a a))) + exception:duplicate-binding + (eval '(@bind ((a 1) (a 2)) (+ a a)) + (interaction-environment))) (pass-if-exception "@bind missing expression" - (cons 'misc-error "^missing or extra expression") - (@bind ((global-a 1)))) + exception:missing-expression + (eval '(@bind ((global-a 1))) + (interaction-environment))) (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind (a) #f)) + exception:bad-binding + (eval '(@bind (a) #f) + (interaction-environment))) (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind ((a)) #f)) + exception:bad-binding + (eval '(@bind ((a)) #f) + (interaction-environment))) (pass-if "@bind and dynamic-wind" (letrec ((co-routine #f) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index ca07686bc..06f42ae28 100644 --- a/test-suite/tests/eval.test +++ b/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)) ;;; diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 30edb479a..4c4bce6c4 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/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)) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index dc6fd7e06..f39489db7 100644 --- a/test-suite/tests/srfi-17.test +++ b/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))))) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 88667ea06..3a9574cb6 100644 --- a/test-suite/tests/syncase.test +++ b/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)) - -(use-modules (test-suite lib)) +(define-module (test-suite test-syncase) + :use-module (test-suite lib)) (pass-if "(ice-9 syncase) loads" - (false-if-exception - (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) - #t))) + (false-if-exception + (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) + #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))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 38a77c3db..3261ea1f6 100644 --- a/test-suite/tests/syntax.test +++ b/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)" - 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" @@ -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)