;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2005 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 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 'syntax-error "Missing or extra expression"))
+(define exception:missing-expr
+ (cons 'syntax-error "Missing expression"))
+(define exception:missing-body-expr
+ (cons 'syntax-error "Missing body expression"))
+(define exception:extra-expr
+ (cons 'syntax-error "Extra expression"))
+(define exception:illegal-empty-combination
+ (cons 'syntax-error "Illegal empty combination"))
(define exception:bad-bindings
- (cons 'misc-error "^bad bindings"))
-(define exception:duplicate-bindings
- (cons 'misc-error "^duplicate bindings"))
+ (cons 'syntax-error "Bad bindings"))
+(define exception:bad-binding
+ (cons 'syntax-error "Bad binding"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "Duplicate binding"))
(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"))
-(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"))
+ (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"))
(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:
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
+ exception:illegal-empty-combination
+ (eval '()
+ (interaction-environment)))))
+
+(with-test-prefix "quote"
+ #t)
+
+(with-test-prefix "quasiquote"
+
+ (with-test-prefix "unquote"
+
+ (pass-if "repeated execution"
+ (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
+ (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
+
+ (with-test-prefix "unquote-splicing"
+
+ (pass-if-exception "extra arguments"
exception:missing/extra-expr
- ())))
+ (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
+
+(with-test-prefix "begin"
+
+ (pass-if "legal (begin)"
+ (begin)
+ #t)
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal begin"
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
+
+ (pass-if "redundant nested begin"
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
+
+ (pass-if "redundant begin at start of body"
+ (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (begin (+ 1) (+ 2)))))))
+
+ (expect-fail-exception "illegal (begin)"
+ exception:bad-body
+ (if #t (begin))
+ #t))
(with-test-prefix "lambda"
+ (with-test-prefix "unmemoization"
+
+ (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))))))
+
+ (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)))))))
+
(with-test-prefix "bad formals"
- (pass-if-exception "(lambda (x 1) 2)"
+ (pass-if-exception "(lambda)"
+ exception:missing-expr
+ (eval '(lambda)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda . \"foo\")"
+ exception:bad-expression
+ (eval '(lambda . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda \"foo\")"
+ exception:missing-expr
+ (eval '(lambda "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda \"foo\" #f)"
exception:bad-formals
- (lambda (x 1) 2))
+ (eval '(lambda "foo" #f)
+ (interaction-environment)))
+
+ (pass-if-exception "(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:missing-expr
+ (eval '(lambda ())
+ (interaction-environment)))))
(with-test-prefix "let"
+ (with-test-prefix "unmemoization"
+
+ (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)))))))
+
(with-test-prefix "bindings"
(pass-if-exception "late binding"
exception:unbound-var
(let ((x 1) (y x)) y)))
- (with-test-prefix "bad body"
-
- (pass-if-exception "(let ())"
- exception:bad-body
- (let ()))
-
- (pass-if-exception "(let ((x 1)))"
- exception:bad-body
- (let ((x 1))))
+ (with-test-prefix "bad bindings"
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let)"
- exception:bad-body
- (let))
+ exception:missing-expr
+ (eval '(let)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let 1)"
- exception:bad-body
- (let 1))
+ exception:missing-expr
+ (eval '(let 1)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let (x))"
- exception:bad-body
- (let (x))))
+ exception:missing-expr
+ (eval '(let (x))
+ (interaction-environment)))
- (with-test-prefix "bad bindings"
+ (pass-if-exception "(let ((x)))"
+ exception:missing-expr
+ (eval '(let ((x)))
+ (interaction-environment)))
(pass-if-exception "(let (x) 1)"
- exception:bad-bindings
- (let (x) 1))
+ exception:bad-binding
+ (eval '(let (x) 1)
+ (interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
- exception:bad-bindings
- (let ((x)) 3))
+ exception:bad-binding
+ (eval '(let ((x)) 3)
+ (interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
- exception:bad-bindings
- (let ((x 1) y) x))
+ exception:bad-binding
+ (eval '(let ((x 1) y) x)
+ (interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
- exception:bad-var
- (let ((1 2)) 3)))
+ exception:bad-variable
+ (eval '(let ((1 2)) 3)
+ (interaction-environment))))
(with-test-prefix "duplicate bindings"
(pass-if-exception "(let ((x 1) (x 2)) x)"
- exception:duplicate-bindings
- (let ((x 1) (x 2)) x))))
+ exception:duplicate-binding
+ (eval '(let ((x 1) (x 2)) x)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(let ())"
+ exception:missing-expr
+ (eval '(let ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((x 1)))"
+ exception:missing-expr
+ (eval '(let ((x 1)))
+ (interaction-environment)))))
(with-test-prefix "named let"
+ (with-test-prefix "initializers"
+
+ (pass-if "evaluated in outer environment"
+ (let ((f -))
+ (eqv? (let f ((n (f 1))) n) -1))))
+
+ (with-test-prefix "bad bindings"
+
+ (pass-if-exception "(let x (y))"
+ exception:missing-expr
+ (eval '(let x (y))
+ (interaction-environment))))
+
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
- exception:bad-body
- (let x ()))
+ exception:missing-expr
+ (eval '(let x ())
+ (interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
- exception:bad-body
- (let x ((y 1))))
-
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
- (pass-if-exception "(let x (y))"
- exception:bad-body
- (let x (y)))))
+ exception:missing-expr
+ (eval '(let x ((y 1)))
+ (interaction-environment)))))
(with-test-prefix "let*"
+ (with-test-prefix "unmemoization"
+
+ (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))))))
+
+ (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)))))))))
+
(with-test-prefix "bindings"
(pass-if "(let* ((x 1) (x 2)) ...)"
(pass-if "(let* ((x 1) (x x)) ...)"
(let* ((x 1) (x x))
- (= x 1))))
+ (= x 1)))
- (with-test-prefix "bad body"
+ (pass-if "(let ((x 1) (y 2)) (let* () ...))"
+ (let ((x 1) (y 2))
+ (let* ()
+ (and (= x 1) (= y 2))))))
- (pass-if-exception "(let* ())"
- exception:bad-body
- (let* ()))
-
- (pass-if-exception "(let* ((x 1)))"
- exception:bad-body
- (let* ((x 1))))
+ (with-test-prefix "bad bindings"
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let*)"
- exception:bad-body
- (let*))
+ exception:missing-expr
+ (eval '(let*)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let* 1)"
- exception:bad-body
- (let* 1))
+ exception:missing-expr
+ (eval '(let* 1)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(let* (x))"
- exception:bad-body
- (let* (x))))
-
- (with-test-prefix "bad bindings"
+ exception:missing-expr
+ (eval '(let* (x))
+ (interaction-environment)))
(pass-if-exception "(let* (x) 1)"
- exception:bad-bindings
- (let* (x) 1))
+ exception:bad-binding
+ (eval '(let* (x) 1)
+ (interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
- exception:bad-bindings
- (let* ((x)) 3))
+ exception:bad-binding
+ (eval '(let* ((x)) 3)
+ (interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
- exception:bad-bindings
- (let* ((x 1) y) x))
+ exception:bad-binding
+ (eval '(let* ((x 1) y) x)
+ (interaction-environment)))
(pass-if-exception "(let* x ())"
exception:bad-bindings
- (let* x ()))
+ (eval '(let* x ())
+ (interaction-environment)))
(pass-if-exception "(let* x (y))"
exception:bad-bindings
- (let* x (y)))
+ (eval '(let* x (y))
+ (interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
- exception:bad-var
- (let* ((1 2)) 3))))
+ exception:bad-variable
+ (eval '(let* ((1 2)) 3)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(let* ())"
+ exception:missing-expr
+ (eval '(let* ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let* ((x 1)))"
+ exception:missing-expr
+ (eval '(let* ((x 1)))
+ (interaction-environment)))))
(with-test-prefix "letrec"
+ (with-test-prefix "unmemoization"
+
+ (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)))))))
+
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
- exception:unbound-var
+ exception:used-before-defined
(let ((x 1))
(letrec ((x 1) (y x)) y))))
- (with-test-prefix "bad body"
-
- (pass-if-exception "(letrec ())"
- exception:bad-body
- (letrec ()))
-
- (pass-if-exception "(letrec ((x 1)))"
- exception:bad-body
- (letrec ((x 1))))
+ (with-test-prefix "bad bindings"
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(letrec)"
- exception:bad-body
- (letrec))
+ exception:missing-expr
+ (eval '(letrec)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(letrec 1)"
- exception:bad-body
- (letrec 1))
+ exception:missing-expr
+ (eval '(letrec 1)
+ (interaction-environment)))
- ;; FIXME: Wouldn't one rather expect a 'bad bindings' error?
- ;; Hmm, the body is bad as well, isn't it?
(pass-if-exception "(letrec (x))"
- exception:bad-body
- (letrec (x))))
-
- (with-test-prefix "bad bindings"
+ exception:missing-expr
+ (eval '(letrec (x))
+ (interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
- exception:bad-bindings
- (letrec (x) 1))
+ exception:bad-binding
+ (eval '(letrec (x) 1)
+ (interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
- exception:bad-bindings
- (letrec ((x)) 3))
+ exception:bad-binding
+ (eval '(letrec ((x)) 3)
+ (interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
- exception:bad-bindings
- (letrec ((x 1) y) x))
+ exception:bad-binding
+ (eval '(letrec ((x 1) y) x)
+ (interaction-environment)))
(pass-if-exception "(letrec x ())"
exception:bad-bindings
- (letrec x ()))
+ (eval '(letrec x ())
+ (interaction-environment)))
(pass-if-exception "(letrec x (y))"
exception:bad-bindings
- (letrec x (y)))
+ (eval '(letrec x (y))
+ (interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
- exception:bad-var
- (letrec ((1 2)) 3)))
+ exception:bad-variable
+ (eval '(letrec ((1 2)) 3)
+ (interaction-environment))))
(with-test-prefix "duplicate bindings"
(pass-if-exception "(letrec ((x 1) (x 2)) x)"
- exception:duplicate-bindings
- (letrec ((x 1) (x 2)) x))))
+ exception:duplicate-binding
+ (eval '(letrec ((x 1) (x 2)) x)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(letrec ())"
+ exception:missing-expr
+ (eval '(letrec ())
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec ((x 1)))"
+ exception:missing-expr
+ (eval '(letrec ((x 1)))
+ (interaction-environment)))))
(with-test-prefix "if"
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal if"
+ (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))))))
+
+ (pass-if "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"
+ (let ((foo (lambda () (if #f #f))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ `(lambda () (if #f #f))))))
+
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
exception:missing/extra-expr
- (if))
+ (eval '(if)
+ (interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
exception:missing/extra-expr
- (if 1 2 3 4))))
+ (eval '(if 1 2 3 4)
+ (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))
+
+ (with-test-prefix "bound '=> is handled correctly"
+
+ (pass-if "#t => 'ok"
+ (let ((=> 'foo))
+ (eq? (cond (#t => 'ok)) 'ok)))
+
+ (pass-if "else =>"
+ (let ((=> 'foo))
+ (eq? (cond (else =>)) 'foo)))
+
+ (pass-if "else => identity"
+ (let ((=> 'foo))
+ (eq? (cond (else => identity)) identity)))))
+
+ (with-test-prefix "unmemoization"
+
+ (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
+ (equal? (procedure-source foo)
+ '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
+
+ (pass-if "else"
+ (let ((foo (lambda () (cond (else 'bar)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (cond (else 'bar))))))
+
+ (pass-if "=>"
+ (let ((foo (lambda () (cond (#t => identity)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (cond (#t => identity)))))))
+
(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 "wrong number of arguments"
- (with-test-prefix "bad formals"
+ (pass-if-exception "=> (lambda (x y) #t)"
+ exception:wrong-num-args
+ (cond (1 => (lambda (x y) #t))))))
- (pass-if-exception "=> (lambda (x 1) 2)"
- exception:bad-formals
- (cond (1 => (lambda (x 1) 2))))))
+(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 "unmemoization"
+
+ (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))))))
+
+ (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)))))))
+
+ (with-test-prefix "bad or missing clauses"
-(with-test-prefix "define"
+ (pass-if-exception "(case)"
+ exception:missing-clauses
+ (eval '(case)
+ (interaction-environment)))
+
+ (pass-if-exception "(case . \"foo\")"
+ exception:bad-expression
+ (eval '(case . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1)"
+ exception:missing-clauses
+ (eval '(case 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 . \"foo\")"
+ exception:bad-expression
+ (eval '(case 1 . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 \"foo\")"
+ exception:bad-case-clause
+ (eval '(case 1 "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 ())"
+ exception:bad-case-clause
+ (eval '(case 1 ())
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (\"foo\"))"
+ exception:bad-case-clause
+ (eval '(case 1 ("foo"))
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
+ exception:bad-case-labels
+ (eval '(case 1 ("foo" "bar"))
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
+ exception:bad-expression
+ (eval '(case 1 ((2) "bar") . "foo")
+ (interaction-environment)))
+
+ (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-expression
+ (eval '(case 1 (else #f) . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (else #f) ((1) #t))"
+ exception:misplaced-else-clause
+ (eval '(case 1 (else #f) ((1) #t))
+ (interaction-environment)))))
+
+(with-test-prefix "top-level define"
+
+ (pass-if "binding is created before expression is evaluated"
+ (= (eval '(begin
+ (define foo
+ (begin
+ (set! foo 1)
+ (+ foo 1)))
+ foo)
+ (interaction-environment))
+ 2))
+
+ (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"
+ (eval '(begin
+ (define (blub) (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () (cons ('(1 . 2)) 2))))
+ (interaction-environment)))
+
+ (pass-if "definition with documentation unmemoized without prior execution"
+ (eval '(begin
+ (define (blub) "Comment" (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () "Comment" (cons ('(1 . 2)) 2))))
+ (interaction-environment))))
(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 "internal define"
+
+ (pass-if "internal defines become letrec"
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment)))
+
+ (pass-if "internal defines with begin"
+ (false-if-exception
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (begin
+ (define (b x) (if (= x 0) 'b (c (- x 1)))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment))))
+
+ (pass-if "internal defines with empty begin"
+ (false-if-exception
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (begin)
+ (define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment))))
+
+ (pass-if "internal defines with macro application"
+ (false-if-exception
+ (eval '(begin
+ (defmacro my-define forms
+ (cons 'define forms))
+ (let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (my-define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5)))))
+ (interaction-environment))))
+
+ (pass-if-exception "missing body expression"
+ exception:missing-body-expr
+ (eval '(let () (define x #t))
+ (interaction-environment)))
+
+ (pass-if "unmemoization"
+ (eval '(begin
+ (define (foo)
+ (define (bar)
+ 'ok)
+ (bar))
+ (foo)
+ (equal?
+ (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))))))))
(with-test-prefix "set!"
+ (with-test-prefix "unmemoization"
+
+ (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)))))))
+
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
exception:missing/extra-expr
- (set!))
+ (eval '(set!)
+ (interaction-environment)))
(pass-if-exception "(set! 1)"
exception:missing/extra-expr
- (set! 1))
+ (eval '(set! 1)
+ (interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
exception:missing/extra-expr
- (set! 1 2 3)))
+ (eval '(set! 1 2 3)
+ (interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
- exception:bad-var
- (set! "" #t))
+ exception:bad-variable
+ (eval '(set! "" #t)
+ (interaction-environment)))
(pass-if-exception "(set! 1 #t)"
- exception:bad-var
- (set! 1 #t))
+ exception:bad-variable
+ (eval '(set! 1 #t)
+ (interaction-environment)))
(pass-if-exception "(set! #t #f)"
- exception:bad-var
- (set! #t #f))
+ exception:bad-variable
+ (eval '(set! #t #f)
+ (interaction-environment)))
(pass-if-exception "(set! #f #t)"
- exception:bad-var
- (set! #f #t))
-
- (pass-if-exception "(set! #\space #f)"
- exception:bad-var
- (set! #\space #f))))
-
-(with-test-prefix "generalized set! (SRFI 17)"
-
- (with-test-prefix "target is not procedure with setter"
-
- (pass-if-exception "(set! (symbol->string 'x) 1)"
- exception:wrong-type-arg
- (set! (symbol->string 'x) 1))
+ exception:bad-variable
+ (eval '(set! #f #t)
+ (interaction-environment)))
- (pass-if-exception "(set! '#f 1)"
- exception:wrong-type-arg
- (set! '#f 1))))
+ (pass-if-exception "(set! #\\space #f)"
+ exception:bad-variable
+ (eval '(set! #\space #f)
+ (interaction-environment)))))
(with-test-prefix "quote"
(pass-if-exception "(quote)"
exception:missing/extra-expr
- (quote))
+ (eval '(quote)
+ (interaction-environment)))
(pass-if-exception "(quote a b)"
exception:missing/extra-expr
- (quote a b))))
+ (eval '(quote a b)
+ (interaction-environment)))))
+
+(with-test-prefix "while"
+
+ (define (unreachable)
+ (error "unreachable code has been reached!"))
+
+ ;; 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.
+ (define (make-iterations-cond 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))))
+
+
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (eval '(while) (interaction-environment)))
+
+ (with-test-prefix "empty body"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n)))
+ (while (cond)))
+ #t)))
+
+ (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))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (cond)
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (with-test-prefix "break"
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (while #t
+ (break 1)))
+
+ (with-test-prefix "from cond"
+ (pass-if "first"
+ (while (begin
+ (break)
+ (unreachable))
+ (unreachable))
+ #t)
+
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (if (cond)
+ #t
+ (begin
+ (break)
+ (unreachable)))
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (with-test-prefix "from body"
+ (pass-if "first"
+ (while #t
+ (break)
+ (unreachable))
+ #t)
+
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while #t
+ (if (not (cond))
+ (begin
+ (break)
+ (unreachable)))
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (pass-if "from nested"
+ (while #t
+ (let ((outer-break break))
+ (while #t
+ (outer-break)
+ (unreachable)))
+ (unreachable))
+ #t)
+
+ (pass-if "from recursive"
+ (let ((outer-break #f))
+ (define (r n)
+ (while #t
+ (if (eq? n 'outer)
+ (begin
+ (set! outer-break break)
+ (r 'inner))
+ (begin
+ (outer-break)
+ (unreachable))))
+ (if (eq? n 'inner)
+ (error "broke only from inner loop")))
+ (r 'outer))
+ #t))
+
+ (with-test-prefix "continue"
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (while #t
+ (continue 1)))
+
+ (with-test-prefix "from cond"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (if (cond)
+ (begin
+ (set! i (1+ i))
+ (continue)
+ (unreachable))
+ #f)
+ (unreachable))
+ (= i n)))))
+
+ (with-test-prefix "from body"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (cond)
+ (set! i (1+ i))
+ (continue)
+ (unreachable))
+ (= i n)))))
+
+ (pass-if "from nested"
+ (let ((cond (make-iterations-cond 3)))
+ (while (cond)
+ (let ((outer-continue continue))
+ (while #t
+ (outer-continue)
+ (unreachable)))))
+ #t)
+
+ (pass-if "from recursive"
+ (let ((outer-continue #f))
+ (define (r n)
+ (let ((cond (make-iterations-cond 3))
+ (first #t))
+ (while (begin
+ (if (and (not first)
+ (eq? n 'inner))
+ (error "continued only to inner loop"))
+ (cond))
+ (set! first #f)
+ (if (eq? n 'outer)
+ (begin
+ (set! outer-continue continue)
+ (r 'inner))
+ (begin
+ (outer-continue)
+ (unreachable))))))
+ (r 'outer))
+ #t)))
HCoop / bpt / guile.git / blobdiff