mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Dirk Herrmann 2003-10-07 22:00:05 +00:00
parent da0e6c2baf
commit d6e04e7c4a
8 changed files with 218 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

20
test-suite/ChangeLog
View file

@ -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.

7
test-suite/lib.scm
View file

@ -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

29
test-suite/tests/dynamic-scope.test
View file

@ -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)

4
test-suite/tests/eval.test
View file

@ -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))
;;;

4
test-suite/tests/r5rs_pitfall.test
View file

@ -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))

7
test-suite/tests/srfi-17.test
View file

@ -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)))))

13
test-suite/tests/syncase.test
View file

@ -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)))

231
test-suite/tests/syntax.test
View file

@ -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)