1 ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
3 ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010,
4 ;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-syntax)
21 #:use-module (ice-9 regex)
22 #:use-module (ice-9 local-eval)
23 #:use-module (test-suite lib))
26 (define exception:generic-syncase-error
27 "source expression failed to match")
28 (define exception:unexpected-syntax
31 (define exception:bad-expression
34 (define exception:missing/extra-expr
35 "Missing or extra expression")
36 (define exception:missing-expr
38 (define exception:missing-body-expr
39 "no expressions in body")
40 (define exception:extra-expr
42 (define exception:illegal-empty-combination
43 "Illegal empty combination")
45 (define exception:bad-lambda
47 (define exception:bad-let
49 (define exception:bad-letrec
51 (define exception:bad-letrec*
53 (define exception:bad-set!
55 (define exception:bad-quote
56 '(quote . "bad syntax"))
57 (define exception:bad-bindings
59 (define exception:bad-binding
61 (define exception:duplicate-binding
62 "duplicate bound variable")
63 (define exception:bad-body
65 (define exception:bad-formals
66 "invalid argument list")
67 (define exception:bad-formal
69 (define exception:duplicate-formals
70 "duplicate identifier in argument list")
72 (define exception:missing-clauses
74 (define exception:misplaced-else-clause
75 "Misplaced else clause")
76 (define exception:bad-case-clause
78 (define exception:bad-case-labels
80 (define exception:bad-cond-clause
83 (define exception:too-many-args
85 (define exception:zero-expression-sequence
86 "sequence of zero expressions")
88 (define exception:define-values-wrong-number-of-return-values
89 (cons 'wrong-number-of-args "^define-values: wrong number of return values returned by expression"))
92 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
93 (define-syntax pass-if-syntax-error
98 (lambda () exp (error "expected syntax-error exception"))
99 (lambda (k who what where form . maybe-subform)
101 (and (eq? who (car pat))
102 (string-match (cdr pat) what))
103 (string-match pat what))
105 (error "unexpected syntax-error exception" what pat))))))))
107 (with-test-prefix "expressions"
109 (with-test-prefix "Bad argument list"
111 (pass-if-syntax-error "improper argument list of length 1"
112 exception:generic-syncase-error
113 (eval '(let ((foo (lambda (x y) #t)))
115 (interaction-environment)))
117 (pass-if-syntax-error "improper argument list of length 2"
118 exception:generic-syncase-error
119 (eval '(let ((foo (lambda (x y) #t)))
121 (interaction-environment))))
123 (with-test-prefix "missing or extra expression"
126 ;; *Note:* In many dialects of Lisp, the empty combination, (),
127 ;; is a legitimate expression. In Scheme, combinations must
128 ;; have at least one subexpression, so () is not a syntactically
132 (pass-if-syntax-error "empty parentheses \"()\""
133 exception:unexpected-syntax
135 (interaction-environment)))))
137 (with-test-prefix "quote"
140 (with-test-prefix "quasiquote"
142 (with-test-prefix "unquote"
144 (pass-if "repeated execution"
145 (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
146 (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
148 (with-test-prefix "unquote-splicing"
150 (pass-if "extra arguments"
151 (equal? (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
152 (interaction-environment))
155 (with-test-prefix "begin"
157 (pass-if "valid (begin)"
158 (eval '(begin (begin) #t) (interaction-environment)))
160 (if (not (include-deprecated-features))
161 (pass-if-syntax-error "invalid (begin)"
162 exception:zero-expression-sequence
163 (eval '(begin (if #t (begin)) #t) (interaction-environment)))))
165 (define-syntax matches?
167 ((_ (op arg ...) pat) (let ((x (op arg ...)))
170 ((_ x (a . b)) (and (pair? x)
172 (matches? (cdr x) b)))
174 ((_ x pat) (equal? x 'pat))))
176 (with-test-prefix "lambda"
178 (with-test-prefix "bad formals"
180 (pass-if-syntax-error "(lambda)"
183 (interaction-environment)))
185 (pass-if-syntax-error "(lambda . \"foo\")"
187 (eval '(lambda . "foo")
188 (interaction-environment)))
190 (pass-if-syntax-error "(lambda \"foo\")"
192 (eval '(lambda "foo")
193 (interaction-environment)))
195 (pass-if-syntax-error "(lambda \"foo\" #f)"
196 exception:bad-formals
197 (eval '(lambda "foo" #f)
198 (interaction-environment)))
200 (pass-if-syntax-error "(lambda (x 1) 2)"
201 exception:bad-formals
202 (eval '(lambda (x 1) 2)
203 (interaction-environment)))
205 (pass-if-syntax-error "(lambda (1 x) 2)"
206 exception:bad-formals
207 (eval '(lambda (1 x) 2)
208 (interaction-environment)))
210 (pass-if-syntax-error "(lambda (x \"a\") 2)"
211 exception:bad-formals
212 (eval '(lambda (x "a") 2)
213 (interaction-environment)))
215 (pass-if-syntax-error "(lambda (\"a\" x) 2)"
216 exception:bad-formals
217 (eval '(lambda ("a" x) 2)
218 (interaction-environment))))
220 (with-test-prefix "duplicate formals"
223 (pass-if-syntax-error "(lambda (x x) 1)"
224 exception:duplicate-formals
225 (eval '(lambda (x x) 1)
226 (interaction-environment)))
229 (pass-if-syntax-error "(lambda (x x x) 1)"
230 exception:duplicate-formals
231 (eval '(lambda (x x x) 1)
232 (interaction-environment))))
234 (with-test-prefix "bad body"
236 (pass-if-syntax-error "(lambda ())"
239 (interaction-environment)))))
241 (with-test-prefix "let"
243 (with-test-prefix "bindings"
245 (pass-if-exception "late binding"
246 exception:unbound-var
247 (let ((x 1) (y x)) y)))
249 (with-test-prefix "bad bindings"
251 (pass-if-syntax-error "(let)"
254 (interaction-environment)))
256 (pass-if-syntax-error "(let 1)"
259 (interaction-environment)))
261 (pass-if-syntax-error "(let (x))"
264 (interaction-environment)))
266 (pass-if-syntax-error "(let ((x)))"
269 (interaction-environment)))
271 (pass-if-syntax-error "(let (x) 1)"
274 (interaction-environment)))
276 (pass-if-syntax-error "(let ((x)) 3)"
279 (interaction-environment)))
281 (pass-if-syntax-error "(let ((x 1) y) x)"
283 (eval '(let ((x 1) y) x)
284 (interaction-environment)))
286 (pass-if-syntax-error "(let ((1 2)) 3)"
288 (eval '(let ((1 2)) 3)
289 (interaction-environment))))
291 (with-test-prefix "duplicate bindings"
293 (pass-if-syntax-error "(let ((x 1) (x 2)) x)"
294 exception:duplicate-binding
295 (eval '(let ((x 1) (x 2)) x)
296 (interaction-environment))))
298 (with-test-prefix "bad body"
300 (pass-if-syntax-error "(let ())"
303 (interaction-environment)))
305 (pass-if-syntax-error "(let ((x 1)))"
308 (interaction-environment)))))
310 (with-test-prefix "named let"
312 (with-test-prefix "initializers"
314 (pass-if "evaluated in outer environment"
316 (eqv? (let f ((n (f 1))) n) -1))))
318 (with-test-prefix "bad bindings"
320 (pass-if-syntax-error "(let x (y))"
323 (interaction-environment))))
325 (with-test-prefix "bad body"
327 (pass-if-syntax-error "(let x ())"
330 (interaction-environment)))
332 (pass-if-syntax-error "(let x ((y 1)))"
334 (eval '(let x ((y 1)))
335 (interaction-environment)))))
337 (with-test-prefix "let*"
339 (with-test-prefix "bindings"
341 (pass-if "(let* ((x 1) (x 2)) ...)"
345 (pass-if "(let* ((x 1) (x x)) ...)"
349 (pass-if "(let ((x 1) (y 2)) (let* () ...))"
352 (and (= x 1) (= y 2))))))
354 (with-test-prefix "bad bindings"
356 (pass-if-syntax-error "(let*)"
357 exception:generic-syncase-error
359 (interaction-environment)))
361 (pass-if-syntax-error "(let* 1)"
362 exception:generic-syncase-error
364 (interaction-environment)))
366 (pass-if-syntax-error "(let* (x))"
367 exception:generic-syncase-error
369 (interaction-environment)))
371 (pass-if-syntax-error "(let* (x) 1)"
372 exception:generic-syncase-error
374 (interaction-environment)))
376 (pass-if-syntax-error "(let* ((x)) 3)"
377 exception:generic-syncase-error
378 (eval '(let* ((x)) 3)
379 (interaction-environment)))
381 (pass-if-syntax-error "(let* ((x 1) y) x)"
382 exception:generic-syncase-error
383 (eval '(let* ((x 1) y) x)
384 (interaction-environment)))
386 (pass-if-syntax-error "(let* x ())"
387 exception:generic-syncase-error
389 (interaction-environment)))
391 (pass-if-syntax-error "(let* x (y))"
392 exception:generic-syncase-error
394 (interaction-environment)))
396 (pass-if-syntax-error "(let* ((1 2)) 3)"
397 exception:generic-syncase-error
398 (eval '(let* ((1 2)) 3)
399 (interaction-environment))))
401 (with-test-prefix "bad body"
403 (pass-if-syntax-error "(let* ())"
404 exception:generic-syncase-error
406 (interaction-environment)))
408 (pass-if-syntax-error "(let* ((x 1)))"
409 exception:generic-syncase-error
410 (eval '(let* ((x 1)))
411 (interaction-environment)))))
413 (with-test-prefix "letrec"
415 (with-test-prefix "bindings"
417 (pass-if-syntax-error "initial bindings are undefined"
418 exception:used-before-defined
420 ;; FIXME: the memoizer does initialize the var to undefined, but
421 ;; the Scheme evaluator has no way of checking what's an
422 ;; undefined value. Not sure how to do this.
424 (letrec ((x 1) (y x)) y))))
426 (with-test-prefix "bad bindings"
428 (pass-if-syntax-error "(letrec)"
431 (interaction-environment)))
433 (pass-if-syntax-error "(letrec 1)"
436 (interaction-environment)))
438 (pass-if-syntax-error "(letrec (x))"
441 (interaction-environment)))
443 (pass-if-syntax-error "(letrec (x) 1)"
445 (eval '(letrec (x) 1)
446 (interaction-environment)))
448 (pass-if-syntax-error "(letrec ((x)) 3)"
450 (eval '(letrec ((x)) 3)
451 (interaction-environment)))
453 (pass-if-syntax-error "(letrec ((x 1) y) x)"
455 (eval '(letrec ((x 1) y) x)
456 (interaction-environment)))
458 (pass-if-syntax-error "(letrec x ())"
461 (interaction-environment)))
463 (pass-if-syntax-error "(letrec x (y))"
465 (eval '(letrec x (y))
466 (interaction-environment)))
468 (pass-if-syntax-error "(letrec ((1 2)) 3)"
470 (eval '(letrec ((1 2)) 3)
471 (interaction-environment))))
473 (with-test-prefix "duplicate bindings"
475 (pass-if-syntax-error "(letrec ((x 1) (x 2)) x)"
476 exception:duplicate-binding
477 (eval '(letrec ((x 1) (x 2)) x)
478 (interaction-environment))))
480 (with-test-prefix "bad body"
482 (pass-if-syntax-error "(letrec ())"
485 (interaction-environment)))
487 (pass-if-syntax-error "(letrec ((x 1)))"
489 (eval '(letrec ((x 1)))
490 (interaction-environment)))))
492 (with-test-prefix "letrec*"
494 (with-test-prefix "bindings"
496 (pass-if-syntax-error "initial bindings are undefined"
497 exception:used-before-defined
499 ;; FIXME: the memoizer does initialize the var to undefined, but
500 ;; the Scheme evaluator has no way of checking what's an
501 ;; undefined value. Not sure how to do this.
503 (letrec* ((x y) (y 1)) y))))
505 (with-test-prefix "bad bindings"
507 (pass-if-syntax-error "(letrec*)"
508 exception:bad-letrec*
510 (interaction-environment)))
512 (pass-if-syntax-error "(letrec* 1)"
513 exception:bad-letrec*
515 (interaction-environment)))
517 (pass-if-syntax-error "(letrec* (x))"
518 exception:bad-letrec*
520 (interaction-environment)))
522 (pass-if-syntax-error "(letrec* (x) 1)"
523 exception:bad-letrec*
524 (eval '(letrec* (x) 1)
525 (interaction-environment)))
527 (pass-if-syntax-error "(letrec* ((x)) 3)"
528 exception:bad-letrec*
529 (eval '(letrec* ((x)) 3)
530 (interaction-environment)))
532 (pass-if-syntax-error "(letrec* ((x 1) y) x)"
533 exception:bad-letrec*
534 (eval '(letrec* ((x 1) y) x)
535 (interaction-environment)))
537 (pass-if-syntax-error "(letrec* x ())"
538 exception:bad-letrec*
539 (eval '(letrec* x ())
540 (interaction-environment)))
542 (pass-if-syntax-error "(letrec* x (y))"
543 exception:bad-letrec*
544 (eval '(letrec* x (y))
545 (interaction-environment)))
547 (pass-if-syntax-error "(letrec* ((1 2)) 3)"
548 exception:bad-letrec*
549 (eval '(letrec* ((1 2)) 3)
550 (interaction-environment))))
552 (with-test-prefix "duplicate bindings"
554 (pass-if-syntax-error "(letrec* ((x 1) (x 2)) x)"
555 exception:duplicate-binding
556 (eval '(letrec* ((x 1) (x 2)) x)
557 (interaction-environment))))
559 (with-test-prefix "bad body"
561 (pass-if-syntax-error "(letrec* ())"
562 exception:bad-letrec*
564 (interaction-environment)))
566 (pass-if-syntax-error "(letrec* ((x 1)))"
567 exception:bad-letrec*
568 (eval '(letrec* ((x 1)))
569 (interaction-environment))))
571 (with-test-prefix "referencing previous values"
572 (pass-if (equal? (letrec ((a (cons 'foo 'bar))
576 (pass-if (equal? (let ()
577 (define a (cons 'foo 'bar))
582 (with-test-prefix "if"
584 (with-test-prefix "missing or extra expressions"
586 (pass-if-syntax-error "(if)"
587 exception:generic-syncase-error
589 (interaction-environment)))
591 (pass-if-syntax-error "(if 1 2 3 4)"
592 exception:generic-syncase-error
594 (interaction-environment)))))
596 (with-test-prefix "cond"
598 (with-test-prefix "cond is hygienic"
600 (pass-if "bound 'else is handled correctly"
601 (eq? (let ((else 'ok)) (cond (else))) 'ok))
603 (with-test-prefix "bound '=> is handled correctly"
607 (eq? (cond (#t => 'ok)) 'ok)))
611 (eq? (cond (else =>)) 'foo)))
613 (pass-if "else => identity"
615 (eq? (cond (else => identity)) identity)))))
617 (with-test-prefix "SRFI-61"
619 (pass-if "always available"
620 (cond-expand (srfi-61 #t) (else #f)))
622 (pass-if "single value consequent"
623 (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
625 (pass-if "single value alternate"
626 (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
628 (pass-if-exception "doesn't affect standard =>"
629 exception:wrong-num-args
630 (cond ((values 1 2) => (lambda (x y) #t))))
632 (pass-if "multiple values consequent"
633 (equal? '(2 1) (cond ((values 1 2)
635 (and (= 1 one) (= 2 two))) =>
636 (lambda (one two) (list two one)))
639 (pass-if "multiple values alternate"
640 (eq? 'ok (cond ((values 2 3 4)
641 (lambda args (equal? '(1 2 3) args)) =>
645 (pass-if "zero values"
646 (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
649 (pass-if "bound => is handled correctly"
651 (eq? 'ok (cond (#t identity =>) (else #f)))))
653 (pass-if-syntax-error "missing recipient"
654 '(cond . "wrong number of receiver expressions")
655 (eval '(cond (#t identity =>))
656 (interaction-environment)))
658 (pass-if-syntax-error "extra recipient"
659 '(cond . "wrong number of receiver expressions")
660 (eval '(cond (#t identity => identity identity))
661 (interaction-environment))))
663 (with-test-prefix "bad or missing clauses"
665 (pass-if-syntax-error "(cond)"
666 exception:generic-syncase-error
668 (interaction-environment)))
670 (pass-if-syntax-error "(cond #t)"
671 '(cond . "invalid clause")
673 (interaction-environment)))
675 (pass-if-syntax-error "(cond 1)"
676 '(cond . "invalid clause")
678 (interaction-environment)))
680 (pass-if-syntax-error "(cond 1 2)"
681 '(cond . "invalid clause")
683 (interaction-environment)))
685 (pass-if-syntax-error "(cond 1 2 3)"
686 '(cond . "invalid clause")
688 (interaction-environment)))
690 (pass-if-syntax-error "(cond 1 2 3 4)"
691 '(cond . "invalid clause")
692 (eval '(cond 1 2 3 4)
693 (interaction-environment)))
695 (pass-if-syntax-error "(cond ())"
696 '(cond . "invalid clause")
698 (interaction-environment)))
700 (pass-if-syntax-error "(cond () 1)"
701 '(cond . "invalid clause")
703 (interaction-environment)))
705 (pass-if-syntax-error "(cond (1) 1)"
706 '(cond . "invalid clause")
708 (interaction-environment)))
710 (pass-if-syntax-error "(cond (else #f) (#t #t))"
711 '(cond . "else must be the last clause")
712 (eval '(cond (else #f) (#t #t))
713 (interaction-environment))))
715 (with-test-prefix "wrong number of arguments"
717 (pass-if-exception "=> (lambda (x y) #t)"
718 exception:wrong-num-args
719 (cond (1 => (lambda (x y) #t))))))
721 (with-test-prefix "case"
723 (pass-if "clause with empty labels list"
724 (case 1 (() #f) (else #t)))
726 (with-test-prefix "case handles '=> correctly"
728 (pass-if "(1 2 3) => list"
729 (equal? (case 1 ((1 2 3) => list))
732 (pass-if "else => list"
738 (with-test-prefix "bound '=> is handled correctly"
740 (pass-if "(1) => 'ok"
742 (eq? (case 1 ((1) => 'ok)) 'ok)))
746 (eq? (case 1 (else =>)) 'foo)))
748 (pass-if "else => list"
750 (eq? (case 1 (else => identity)) identity))))
752 (pass-if-syntax-error "missing recipient"
753 '(case . "wrong number of receiver expressions")
754 (eval '(case 1 ((1) =>))
755 (interaction-environment)))
757 (pass-if-syntax-error "extra recipient"
758 '(case . "wrong number of receiver expressions")
759 (eval '(case 1 ((1) => identity identity))
760 (interaction-environment))))
762 (with-test-prefix "case is hygienic"
764 (pass-if-syntax-error "bound 'else is handled correctly"
765 '(case . "invalid clause")
766 (eval '(let ((else #f)) (case 1 (else #f)))
767 (interaction-environment))))
769 (with-test-prefix "bad or missing clauses"
771 (pass-if-syntax-error "(case)"
772 exception:generic-syncase-error
774 (interaction-environment)))
776 (pass-if-syntax-error "(case . \"foo\")"
777 exception:generic-syncase-error
778 (eval '(case . "foo")
779 (interaction-environment)))
781 (pass-if-syntax-error "(case 1)"
782 exception:generic-syncase-error
784 (interaction-environment)))
786 (pass-if-syntax-error "(case 1 . \"foo\")"
787 exception:generic-syncase-error
788 (eval '(case 1 . "foo")
789 (interaction-environment)))
791 (pass-if-syntax-error "(case 1 \"foo\")"
792 '(case . "invalid clause")
793 (eval '(case 1 "foo")
794 (interaction-environment)))
796 (pass-if-syntax-error "(case 1 ())"
797 '(case . "invalid clause")
799 (interaction-environment)))
801 (pass-if-syntax-error "(case 1 (\"foo\"))"
802 '(case . "invalid clause")
803 (eval '(case 1 ("foo"))
804 (interaction-environment)))
806 (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
807 '(case . "invalid clause")
808 (eval '(case 1 ("foo" "bar"))
809 (interaction-environment)))
811 (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")"
812 exception:generic-syncase-error
813 (eval '(case 1 ((2) "bar") . "foo")
814 (interaction-environment)))
816 (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
817 '(case . "invalid clause")
818 (eval '(case 1 ((2) "bar") (else))
819 (interaction-environment)))
821 (pass-if-syntax-error "(case 1 (else #f) . \"foo\")"
822 exception:generic-syncase-error
823 (eval '(case 1 (else #f) . "foo")
824 (interaction-environment)))
826 (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
827 '(case . "else must be the last clause")
828 (eval '(case 1 (else #f) ((1) #t))
829 (interaction-environment)))))
831 (with-test-prefix "top-level define"
833 (pass-if "redefinition"
834 (let ((m (make-module)))
835 (beautify-user-module! m)
837 ;; The previous value of `round' must still be visible at the time the
838 ;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
839 ;; should behave like `set!' in this case (except that in the case of
840 ;; Guile, we respect module boundaries).
841 (eval '(define round round) m)
842 (eq? (module-ref m 'round) round)))
844 (with-test-prefix "missing or extra expressions"
846 (pass-if-syntax-error "(define)"
847 exception:generic-syncase-error
849 (interaction-environment)))))
851 (with-test-prefix "internal define"
853 (pass-if "internal defines become letrec"
854 (eval '(let ((a identity) (b identity) (c identity))
855 (define (a x) (if (= x 0) 'a (b (- x 1))))
856 (define (b x) (if (= x 0) 'b (c (- x 1))))
857 (define (c x) (if (= x 0) 'c (a (- x 1))))
858 (and (eq? 'a (a 0) (a 3))
860 (eq? 'c (a 2) (a 5))))
861 (interaction-environment)))
863 (pass-if "binding is created before expression is evaluated"
864 ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
871 (interaction-environment))
874 (pass-if "internal defines with begin"
876 (eval '(let ((a identity) (b identity) (c identity))
877 (define (a x) (if (= x 0) 'a (b (- x 1))))
879 (define (b x) (if (= x 0) 'b (c (- x 1)))))
880 (define (c x) (if (= x 0) 'c (a (- x 1))))
881 (and (eq? 'a (a 0) (a 3))
883 (eq? 'c (a 2) (a 5))))
884 (interaction-environment))))
886 (pass-if "internal defines with empty begin"
888 (eval '(let ((a identity) (b identity) (c identity))
889 (define (a x) (if (= x 0) 'a (b (- x 1))))
891 (define (b x) (if (= x 0) 'b (c (- x 1))))
892 (define (c x) (if (= x 0) 'c (a (- x 1))))
893 (and (eq? 'a (a 0) (a 3))
895 (eq? 'c (a 2) (a 5))))
896 (interaction-environment))))
898 (pass-if "internal defines with macro application"
901 (defmacro my-define forms
902 (cons 'define forms))
903 (let ((a identity) (b identity) (c identity))
904 (define (a x) (if (= x 0) 'a (b (- x 1))))
905 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
906 (define (c x) (if (= x 0) 'c (a (- x 1))))
907 (and (eq? 'a (a 0) (a 3))
909 (eq? 'c (a 2) (a 5)))))
910 (interaction-environment))))
912 (pass-if-syntax-error "missing body expression"
913 exception:missing-body-expr
914 (eval '(let () (define x #t))
915 (interaction-environment))))
917 (with-test-prefix "top-level define-values"
919 (pass-if "zero values"
920 (eval '(begin (define-values () (values))
922 (interaction-environment)))
924 (pass-if-equal "one value"
926 (eval '(begin (define-values (x) 1)
928 (interaction-environment)))
930 (pass-if-equal "two values"
932 (eval '(begin (define-values (x y) (values 2 3))
934 (interaction-environment)))
936 (pass-if-equal "three values"
938 (eval '(begin (define-values (x y z) (values 4 5 6))
940 (interaction-environment)))
942 (pass-if-equal "one value with tail"
944 (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd))
946 (interaction-environment)))
948 (pass-if-equal "two values with tail"
950 (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w))
952 (interaction-environment)))
954 (pass-if-equal "just tail"
956 (eval '(begin (define-values x (values 1 2 3))
958 (interaction-environment)))
960 (pass-if-exception "expected 0 values, got 1"
961 exception:define-values-wrong-number-of-return-values
962 (eval '(define-values () 1)
963 (interaction-environment)))
965 (pass-if-exception "expected 1 value, got 0"
966 exception:define-values-wrong-number-of-return-values
967 (eval '(define-values (x) (values))
968 (interaction-environment)))
970 (pass-if-exception "expected 1 value, got 2"
971 exception:define-values-wrong-number-of-return-values
972 (eval '(define-values (x) (values 1 2))
973 (interaction-environment)))
975 (pass-if-exception "expected 1 value with tail, got 0"
976 exception:define-values-wrong-number-of-return-values
977 (eval '(define-values (x . y) (values))
978 (interaction-environment)))
980 (pass-if-exception "expected 2 value with tail, got 1"
981 exception:define-values-wrong-number-of-return-values
982 (eval '(define-values (x y . z) 1)
983 (interaction-environment)))
985 (pass-if "redefinition"
986 (let ((m (make-module)))
987 (beautify-user-module! m)
989 ;; The previous values of `floor' and `round' must still be
990 ;; visible at the time the new `floor' and `round' are defined.
991 (eval '(define-values (floor round) (values floor round)) m)
992 (and (eq? (module-ref m 'floor) floor)
993 (eq? (module-ref m 'round) round))))
995 (with-test-prefix "missing expression"
997 (pass-if-syntax-error "(define-values)"
998 exception:generic-syncase-error
999 (eval '(define-values)
1000 (interaction-environment)))))
1002 (with-test-prefix "internal define-values"
1004 (pass-if "zero values"
1006 (define-values () (values))
1009 (pass-if-equal "one value"
1012 (define-values (x) 1)
1015 (pass-if-equal "two values"
1018 (define-values (x y) (values 2 3))
1021 (pass-if-equal "three values"
1024 (define-values (x y z) (values 4 5 6))
1027 (pass-if-equal "one value with tail"
1030 (define-values (x . y) (values 'a 'b 'c 'd))
1033 (pass-if-equal "two values with tail"
1036 (define-values (x y . z) (values 'x 'y 'z 'w))
1039 (pass-if-equal "just tail"
1042 (define-values x (values 1 2 3))
1045 (pass-if-exception "expected 0 values, got 1"
1046 exception:define-values-wrong-number-of-return-values
1048 (define-values () 1)
1050 (interaction-environment)))
1052 (pass-if-exception "expected 1 value, got 0"
1053 exception:define-values-wrong-number-of-return-values
1055 (define-values (x) (values))
1057 (interaction-environment)))
1059 (pass-if-exception "expected 1 value, got 2"
1060 exception:define-values-wrong-number-of-return-values
1062 (define-values (x) (values 1 2))
1064 (interaction-environment)))
1066 (pass-if-exception "expected 1 value with tail, got 0"
1067 exception:define-values-wrong-number-of-return-values
1069 (define-values (x . y) (values))
1071 (interaction-environment)))
1073 (pass-if-exception "expected 2 value with tail, got 1"
1074 exception:define-values-wrong-number-of-return-values
1076 (define-values (x y . z) 1)
1078 (interaction-environment)))
1080 (with-test-prefix "missing expression"
1082 (pass-if-syntax-error "(define-values)"
1083 exception:generic-syncase-error
1087 (interaction-environment)))))
1089 (with-test-prefix "set!"
1091 (with-test-prefix "missing or extra expressions"
1093 (pass-if-syntax-error "(set!)"
1096 (interaction-environment)))
1098 (pass-if-syntax-error "(set! 1)"
1101 (interaction-environment)))
1103 (pass-if-syntax-error "(set! 1 2 3)"
1106 (interaction-environment))))
1108 (with-test-prefix "bad variable"
1110 (pass-if-syntax-error "(set! \"\" #t)"
1113 (interaction-environment)))
1115 (pass-if-syntax-error "(set! 1 #t)"
1118 (interaction-environment)))
1120 (pass-if-syntax-error "(set! #t #f)"
1123 (interaction-environment)))
1125 (pass-if-syntax-error "(set! #f #t)"
1128 (interaction-environment)))
1130 (pass-if-syntax-error "(set! #\\space #f)"
1132 (eval '(set! #\space #f)
1133 (interaction-environment)))))
1135 (with-test-prefix "quote"
1137 (with-test-prefix "missing or extra expression"
1139 (pass-if-syntax-error "(quote)"
1142 (interaction-environment)))
1144 (pass-if-syntax-error "(quote a b)"
1147 (interaction-environment)))))
1149 (with-test-prefix "while"
1151 (define (unreachable)
1152 (error "unreachable code has been reached!"))
1154 ;; Return a new procedure COND which when called (COND) will return #t the
1155 ;; first N times, then #f, then any further call is an error. N=0 is
1156 ;; allowed, in which case #f is returned by the first call.
1157 (define (make-iterations-cond n)
1160 (error "oops, condition re-tested after giving false"))
1169 (pass-if-syntax-error "too few args" exception:generic-syncase-error
1170 (eval '(while) (interaction-environment)))
1172 (with-test-prefix "empty body"
1176 (eval `(letrec ((make-iterations-cond
1180 (error "oops, condition re-tested after giving false"))
1187 (let ((cond (make-iterations-cond ,n)))
1190 (interaction-environment)))))
1192 (pass-if "initially false"
1197 (with-test-prefix "iterations"
1201 (let ((cond (make-iterations-cond n))
1207 (with-test-prefix "break"
1209 (pass-if "normal return"
1210 (not (while #f (error "not reached"))))
1215 (pass-if "multiple values"
1218 (lambda () (while #t (break 1 2 3)))
1221 (with-test-prefix "from cond"
1232 (let ((cond (make-iterations-cond n))
1242 (with-test-prefix "from body"
1252 (let ((cond (make-iterations-cond n))
1262 (pass-if "from nested"
1264 (let ((outer-break break))
1271 (pass-if "from recursive"
1272 (let ((outer-break #f))
1277 (set! outer-break break)
1283 (error "broke only from inner loop")))
1287 (with-test-prefix "continue"
1289 (pass-if-syntax-error "too many args" exception:too-many-args
1292 (interaction-environment)))
1294 (with-test-prefix "from cond"
1298 (let ((cond (make-iterations-cond n))
1309 (with-test-prefix "from body"
1313 (let ((cond (make-iterations-cond n))
1321 (pass-if "from nested"
1322 (let ((cond (make-iterations-cond 3)))
1324 (let ((outer-continue continue))
1330 (pass-if "from recursive"
1331 (let ((outer-continue #f))
1333 (let ((cond (make-iterations-cond 3))
1336 (if (and (not first)
1338 (error "continued only to inner loop"))
1343 (set! outer-continue continue)
1351 (with-test-prefix "syntax-rules"
1353 (pass-if-equal "custom ellipsis within normal ellipsis"
1354 '((((a x) (a y) (a …))
1356 ((c x) (c y) (c …)))
1357 (((a x) (b x) (c x))
1359 ((a …) (b …) (c …))))
1367 (((x y) …) ...)))))))
1368 (define-syntax bar (foo x y …))
1371 (pass-if-equal "normal ellipsis within custom ellipsis"
1372 '((((a x) (a y) (a z))
1374 ((c x) (c y) (c z)))
1375 (((a x) (b x) (c x))
1377 ((a z) (b z) (c z))))
1385 (((x y) ...) …)))))))
1386 (define-syntax bar (foo x y z))
1389 ;; This test is given in SRFI-46.
1390 (pass-if-equal "custom ellipsis is handled hygienically"
1393 ((f (syntax-rules ()
1396 ((g (syntax-rules --- ()
1397 ((g (??x ?e) (??y ---))
1398 '((??x) ?e (??y) ---)))))
1399 (g (1 2) (3 4)))))))
1402 (with-test-prefix "syntax-error"
1404 (pass-if-syntax-error "outside of macro without args"
1406 (eval '(syntax-error "test error")
1407 (interaction-environment)))
1409 (pass-if-syntax-error "outside of macro with args"
1410 "test error x \\(y z\\)"
1411 (eval '(syntax-error "test error" x (y z))
1412 (interaction-environment)))
1414 (pass-if-equal "within macro"
1416 "expected an identifier but got (z1 z2)"
1417 (simple-let ((y (* x x))
1418 ((z1 z2) (values x x)))
1420 (catch 'syntax-error
1423 (define-syntax simple-let
1425 ((_ (head ... ((x . y) val) . tail)
1428 "expected an identifier but got"
1430 ((_ ((name val) ...) body1 body2 ...)
1431 ((lambda (name ...) body1 body2 ...)
1434 (simple-let ((y (* x x))
1435 ((z1 z2) (values x x)))
1438 (interaction-environment))
1439 (error "expected syntax-error exception"))
1440 (lambda (k who what where form . maybe-subform)
1441 (list who what form)))))
1443 (with-test-prefix "syntax-case"
1445 (pass-if-syntax-error "duplicate pattern variable"
1446 '(syntax-case . "duplicate pattern variable")
1449 ((a b c d e d f) #f)))
1450 (interaction-environment)))
1452 (with-test-prefix "misplaced ellipses"
1454 (pass-if-syntax-error "bare ellipsis"
1455 '(syntax-case . "misplaced ellipsis")
1459 (interaction-environment)))
1461 (pass-if-syntax-error "ellipsis singleton"
1462 '(syntax-case . "misplaced ellipsis")
1466 (interaction-environment)))
1468 (pass-if-syntax-error "ellipsis in car"
1469 '(syntax-case . "misplaced ellipsis")
1473 (interaction-environment)))
1475 (pass-if-syntax-error "ellipsis in cdr"
1476 '(syntax-case . "misplaced ellipsis")
1480 (interaction-environment)))
1482 (pass-if-syntax-error "two ellipses in the same list"
1483 '(syntax-case . "misplaced ellipsis")
1486 ((x ... y ...) #f)))
1487 (interaction-environment)))
1489 (pass-if-syntax-error "three ellipses in the same list"
1490 '(syntax-case . "misplaced ellipsis")
1493 ((x ... y ... z ...) #f)))
1494 (interaction-environment)))))
1496 (with-test-prefix "with-ellipsis"
1498 (pass-if-equal "simple"
1501 (define-syntax define-quotation-macros
1504 ((_ (macro-name head-symbol) ...)
1505 #'(begin (define-syntax macro-name
1510 #'(quote (head-symbol x …)))))))
1512 (define-quotation-macros (quote-a a) (quote-b b))
1515 (pass-if-equal "disables normal ellipsis"
1523 #'(quote (a ...)))))))
1526 (pass-if-equal "doesn't affect ellipsis for generated code"
1529 (define-syntax quotation-macro
1537 #'(quote (x ...))))))))))
1538 (define-syntax kwote (quotation-macro))
1541 (pass-if-equal "propagates into syntax binders"
1545 (define-syntax kwote
1552 (pass-if-equal "works with local-eval"
1554 (let ((env (with-ellipsis … (the-environment))))
1555 (local-eval '(syntax-case #'(a b c d e) ()
1560 ;;; Local Variables:
1561 ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
1562 ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)