diff options
Diffstat (limited to 'test-suite/tests/syntax.test')
-rw-r--r-- | test-suite/tests/syntax.test | 1656 |
1 files changed, 1656 insertions, 0 deletions
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test new file mode 100644 index 000000000..883004a27 --- /dev/null +++ b/test-suite/tests/syntax.test @@ -0,0 +1,1656 @@ +;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- +;;;; +;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, +;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite test-syntax) + #:use-module (ice-9 regex) + #:use-module (ice-9 local-eval) + #:use-module ((system syntax) #:select (syntax?)) + #:use-module (test-suite lib)) + + +(define exception:generic-syncase-error + "source expression failed to match") +(define exception:unexpected-syntax + "unexpected syntax") + +(define exception:bad-expression + "Bad expression") + +(define exception:missing/extra-expr + "Missing or extra expression") +(define exception:missing-expr + "Missing expression") +(define exception:missing-body-expr + "no expressions in body") +(define exception:extra-expr + "Extra expression") +(define exception:illegal-empty-combination + "Illegal empty combination") + +(define exception:bad-lambda + "bad lambda") +(define exception:bad-let + "bad let$") +(define exception:bad-letrec + "bad letrec$") +(define exception:bad-letrec* + "bad letrec\\*$") +(define exception:bad-set! + "bad set!") +(define exception:bad-quote + '(quote . "bad syntax")) +(define exception:bad-bindings + "Bad bindings") +(define exception:bad-binding + "Bad binding") +(define exception:duplicate-binding + "duplicate bound variable") +(define exception:bad-body + "^bad body") +(define exception:bad-formals + "invalid argument list") +(define exception:bad-formal + "Bad formal") +(define exception:duplicate-formals + "duplicate identifier in argument list") + +(define exception:missing-clauses + "Missing clauses") +(define exception:misplaced-else-clause + "Misplaced else clause") +(define exception:bad-case-clause + "Bad case clause") +(define exception:bad-case-labels + "Bad case labels") +(define exception:bad-cond-clause + "Bad cond clause") + +(define exception:too-many-args + "too many arguments") +(define exception:wrong-number-of-values + '(wrong-number-of-args . "number of (values)|(arguments)")) +(define exception:zero-expression-sequence + "sequence of zero expressions") + +(define exception:variable-ref + '(misc-error . "Unbound variable")) + +;; (put 'pass-if-syntax-error 'scheme-indent-function 1) +(define-syntax pass-if-syntax-error + (syntax-rules () + ((_ name pat exp) + (pass-if name + (catch 'syntax-error + (lambda () exp (error "expected syntax-error exception")) + (lambda (k who what where form . maybe-subform) + (if (if (pair? pat) + (and (eq? who (car pat)) + (string-match (cdr pat) what)) + (string-match pat what)) + #t + (error "unexpected syntax-error exception" what pat)))))))) + +(with-test-prefix "expressions" + + (with-test-prefix "Bad argument list" + + (pass-if-syntax-error "improper argument list of length 1" + exception:generic-syncase-error + (eval '(let ((foo (lambda (x y) #t))) + (foo . 1)) + (interaction-environment))) + + (pass-if-syntax-error "improper argument list of length 2" + exception:generic-syncase-error + (eval '(let ((foo (lambda (x y) #t))) + (foo 1 . 2)) + (interaction-environment)))) + + (with-test-prefix "missing or extra expression" + + ;; R5RS says: + ;; *Note:* In many dialects of Lisp, the empty combination, (), + ;; is a legitimate expression. In Scheme, combinations must + ;; have at least one subexpression, so () is not a syntactically + ;; valid expression. + + ;; Fixed on 2001-3-3 + (pass-if-syntax-error "empty parentheses \"()\"" + exception:unexpected-syntax + (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 "extra arguments" + (equal? (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment)) + '(1 2 3 4))))) + +(with-test-prefix "begin" + + (pass-if "valid (begin)" + (eval '(begin (begin) #t) (interaction-environment))) + + (if (not (include-deprecated-features)) + (pass-if-syntax-error "invalid (begin)" + exception:zero-expression-sequence + (eval '(begin (if #t (begin)) #t) (interaction-environment))))) + +(define-syntax matches? + (syntax-rules (<>) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x <>) #t) + ((_ x pat) (equal? x 'pat)))) + +(with-test-prefix "lambda" + + (with-test-prefix "bad formals" + + (pass-if-syntax-error "(lambda)" + exception:bad-lambda + (eval '(lambda) + (interaction-environment))) + + (pass-if-syntax-error "(lambda . \"foo\")" + exception:bad-lambda + (eval '(lambda . "foo") + (interaction-environment))) + + (pass-if-syntax-error "(lambda \"foo\")" + exception:bad-lambda + (eval '(lambda "foo") + (interaction-environment))) + + (pass-if-syntax-error "(lambda \"foo\" #f)" + exception:bad-formals + (eval '(lambda "foo" #f) + (interaction-environment))) + + (pass-if-syntax-error "(lambda (x 1) 2)" + exception:bad-formals + (eval '(lambda (x 1) 2) + (interaction-environment))) + + (pass-if-syntax-error "(lambda (1 x) 2)" + exception:bad-formals + (eval '(lambda (1 x) 2) + (interaction-environment))) + + (pass-if-syntax-error "(lambda (x \"a\") 2)" + exception:bad-formals + (eval '(lambda (x "a") 2) + (interaction-environment))) + + (pass-if-syntax-error "(lambda (\"a\" x) 2)" + exception:bad-formals + (eval '(lambda ("a" x) 2) + (interaction-environment)))) + + (with-test-prefix "duplicate formals" + + ;; Fixed on 2001-3-3 + (pass-if-syntax-error "(lambda (x x) 1)" + exception:duplicate-formals + (eval '(lambda (x x) 1) + (interaction-environment))) + + ;; Fixed on 2001-3-3 + (pass-if-syntax-error "(lambda (x x x) 1)" + exception:duplicate-formals + (eval '(lambda (x x x) 1) + (interaction-environment)))) + + (with-test-prefix "bad body" + + (pass-if-syntax-error "(lambda ())" + exception:bad-lambda + (eval '(lambda ()) + (interaction-environment))))) + +(with-test-prefix "let" + + (with-test-prefix "bindings" + + (pass-if-exception "late binding" + exception:unbound-var + (let ((x 1) (y x)) y))) + + (with-test-prefix "bad bindings" + + (pass-if-syntax-error "(let)" + exception:bad-let + (eval '(let) + (interaction-environment))) + + (pass-if-syntax-error "(let 1)" + exception:bad-let + (eval '(let 1) + (interaction-environment))) + + (pass-if-syntax-error "(let (x))" + exception:bad-let + (eval '(let (x)) + (interaction-environment))) + + (pass-if-syntax-error "(let ((x)))" + exception:bad-let + (eval '(let ((x))) + (interaction-environment))) + + (pass-if-syntax-error "(let (x) 1)" + exception:bad-let + (eval '(let (x) 1) + (interaction-environment))) + + (pass-if-syntax-error "(let ((x)) 3)" + exception:bad-let + (eval '(let ((x)) 3) + (interaction-environment))) + + (pass-if-syntax-error "(let ((x 1) y) x)" + exception:bad-let + (eval '(let ((x 1) y) x) + (interaction-environment))) + + (pass-if-syntax-error "(let ((1 2)) 3)" + exception:bad-let + (eval '(let ((1 2)) 3) + (interaction-environment)))) + + (with-test-prefix "duplicate bindings" + + (pass-if-syntax-error "(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-syntax-error "(let ())" + exception:bad-let + (eval '(let ()) + (interaction-environment))) + + (pass-if-syntax-error "(let ((x 1)))" + exception:bad-let + (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-syntax-error "(let x (y))" + exception:bad-let + (eval '(let x (y)) + (interaction-environment)))) + + (with-test-prefix "bad body" + + (pass-if-syntax-error "(let x ())" + exception:bad-let + (eval '(let x ()) + (interaction-environment))) + + (pass-if-syntax-error "(let x ((y 1)))" + exception:bad-let + (eval '(let x ((y 1))) + (interaction-environment))))) + +(with-test-prefix "let*" + + (with-test-prefix "bindings" + + (pass-if "(let* ((x 1) (x 2)) ...)" + (let* ((x 1) (x 2)) + (= x 2))) + + (pass-if "(let* ((x 1) (x x)) ...)" + (let* ((x 1) (x x)) + (= x 1))) + + (pass-if "(let ((x 1) (y 2)) (let* () ...))" + (let ((x 1) (y 2)) + (let* () + (and (= x 1) (= y 2)))))) + + (with-test-prefix "bad bindings" + + (pass-if-syntax-error "(let*)" + exception:generic-syncase-error + (eval '(let*) + (interaction-environment))) + + (pass-if-syntax-error "(let* 1)" + exception:generic-syncase-error + (eval '(let* 1) + (interaction-environment))) + + (pass-if-syntax-error "(let* (x))" + exception:generic-syncase-error + (eval '(let* (x)) + (interaction-environment))) + + (pass-if-syntax-error "(let* (x) 1)" + exception:generic-syncase-error + (eval '(let* (x) 1) + (interaction-environment))) + + (pass-if-syntax-error "(let* ((x)) 3)" + exception:generic-syncase-error + (eval '(let* ((x)) 3) + (interaction-environment))) + + (pass-if-syntax-error "(let* ((x 1) y) x)" + exception:generic-syncase-error + (eval '(let* ((x 1) y) x) + (interaction-environment))) + + (pass-if-syntax-error "(let* x ())" + exception:generic-syncase-error + (eval '(let* x ()) + (interaction-environment))) + + (pass-if-syntax-error "(let* x (y))" + exception:generic-syncase-error + (eval '(let* x (y)) + (interaction-environment))) + + (pass-if-syntax-error "(let* ((1 2)) 3)" + exception:generic-syncase-error + (eval '(let* ((1 2)) 3) + (interaction-environment)))) + + (with-test-prefix "bad body" + + (pass-if-syntax-error "(let* ())" + exception:generic-syncase-error + (eval '(let* ()) + (interaction-environment))) + + (pass-if-syntax-error "(let* ((x 1)))" + exception:generic-syncase-error + (eval '(let* ((x 1))) + (interaction-environment))))) + +(with-test-prefix "letrec" + + (with-test-prefix "bindings" + + (pass-if-exception "initial bindings are undefined" + exception:variable-ref + (eval '(let ((x 1)) + (letrec ((x 1) (y x)) y)) + (interaction-environment)))) + + (with-test-prefix "bad bindings" + + (pass-if-syntax-error "(letrec)" + exception:bad-letrec + (eval '(letrec) + (interaction-environment))) + + (pass-if-syntax-error "(letrec 1)" + exception:bad-letrec + (eval '(letrec 1) + (interaction-environment))) + + (pass-if-syntax-error "(letrec (x))" + exception:bad-letrec + (eval '(letrec (x)) + (interaction-environment))) + + (pass-if-syntax-error "(letrec (x) 1)" + exception:bad-letrec + (eval '(letrec (x) 1) + (interaction-environment))) + + (pass-if-syntax-error "(letrec ((x)) 3)" + exception:bad-letrec + (eval '(letrec ((x)) 3) + (interaction-environment))) + + (pass-if-syntax-error "(letrec ((x 1) y) x)" + exception:bad-letrec + (eval '(letrec ((x 1) y) x) + (interaction-environment))) + + (pass-if-syntax-error "(letrec x ())" + exception:bad-letrec + (eval '(letrec x ()) + (interaction-environment))) + + (pass-if-syntax-error "(letrec x (y))" + exception:bad-letrec + (eval '(letrec x (y)) + (interaction-environment))) + + (pass-if-syntax-error "(letrec ((1 2)) 3)" + exception:bad-letrec + (eval '(letrec ((1 2)) 3) + (interaction-environment)))) + + (with-test-prefix "duplicate bindings" + + (pass-if-syntax-error "(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-syntax-error "(letrec ())" + exception:bad-letrec + (eval '(letrec ()) + (interaction-environment))) + + (pass-if-syntax-error "(letrec ((x 1)))" + exception:bad-letrec + (eval '(letrec ((x 1))) + (interaction-environment))))) + +(with-test-prefix "letrec*" + + (with-test-prefix "bindings" + + (pass-if-exception "initial bindings are undefined" + exception:variable-ref + (eval '(letrec* ((x y) (y 1)) y) + (interaction-environment)))) + + (with-test-prefix "bad bindings" + + (pass-if-syntax-error "(letrec*)" + exception:bad-letrec* + (eval '(letrec*) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* 1)" + exception:bad-letrec* + (eval '(letrec* 1) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* (x))" + exception:bad-letrec* + (eval '(letrec* (x)) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* (x) 1)" + exception:bad-letrec* + (eval '(letrec* (x) 1) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* ((x)) 3)" + exception:bad-letrec* + (eval '(letrec* ((x)) 3) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* ((x 1) y) x)" + exception:bad-letrec* + (eval '(letrec* ((x 1) y) x) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* x ())" + exception:bad-letrec* + (eval '(letrec* x ()) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* x (y))" + exception:bad-letrec* + (eval '(letrec* x (y)) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* ((1 2)) 3)" + exception:bad-letrec* + (eval '(letrec* ((1 2)) 3) + (interaction-environment)))) + + (with-test-prefix "duplicate bindings" + + (pass-if-syntax-error "(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-syntax-error "(letrec* ())" + exception:bad-letrec* + (eval '(letrec* ()) + (interaction-environment))) + + (pass-if-syntax-error "(letrec* ((x 1)))" + exception:bad-letrec* + (eval '(letrec* ((x 1))) + (interaction-environment)))) + + (with-test-prefix "referencing previous values" + (pass-if (equal? (letrec* ((a (cons 'foo 'bar)) + (b a)) + b) + '(foo . bar))) + (pass-if (equal? (let () + (define a (cons 'foo 'bar)) + (define b a) + b) + '(foo . bar))))) + +(with-test-prefix "if" + + (with-test-prefix "missing or extra expressions" + + (pass-if-syntax-error "(if)" + exception:generic-syncase-error + (eval '(if) + (interaction-environment))) + + (pass-if-syntax-error "(if 1 2 3 4)" + exception:generic-syncase-error + (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 "SRFI-61" + + (pass-if "always available" + (cond-expand (srfi-61 #t) (else #f))) + + (pass-if "single value consequent" + (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f)))) + + (pass-if "single value alternate" + (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok)))) + + (pass-if-exception "doesn't affect standard =>" + exception:wrong-num-args + (cond ((values 1 2) => (lambda (x y) #t)))) + + (pass-if "multiple values consequent" + (equal? '(2 1) (cond ((values 1 2) + (lambda (one two) + (and (= 1 one) (= 2 two))) => + (lambda (one two) (list two one))) + (else #f)))) + + (pass-if "multiple values alternate" + (eq? 'ok (cond ((values 2 3 4) + (lambda args (equal? '(1 2 3) args)) => + (lambda (x y z) #f)) + (else 'ok)))) + + (pass-if "zero values" + (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok)) + (else #f)))) + + (pass-if "bound => is handled correctly" + (let ((=> 'ok)) + (eq? 'ok (cond (#t identity =>) (else #f))))) + + (pass-if-syntax-error "missing recipient" + '(cond . "wrong number of receiver expressions") + (eval '(cond (#t identity =>)) + (interaction-environment))) + + (pass-if-syntax-error "extra recipient" + '(cond . "wrong number of receiver expressions") + (eval '(cond (#t identity => identity identity)) + (interaction-environment)))) + + (with-test-prefix "bad or missing clauses" + + (pass-if-syntax-error "(cond)" + exception:generic-syncase-error + (eval '(cond) + (interaction-environment))) + + (pass-if-syntax-error "(cond #t)" + '(cond . "invalid clause") + (eval '(cond #t) + (interaction-environment))) + + (pass-if-syntax-error "(cond 1)" + '(cond . "invalid clause") + (eval '(cond 1) + (interaction-environment))) + + (pass-if-syntax-error "(cond 1 2)" + '(cond . "invalid clause") + (eval '(cond 1 2) + (interaction-environment))) + + (pass-if-syntax-error "(cond 1 2 3)" + '(cond . "invalid clause") + (eval '(cond 1 2 3) + (interaction-environment))) + + (pass-if-syntax-error "(cond 1 2 3 4)" + '(cond . "invalid clause") + (eval '(cond 1 2 3 4) + (interaction-environment))) + + (pass-if-syntax-error "(cond ())" + '(cond . "invalid clause") + (eval '(cond ()) + (interaction-environment))) + + (pass-if-syntax-error "(cond () 1)" + '(cond . "invalid clause") + (eval '(cond () 1) + (interaction-environment))) + + (pass-if-syntax-error "(cond (1) 1)" + '(cond . "invalid clause") + (eval '(cond (1) 1) + (interaction-environment))) + + (pass-if-syntax-error "(cond (else #f) (#t #t))" + '(cond . "else must be the last clause") + (eval '(cond (else #f) (#t #t)) + (interaction-environment)))) + + (with-test-prefix "wrong number of arguments" + + (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 handles '=> correctly" + + (pass-if "(1 2 3) => list" + (equal? (case 1 ((1 2 3) => list)) + '(1))) + + (pass-if "else => list" + (equal? (case 6 + ((1 2 3) 'wrong) + (else => list)) + '(6))) + + (with-test-prefix "bound '=> is handled correctly" + + (pass-if "(1) => 'ok" + (let ((=> 'foo)) + (eq? (case 1 ((1) => 'ok)) 'ok))) + + (pass-if "else =>" + (let ((=> 'foo)) + (eq? (case 1 (else =>)) 'foo))) + + (pass-if "else => list" + (let ((=> 'foo)) + (eq? (case 1 (else => identity)) identity)))) + + (pass-if-syntax-error "missing recipient" + '(case . "wrong number of receiver expressions") + (eval '(case 1 ((1) =>)) + (interaction-environment))) + + (pass-if-syntax-error "extra recipient" + '(case . "wrong number of receiver expressions") + (eval '(case 1 ((1) => identity identity)) + (interaction-environment)))) + + (with-test-prefix "case is hygienic" + + (pass-if-syntax-error "bound 'else is handled correctly" + '(case . "invalid clause") + (eval '(let ((else #f)) (case 1 (else #f))) + (interaction-environment)))) + + (with-test-prefix "bad or missing clauses" + + (pass-if-syntax-error "(case)" + exception:generic-syncase-error + (eval '(case) + (interaction-environment))) + + (pass-if-syntax-error "(case . \"foo\")" + exception:generic-syncase-error + (eval '(case . "foo") + (interaction-environment))) + + (pass-if-syntax-error "(case 1)" + exception:generic-syncase-error + (eval '(case 1) + (interaction-environment))) + + (pass-if-syntax-error "(case 1 . \"foo\")" + exception:generic-syncase-error + (eval '(case 1 . "foo") + (interaction-environment))) + + (pass-if-syntax-error "(case 1 \"foo\")" + '(case . "invalid clause") + (eval '(case 1 "foo") + (interaction-environment))) + + (pass-if-syntax-error "(case 1 ())" + '(case . "invalid clause") + (eval '(case 1 ()) + (interaction-environment))) + + (pass-if-syntax-error "(case 1 (\"foo\"))" + '(case . "invalid clause") + (eval '(case 1 ("foo")) + (interaction-environment))) + + (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))" + '(case . "invalid clause") + (eval '(case 1 ("foo" "bar")) + (interaction-environment))) + + (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")" + exception:generic-syncase-error + (eval '(case 1 ((2) "bar") . "foo") + (interaction-environment))) + + (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))" + '(case . "invalid clause") + (eval '(case 1 ((2) "bar") (else)) + (interaction-environment))) + + (pass-if-syntax-error "(case 1 (else #f) . \"foo\")" + exception:generic-syncase-error + (eval '(case 1 (else #f) . "foo") + (interaction-environment))) + + (pass-if-syntax-error "(case 1 (else #f) ((1) #t))" + '(case . "else must be the last clause") + (eval '(case 1 (else #f) ((1) #t)) + (interaction-environment))))) + +(with-test-prefix "top-level define" + + (pass-if "redefinition" + (let ((m (make-module))) + (beautify-user-module! m) + + ;; The previous value of `round' must still be visible at the time the + ;; new `round' is defined. According to R5RS (Section 5.2.1), `define' + ;; should behave like `set!' in this case (except that in the case of + ;; Guile, we respect module boundaries). + (eval '(define round round) m) + (eq? (module-ref m 'round) round))) + + (with-test-prefix "missing or extra expressions" + + (pass-if-syntax-error "(define)" + exception:generic-syncase-error + (eval '(define) + (interaction-environment)))) + + (pass-if "module scoping" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-1) + #:export (define-10)) + (define-syntax-rule (define-10 name) + (begin + (define t 10) + (define (name) t))) + (define-module (top-level-define/module-scoping-2) + #:use-module (top-level-define/module-scoping-1)) + (define-10 foo) + (foo)) + (current-module)) + 10)) + + (pass-if "module scoping, same symbolic name" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-3)) + (define a 10) + (define-module (top-level-define/module-scoping-4) + #:use-module (top-level-define/module-scoping-3)) + (define a (@@ (top-level-define/module-scoping-3) a)) + a) + (current-module)) + 10)) + + (pass-if "module scoping, introduced names" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-5) + #:export (define-constant)) + (define-syntax-rule (define-constant name val) + (begin + (define t val) + (define (name) t))) + (define-module (top-level-define/module-scoping-6) + #:use-module (top-level-define/module-scoping-5)) + (define-constant foo 10) + (define-constant bar 20) + (foo)) + (current-module)) + 10)) + + (pass-if "module scoping, duplicate introduced name" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-7) + #:export (define-constant)) + (define-syntax-rule (define-constant name val) + (begin + (define t val) + (define (name) t))) + (define-module (top-level-define/module-scoping-8) + #:use-module (top-level-define/module-scoping-7)) + (define-constant foo 10) + (define-constant foo 20) + (foo)) + (current-module)) + 20))) + +(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 "binding is created before expression is evaluated" + ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2). + (= (eval '(let () + (define foo + (begin + (set! foo 1) + (+ foo 1))) + foo) + (interaction-environment)) + 2)) + + (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-syntax-error "missing body expression" + exception:missing-body-expr + (eval '(let () (define x #t)) + (interaction-environment)))) + +(with-test-prefix "top-level define-values" + + (pass-if "zero values" + (eval '(begin (define-values () (values)) + #t) + (interaction-environment))) + + (pass-if-equal "one value" + 1 + (eval '(begin (define-values (x) 1) + x) + (interaction-environment))) + + (pass-if-equal "two values" + '(2 3) + (eval '(begin (define-values (x y) (values 2 3)) + (list x y)) + (interaction-environment))) + + (pass-if-equal "three values" + '(4 5 6) + (eval '(begin (define-values (x y z) (values 4 5 6)) + (list x y z)) + (interaction-environment))) + + (pass-if-equal "one value with tail" + '(a (b c d)) + (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd)) + (list x y)) + (interaction-environment))) + + (pass-if-equal "two values with tail" + '(x y (z w)) + (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w)) + (list x y z)) + (interaction-environment))) + + (pass-if-equal "just tail" + '(1 2 3) + (eval '(begin (define-values x (values 1 2 3)) + x) + (interaction-environment))) + + (pass-if-exception "expected 0 values, got 1" + exception:wrong-number-of-values + (eval '(define-values () 1) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 0" + exception:wrong-number-of-values + (eval '(define-values (x) (values)) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 2" + exception:wrong-number-of-values + (eval '(define-values (x) (values 1 2)) + (interaction-environment))) + + (pass-if-exception "expected 1 value with tail, got 0" + exception:wrong-number-of-values + (eval '(define-values (x . y) (values)) + (interaction-environment))) + + (pass-if-exception "expected 2 value with tail, got 1" + exception:wrong-number-of-values + (eval '(define-values (x y . z) 1) + (interaction-environment))) + + (pass-if "redefinition" + (let ((m (make-module))) + (beautify-user-module! m) + + ;; The previous values of `floor' and `round' must still be + ;; visible at the time the new `floor' and `round' are defined. + (eval '(define-values (floor round) (values floor round)) m) + (and (eq? (module-ref m 'floor) floor) + (eq? (module-ref m 'round) round)))) + + (with-test-prefix "missing expression" + + (pass-if-syntax-error "(define-values)" + exception:generic-syncase-error + (eval '(define-values) + (interaction-environment))))) + +(with-test-prefix "internal define-values" + + (pass-if "zero values" + (let () + (define-values () (values)) + #t)) + + (pass-if-equal "one value" + 1 + (let () + (define-values (x) 1) + x)) + + (pass-if-equal "two values" + '(2 3) + (let () + (define-values (x y) (values 2 3)) + (list x y))) + + (pass-if-equal "three values" + '(4 5 6) + (let () + (define-values (x y z) (values 4 5 6)) + (list x y z))) + + (pass-if-equal "one value with tail" + '(a (b c d)) + (let () + (define-values (x . y) (values 'a 'b 'c 'd)) + (list x y))) + + (pass-if-equal "two values with tail" + '(x y (z w)) + (let () + (define-values (x y . z) (values 'x 'y 'z 'w)) + (list x y z))) + + (pass-if-equal "just tail" + '(1 2 3) + (let () + (define-values x (values 1 2 3)) + x)) + + (pass-if-exception "expected 0 values, got 1" + exception:wrong-number-of-values + (eval '(let () + (define-values () 1) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 0" + exception:wrong-number-of-values + (eval '(let () + (define-values (x) (values)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 2" + exception:wrong-number-of-values + (eval '(let () + (define-values (x) (values 1 2)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value with tail, got 0" + exception:wrong-number-of-values + (eval '(let () + (define-values (x . y) (values)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 2 value with tail, got 1" + exception:wrong-number-of-values + (eval '(let () + (define-values (x y . z) 1) + #f) + (interaction-environment))) + + (with-test-prefix "missing expression" + + (pass-if-syntax-error "(define-values)" + exception:generic-syncase-error + (eval '(let () + (define-values) + #f) + (interaction-environment))))) + +(with-test-prefix "set!" + + (with-test-prefix "missing or extra expressions" + + (pass-if-syntax-error "(set!)" + exception:bad-set! + (eval '(set!) + (interaction-environment))) + + (pass-if-syntax-error "(set! 1)" + exception:bad-set! + (eval '(set! 1) + (interaction-environment))) + + (pass-if-syntax-error "(set! 1 2 3)" + exception:bad-set! + (eval '(set! 1 2 3) + (interaction-environment)))) + + (with-test-prefix "bad variable" + + (pass-if-syntax-error "(set! \"\" #t)" + exception:bad-set! + (eval '(set! "" #t) + (interaction-environment))) + + (pass-if-syntax-error "(set! 1 #t)" + exception:bad-set! + (eval '(set! 1 #t) + (interaction-environment))) + + (pass-if-syntax-error "(set! #t #f)" + exception:bad-set! + (eval '(set! #t #f) + (interaction-environment))) + + (pass-if-syntax-error "(set! #f #t)" + exception:bad-set! + (eval '(set! #f #t) + (interaction-environment))) + + (pass-if-syntax-error "(set! #\\space #f)" + exception:bad-set! + (eval '(set! #\space #f) + (interaction-environment))))) + +(with-test-prefix "quote" + + (with-test-prefix "missing or extra expression" + + (pass-if-syntax-error "(quote)" + exception:bad-quote + (eval '(quote) + (interaction-environment))) + + (pass-if-syntax-error "(quote a b)" + exception:bad-quote + (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-syntax-error "too few args" exception:generic-syncase-error + (eval '(while) (interaction-environment))) + + (with-test-prefix "empty body" + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (eval `(letrec ((make-iterations-cond + (lambda (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)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) + + (pass-if "initially false" + (while #f + (unreachable)) + #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 "normal return" + (not (while #f (error "not reached")))) + + (pass-if "no args" + (while #t (break))) + + (pass-if "multiple values" + (equal? '(1 2 3) + (call-with-values + (lambda () (while #t (break 1 2 3))) + list))) + + (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-syntax-error "too many args" exception:too-many-args + (eval '(while #t + (continue 1)) + (interaction-environment))) + + (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))) + +(with-test-prefix "syntax-rules" + + (pass-if-equal "custom ellipsis within normal ellipsis" + '((((a x) (a y) (a …)) + ((b x) (b y) (b …)) + ((c x) (c y) (c …))) + (((a x) (b x) (c x)) + ((a y) (b y) (c y)) + ((a …) (b …) (c …)))) + (let () + (define-syntax foo + (syntax-rules () + ((_ y ...) + (syntax-rules … () + ((_ x …) + '((((x y) ...) …) + (((x y) …) ...))))))) + (define-syntax bar (foo x y …)) + (bar a b c))) + + (pass-if-equal "normal ellipsis within custom ellipsis" + '((((a x) (a y) (a z)) + ((b x) (b y) (b z)) + ((c x) (c y) (c z))) + (((a x) (b x) (c x)) + ((a y) (b y) (c y)) + ((a z) (b z) (c z)))) + (let () + (define-syntax foo + (syntax-rules … () + ((_ y …) + (syntax-rules () + ((_ x ...) + '((((x y) …) ...) + (((x y) ...) …))))))) + (define-syntax bar (foo x y z)) + (bar a b c))) + + ;; This test is given in SRFI-46. + (pass-if-equal "custom ellipsis is handled hygienically" + '((1) 2 (3) (4)) + (let-syntax + ((f (syntax-rules () + ((f ?e) + (let-syntax + ((g (syntax-rules --- () + ((g (??x ?e) (??y ---)) + '((??x) ?e (??y) ---))))) + (g (1 2) (3 4))))))) + (f ---)))) + +(with-test-prefix "syntax-error" + + (pass-if-syntax-error "outside of macro without args" + "test error" + (eval '(syntax-error "test error") + (interaction-environment))) + + (pass-if-syntax-error "outside of macro with args" + "test error x \\(y z\\)" + (eval '(syntax-error "test error" x (y z)) + (interaction-environment))) + + (pass-if-equal "within macro" + '(simple-let + "expected an identifier but got (z1 z2)" + (simple-let ((y (* x x)) + ((z1 z2) (values x x))) + (+ y 1))) + (catch 'syntax-error + (lambda () + (eval '(let () + (define-syntax simple-let + (syntax-rules () + ((_ (head ... ((x . y) val) . tail) + body1 body2 ...) + (syntax-error + "expected an identifier but got" + (x . y))) + ((_ ((name val) ...) body1 body2 ...) + ((lambda (name ...) body1 body2 ...) + val ...)))) + (define (foo x) + (simple-let ((y (* x x)) + ((z1 z2) (values x x))) + (+ y 1))) + foo) + (interaction-environment)) + (error "expected syntax-error exception")) + (lambda (k who what where form . maybe-subform) + (list who what form))))) + +(with-test-prefix "syntax-case" + + (pass-if-syntax-error "duplicate pattern variable" + '(syntax-case . "duplicate pattern variable") + (eval '(lambda (e) + (syntax-case e () + ((a b c d e d f) #f))) + (interaction-environment))) + + (with-test-prefix "misplaced ellipses" + + (pass-if-syntax-error "bare ellipsis" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + (... #f))) + (interaction-environment))) + + (pass-if-syntax-error "ellipsis singleton" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + ((...) #f))) + (interaction-environment))) + + (pass-if-syntax-error "ellipsis in car" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + ((... . _) #f))) + (interaction-environment))) + + (pass-if-syntax-error "ellipsis in cdr" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + ((_ . ...) #f))) + (interaction-environment))) + + (pass-if-syntax-error "two ellipses in the same list" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + ((x ... y ...) #f))) + (interaction-environment))) + + (pass-if-syntax-error "three ellipses in the same list" + '(syntax-case . "misplaced ellipsis") + (eval '(lambda (e) + (syntax-case e () + ((x ... y ... z ...) #f))) + (interaction-environment))))) + +(with-test-prefix "with-ellipsis" + + (pass-if-equal "simple" + '(a 1 2 3) + (let () + (define-syntax define-quotation-macros + (lambda (x) + (syntax-case x () + ((_ (macro-name head-symbol) ...) + #'(begin (define-syntax macro-name + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_ x …) + #'(quote (head-symbol x …))))))) + ...))))) + (define-quotation-macros (quote-a a) (quote-b b)) + (quote-a 1 2 3))) + + (pass-if-equal "disables normal ellipsis" + '(a ...) + (let () + (define-syntax foo + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_) + #'(quote (a ...))))))) + (foo))) + + (pass-if-equal "doesn't affect ellipsis for generated code" + '(a b c) + (let () + (define-syntax quotation-macro + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_) + #'(lambda (x) + (syntax-case x () + ((_ x ...) + #'(quote (x ...)))))))))) + (define-syntax kwote (quotation-macro)) + (kwote a b c))) + + (pass-if-equal "propagates into syntax binders" + '(a b c) + (let () + (with-ellipsis … + (define-syntax kwote + (lambda (x) + (syntax-case x () + ((_ x …) + #'(quote (x …)))))) + (kwote a b c)))) + + (pass-if-equal "works with local-eval" + 5 + (let ((env (with-ellipsis … (the-environment)))) + (local-eval '(syntax-case #'(a b c d e) () + ((x …) + (length #'(x …)))) + env)))) + +(with-test-prefix "syntax objects" + (let ((interpreted (eval '#'(foo bar baz) (current-module))) + (interpreted-bis (eval '#'(foo bar baz) (current-module))) + (compiled ((@ (system base compile) compile) '#'(foo bar baz) + #:env (current-module)))) + ;; Guile's expander doesn't wrap lists. + (pass-if "interpreted syntax object?" + (and (list? interpreted) + (and-map syntax? interpreted))) + (pass-if "compiled syntax object?" + (and (list? compiled) + (and-map syntax? compiled))) + + (pass-if "interpreted syntax objects are not vectors" + (not (vector? interpreted))) + (pass-if "compiled syntax objects are not vectors" + (not (vector? compiled))) + + (pass-if-equal "syntax objects comparable with equal? (eval/eval)" + interpreted interpreted-bis) + (pass-if-equal "syntax objects comparable with equal? (eval/compile)" + interpreted compiled) + + (pass-if-equal "syntax objects hash the same (eval/eval)" + (hash interpreted most-positive-fixnum) + (hash interpreted-bis most-positive-fixnum)) + + (pass-if-equal "syntax objects hash the same (eval/compile)" + (hash interpreted most-positive-fixnum) + (hash compiled most-positive-fixnum)))) + + +;;; Local Variables: +;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) +;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) +;;; End: |