summaryrefslogtreecommitdiff
path: root/test-suite/tests/syntax.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/syntax.test')
-rw-r--r--test-suite/tests/syntax.test1656
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: