1 ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
3 ;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
10 ;;;; This program is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18 ;;;; Boston, MA 02110-1301 USA
20 (define-module (test-suite test-syntax)
21 :use-module (test-suite lib))
24 (define exception:bad-expression
25 (cons 'syntax-error "Bad expression"))
27 (define exception:missing/extra-expr
28 (cons 'syntax-error "Missing or extra expression"))
29 (define exception:missing-expr
30 (cons 'syntax-error "Missing expression"))
31 (define exception:missing-body-expr
32 (cons 'syntax-error "Missing body expression"))
33 (define exception:extra-expr
34 (cons 'syntax-error "Extra expression"))
35 (define exception:illegal-empty-combination
36 (cons 'syntax-error "Illegal empty combination"))
38 (define exception:bad-bindings
39 (cons 'syntax-error "Bad bindings"))
40 (define exception:bad-binding
41 (cons 'syntax-error "Bad binding"))
42 (define exception:duplicate-binding
43 (cons 'syntax-error "Duplicate binding"))
44 (define exception:bad-body
45 (cons 'misc-error "^bad body"))
46 (define exception:bad-formals
47 (cons 'syntax-error "Bad formals"))
48 (define exception:bad-formal
49 (cons 'syntax-error "Bad formal"))
50 (define exception:duplicate-formal
51 (cons 'syntax-error "Duplicate formal"))
53 (define exception:missing-clauses
54 (cons 'syntax-error "Missing clauses"))
55 (define exception:misplaced-else-clause
56 (cons 'syntax-error "Misplaced else clause"))
57 (define exception:bad-case-clause
58 (cons 'syntax-error "Bad case clause"))
59 (define exception:bad-case-labels
60 (cons 'syntax-error "Bad case labels"))
61 (define exception:bad-cond-clause
62 (cons 'syntax-error "Bad cond clause"))
65 (with-test-prefix "expressions"
67 (with-test-prefix "Bad argument list"
69 (pass-if-exception "improper argument list of length 1"
70 exception:wrong-num-args
71 (eval '(let ((foo (lambda (x y) #t)))
73 (interaction-environment)))
75 (pass-if-exception "improper argument list of length 2"
76 exception:wrong-num-args
77 (eval '(let ((foo (lambda (x y) #t)))
79 (interaction-environment))))
81 (with-test-prefix "missing or extra expression"
84 ;; *Note:* In many dialects of Lisp, the empty combination, (),
85 ;; is a legitimate expression. In Scheme, combinations must
86 ;; have at least one subexpression, so () is not a syntactically
90 (pass-if-exception "empty parentheses \"()\""
91 exception:illegal-empty-combination
93 (interaction-environment)))))
95 (with-test-prefix "quote"
98 (with-test-prefix "quasiquote"
100 (with-test-prefix "unquote"
102 (pass-if "repeated execution"
103 (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
104 (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
106 (with-test-prefix "unquote-splicing"
108 (pass-if-exception "extra arguments"
109 exception:missing/extra-expr
110 (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
112 (with-test-prefix "begin"
114 (pass-if "legal (begin)"
118 (with-test-prefix "unmemoization"
120 (pass-if "normal begin"
121 (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
122 (foo) ; make sure, memoization has been performed
123 (equal? (procedure-source foo)
124 '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
126 (pass-if "redundant nested begin"
127 (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
128 (foo) ; make sure, memoization has been performed
129 (equal? (procedure-source foo)
130 '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
132 (pass-if "redundant begin at start of body"
133 (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
134 (foo) ; make sure, memoization has been performed
135 (equal? (procedure-source foo)
136 '(lambda () (begin (+ 1) (+ 2)))))))
138 (expect-fail-exception "illegal (begin)"
143 (with-test-prefix "lambda"
145 (with-test-prefix "unmemoization"
147 (pass-if "normal lambda"
148 (let ((foo (lambda () (lambda (x y) (+ x y)))))
149 ((foo) 1 2) ; make sure, memoization has been performed
150 (equal? (procedure-source foo)
151 '(lambda () (lambda (x y) (+ x y))))))
153 (pass-if "lambda with documentation"
154 (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
155 ((foo) 1 2) ; make sure, memoization has been performed
156 (equal? (procedure-source foo)
157 '(lambda () (lambda (x y) "docstring" (+ x y)))))))
159 (with-test-prefix "bad formals"
161 (pass-if-exception "(lambda)"
162 exception:missing-expr
164 (interaction-environment)))
166 (pass-if-exception "(lambda . \"foo\")"
167 exception:bad-expression
168 (eval '(lambda . "foo")
169 (interaction-environment)))
171 (pass-if-exception "(lambda \"foo\")"
172 exception:missing-expr
173 (eval '(lambda "foo")
174 (interaction-environment)))
176 (pass-if-exception "(lambda \"foo\" #f)"
177 exception:bad-formals
178 (eval '(lambda "foo" #f)
179 (interaction-environment)))
181 (pass-if-exception "(lambda (x 1) 2)"
183 (eval '(lambda (x 1) 2)
184 (interaction-environment)))
186 (pass-if-exception "(lambda (1 x) 2)"
188 (eval '(lambda (1 x) 2)
189 (interaction-environment)))
191 (pass-if-exception "(lambda (x \"a\") 2)"
193 (eval '(lambda (x "a") 2)
194 (interaction-environment)))
196 (pass-if-exception "(lambda (\"a\" x) 2)"
198 (eval '(lambda ("a" x) 2)
199 (interaction-environment))))
201 (with-test-prefix "duplicate formals"
204 (pass-if-exception "(lambda (x x) 1)"
205 exception:duplicate-formal
206 (eval '(lambda (x x) 1)
207 (interaction-environment)))
210 (pass-if-exception "(lambda (x x x) 1)"
211 exception:duplicate-formal
212 (eval '(lambda (x x x) 1)
213 (interaction-environment))))
215 (with-test-prefix "bad body"
217 (pass-if-exception "(lambda ())"
218 exception:missing-expr
220 (interaction-environment)))))
222 (with-test-prefix "let"
224 (with-test-prefix "unmemoization"
226 (pass-if "normal let"
227 (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
228 (foo) ; make sure, memoization has been performed
229 (equal? (procedure-source foo)
230 '(lambda () (let ((i 1) (j 2)) (+ i j)))))))
232 (with-test-prefix "bindings"
234 (pass-if-exception "late binding"
235 exception:unbound-var
236 (let ((x 1) (y x)) y)))
238 (with-test-prefix "bad bindings"
240 (pass-if-exception "(let)"
241 exception:missing-expr
243 (interaction-environment)))
245 (pass-if-exception "(let 1)"
246 exception:missing-expr
248 (interaction-environment)))
250 (pass-if-exception "(let (x))"
251 exception:missing-expr
253 (interaction-environment)))
255 (pass-if-exception "(let ((x)))"
256 exception:missing-expr
258 (interaction-environment)))
260 (pass-if-exception "(let (x) 1)"
261 exception:bad-binding
263 (interaction-environment)))
265 (pass-if-exception "(let ((x)) 3)"
266 exception:bad-binding
268 (interaction-environment)))
270 (pass-if-exception "(let ((x 1) y) x)"
271 exception:bad-binding
272 (eval '(let ((x 1) y) x)
273 (interaction-environment)))
275 (pass-if-exception "(let ((1 2)) 3)"
276 exception:bad-variable
277 (eval '(let ((1 2)) 3)
278 (interaction-environment))))
280 (with-test-prefix "duplicate bindings"
282 (pass-if-exception "(let ((x 1) (x 2)) x)"
283 exception:duplicate-binding
284 (eval '(let ((x 1) (x 2)) x)
285 (interaction-environment))))
287 (with-test-prefix "bad body"
289 (pass-if-exception "(let ())"
290 exception:missing-expr
292 (interaction-environment)))
294 (pass-if-exception "(let ((x 1)))"
295 exception:missing-expr
297 (interaction-environment)))))
299 (with-test-prefix "named let"
301 (with-test-prefix "initializers"
303 (pass-if "evaluated in outer environment"
305 (eqv? (let f ((n (f 1))) n) -1))))
307 (with-test-prefix "bad bindings"
309 (pass-if-exception "(let x (y))"
310 exception:missing-expr
312 (interaction-environment))))
314 (with-test-prefix "bad body"
316 (pass-if-exception "(let x ())"
317 exception:missing-expr
319 (interaction-environment)))
321 (pass-if-exception "(let x ((y 1)))"
322 exception:missing-expr
323 (eval '(let x ((y 1)))
324 (interaction-environment)))))
326 (with-test-prefix "let*"
328 (with-test-prefix "unmemoization"
330 (pass-if "normal let*"
331 (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
332 (foo) ; make sure, memoization has been performed
333 (equal? (procedure-source foo)
334 '(lambda () (let* ((x 1) (y 2)) (+ x y))))))
336 (pass-if "let* without bindings"
337 (let ((foo (lambda () (let ((x 1) (y 2))
339 (and (= x 1) (= y 2)))))))
340 (foo) ; make sure, memoization has been performed
341 (equal? (procedure-source foo)
342 '(lambda () (let ((x 1) (y 2))
344 (and (= x 1) (= y 2)))))))))
346 (with-test-prefix "bindings"
348 (pass-if "(let* ((x 1) (x 2)) ...)"
352 (pass-if "(let* ((x 1) (x x)) ...)"
356 (pass-if "(let ((x 1) (y 2)) (let* () ...))"
359 (and (= x 1) (= y 2))))))
361 (with-test-prefix "bad bindings"
363 (pass-if-exception "(let*)"
364 exception:missing-expr
366 (interaction-environment)))
368 (pass-if-exception "(let* 1)"
369 exception:missing-expr
371 (interaction-environment)))
373 (pass-if-exception "(let* (x))"
374 exception:missing-expr
376 (interaction-environment)))
378 (pass-if-exception "(let* (x) 1)"
379 exception:bad-binding
381 (interaction-environment)))
383 (pass-if-exception "(let* ((x)) 3)"
384 exception:bad-binding
385 (eval '(let* ((x)) 3)
386 (interaction-environment)))
388 (pass-if-exception "(let* ((x 1) y) x)"
389 exception:bad-binding
390 (eval '(let* ((x 1) y) x)
391 (interaction-environment)))
393 (pass-if-exception "(let* x ())"
394 exception:bad-bindings
396 (interaction-environment)))
398 (pass-if-exception "(let* x (y))"
399 exception:bad-bindings
401 (interaction-environment)))
403 (pass-if-exception "(let* ((1 2)) 3)"
404 exception:bad-variable
405 (eval '(let* ((1 2)) 3)
406 (interaction-environment))))
408 (with-test-prefix "bad body"
410 (pass-if-exception "(let* ())"
411 exception:missing-expr
413 (interaction-environment)))
415 (pass-if-exception "(let* ((x 1)))"
416 exception:missing-expr
417 (eval '(let* ((x 1)))
418 (interaction-environment)))))
420 (with-test-prefix "letrec"
422 (with-test-prefix "unmemoization"
424 (pass-if "normal letrec"
425 (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
426 (foo) ; make sure, memoization has been performed
427 (equal? (procedure-source foo)
428 '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
430 (with-test-prefix "bindings"
432 (pass-if-exception "initial bindings are undefined"
433 exception:used-before-defined
435 (letrec ((x 1) (y x)) y))))
437 (with-test-prefix "bad bindings"
439 (pass-if-exception "(letrec)"
440 exception:missing-expr
442 (interaction-environment)))
444 (pass-if-exception "(letrec 1)"
445 exception:missing-expr
447 (interaction-environment)))
449 (pass-if-exception "(letrec (x))"
450 exception:missing-expr
452 (interaction-environment)))
454 (pass-if-exception "(letrec (x) 1)"
455 exception:bad-binding
456 (eval '(letrec (x) 1)
457 (interaction-environment)))
459 (pass-if-exception "(letrec ((x)) 3)"
460 exception:bad-binding
461 (eval '(letrec ((x)) 3)
462 (interaction-environment)))
464 (pass-if-exception "(letrec ((x 1) y) x)"
465 exception:bad-binding
466 (eval '(letrec ((x 1) y) x)
467 (interaction-environment)))
469 (pass-if-exception "(letrec x ())"
470 exception:bad-bindings
472 (interaction-environment)))
474 (pass-if-exception "(letrec x (y))"
475 exception:bad-bindings
476 (eval '(letrec x (y))
477 (interaction-environment)))
479 (pass-if-exception "(letrec ((1 2)) 3)"
480 exception:bad-variable
481 (eval '(letrec ((1 2)) 3)
482 (interaction-environment))))
484 (with-test-prefix "duplicate bindings"
486 (pass-if-exception "(letrec ((x 1) (x 2)) x)"
487 exception:duplicate-binding
488 (eval '(letrec ((x 1) (x 2)) x)
489 (interaction-environment))))
491 (with-test-prefix "bad body"
493 (pass-if-exception "(letrec ())"
494 exception:missing-expr
496 (interaction-environment)))
498 (pass-if-exception "(letrec ((x 1)))"
499 exception:missing-expr
500 (eval '(letrec ((x 1)))
501 (interaction-environment)))))
503 (with-test-prefix "if"
505 (with-test-prefix "unmemoization"
508 (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
509 (foo #t) ; make sure, memoization has been performed
510 (foo #f) ; make sure, memoization has been performed
511 (equal? (procedure-source foo)
512 '(lambda (x) (if x (+ 1) (+ 2))))))
514 (pass-if "if without else"
515 (let ((foo (lambda (x) (if x (+ 1)))))
516 (foo #t) ; make sure, memoization has been performed
517 (foo #f) ; make sure, memoization has been performed
518 (equal? (procedure-source foo)
519 '(lambda (x) (if x (+ 1))))))
521 (pass-if "if #f without else"
522 (let ((foo (lambda () (if #f #f))))
523 (foo) ; make sure, memoization has been performed
524 (equal? (procedure-source foo)
525 `(lambda () (if #f #f))))))
527 (with-test-prefix "missing or extra expressions"
529 (pass-if-exception "(if)"
530 exception:missing/extra-expr
532 (interaction-environment)))
534 (pass-if-exception "(if 1 2 3 4)"
535 exception:missing/extra-expr
537 (interaction-environment)))))
539 (with-test-prefix "cond"
541 (with-test-prefix "cond is hygienic"
543 (pass-if "bound 'else is handled correctly"
544 (eq? (let ((else 'ok)) (cond (else))) 'ok))
546 (with-test-prefix "bound '=> is handled correctly"
550 (eq? (cond (#t => 'ok)) 'ok)))
554 (eq? (cond (else =>)) 'foo)))
556 (pass-if "else => identity"
558 (eq? (cond (else => identity)) identity)))))
560 (with-test-prefix "SRFI-61"
562 (pass-if "always available"
563 (cond-expand (srfi-61 #t) (else #f)))
565 (pass-if "single value consequent"
566 (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
568 (pass-if "single value alternate"
569 (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
571 (pass-if-exception "doesn't affect standard =>"
572 exception:wrong-num-args
573 (cond ((values 1 2) => (lambda (x y) #t))))
575 (pass-if "multiple values consequent"
576 (equal? '(2 1) (cond ((values 1 2)
578 (and (= 1 one) (= 2 two))) =>
579 (lambda (one two) (list two one)))
582 (pass-if "multiple values alternate"
583 (eq? 'ok (cond ((values 2 3 4)
584 (lambda args (equal? '(1 2 3) args)) =>
588 (pass-if "zero values"
589 (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
592 (pass-if "bound => is handled correctly"
594 (eq? 'ok (cond (#t identity =>) (else #f)))))
596 (pass-if-exception "missing recipient"
597 '(syntax-error . "Missing recipient")
598 (cond (#t identity =>)))
600 (pass-if-exception "extra recipient"
601 '(syntax-error . "Extra expression")
602 (cond (#t identity => identity identity))))
604 (with-test-prefix "unmemoization"
606 (pass-if "normal clauses"
607 (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
608 (foo 1) ; make sure, memoization has been performed
609 (foo 2) ; make sure, memoization has been performed
610 (equal? (procedure-source foo)
611 '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
614 (let ((foo (lambda () (cond (else 'bar)))))
615 (foo) ; make sure, memoization has been performed
616 (equal? (procedure-source foo)
617 '(lambda () (cond (else 'bar))))))
620 (let ((foo (lambda () (cond (#t => identity)))))
621 (foo) ; make sure, memoization has been performed
622 (equal? (procedure-source foo)
623 '(lambda () (cond (#t => identity)))))))
625 (with-test-prefix "bad or missing clauses"
627 (pass-if-exception "(cond)"
628 exception:missing-clauses
630 (interaction-environment)))
632 (pass-if-exception "(cond #t)"
633 exception:bad-cond-clause
635 (interaction-environment)))
637 (pass-if-exception "(cond 1)"
638 exception:bad-cond-clause
640 (interaction-environment)))
642 (pass-if-exception "(cond 1 2)"
643 exception:bad-cond-clause
645 (interaction-environment)))
647 (pass-if-exception "(cond 1 2 3)"
648 exception:bad-cond-clause
650 (interaction-environment)))
652 (pass-if-exception "(cond 1 2 3 4)"
653 exception:bad-cond-clause
654 (eval '(cond 1 2 3 4)
655 (interaction-environment)))
657 (pass-if-exception "(cond ())"
658 exception:bad-cond-clause
660 (interaction-environment)))
662 (pass-if-exception "(cond () 1)"
663 exception:bad-cond-clause
665 (interaction-environment)))
667 (pass-if-exception "(cond (1) 1)"
668 exception:bad-cond-clause
670 (interaction-environment))))
672 (with-test-prefix "wrong number of arguments"
674 (pass-if-exception "=> (lambda (x y) #t)"
675 exception:wrong-num-args
676 (cond (1 => (lambda (x y) #t))))))
678 (with-test-prefix "case"
680 (pass-if "clause with empty labels list"
681 (case 1 (() #f) (else #t)))
683 (with-test-prefix "case is hygienic"
685 (pass-if-exception "bound 'else is handled correctly"
686 exception:bad-case-labels
687 (eval '(let ((else #f)) (case 1 (else #f)))
688 (interaction-environment))))
690 (with-test-prefix "unmemoization"
692 (pass-if "normal clauses"
693 (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
694 (foo 1) ; make sure, memoization has been performed
695 (foo 2) ; make sure, memoization has been performed
696 (foo 3) ; make sure, memoization has been performed
697 (equal? (procedure-source foo)
698 '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
700 (pass-if "empty labels"
701 (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
702 (foo 1) ; make sure, memoization has been performed
703 (foo 2) ; make sure, memoization has been performed
704 (foo 3) ; make sure, memoization has been performed
705 (equal? (procedure-source foo)
706 '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
708 (with-test-prefix "bad or missing clauses"
710 (pass-if-exception "(case)"
711 exception:missing-clauses
713 (interaction-environment)))
715 (pass-if-exception "(case . \"foo\")"
716 exception:bad-expression
717 (eval '(case . "foo")
718 (interaction-environment)))
720 (pass-if-exception "(case 1)"
721 exception:missing-clauses
723 (interaction-environment)))
725 (pass-if-exception "(case 1 . \"foo\")"
726 exception:bad-expression
727 (eval '(case 1 . "foo")
728 (interaction-environment)))
730 (pass-if-exception "(case 1 \"foo\")"
731 exception:bad-case-clause
732 (eval '(case 1 "foo")
733 (interaction-environment)))
735 (pass-if-exception "(case 1 ())"
736 exception:bad-case-clause
738 (interaction-environment)))
740 (pass-if-exception "(case 1 (\"foo\"))"
741 exception:bad-case-clause
742 (eval '(case 1 ("foo"))
743 (interaction-environment)))
745 (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
746 exception:bad-case-labels
747 (eval '(case 1 ("foo" "bar"))
748 (interaction-environment)))
750 (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
751 exception:bad-expression
752 (eval '(case 1 ((2) "bar") . "foo")
753 (interaction-environment)))
755 (pass-if-exception "(case 1 ((2) \"bar\") (else))"
756 exception:bad-case-clause
757 (eval '(case 1 ((2) "bar") (else))
758 (interaction-environment)))
760 (pass-if-exception "(case 1 (else #f) . \"foo\")"
761 exception:bad-expression
762 (eval '(case 1 (else #f) . "foo")
763 (interaction-environment)))
765 (pass-if-exception "(case 1 (else #f) ((1) #t))"
766 exception:misplaced-else-clause
767 (eval '(case 1 (else #f) ((1) #t))
768 (interaction-environment)))))
770 (with-test-prefix "top-level define"
772 (pass-if "redefinition"
773 (let ((m (make-module)))
774 (beautify-user-module! m)
776 ;; The previous value of `round' must still be visible at the time the
777 ;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
778 ;; should behave like `set!' in this case (except that in the case of
779 ;; Guile, we respect module boundaries).
780 (eval '(define round round) m)
781 (eq? (module-ref m 'round) round)))
783 (with-test-prefix "currying"
785 (pass-if "(define ((foo)) #f)"
789 (interaction-environment))))
791 (with-test-prefix "unmemoization"
793 (pass-if "definition unmemoized without prior execution"
795 (define (blub) (cons ('(1 . 2)) 2))
797 (procedure-source blub)
798 '(lambda () (cons ('(1 . 2)) 2))))
799 (interaction-environment)))
801 (pass-if "definition with documentation unmemoized without prior execution"
803 (define (blub) "Comment" (cons ('(1 . 2)) 2))
805 (procedure-source blub)
806 '(lambda () "Comment" (cons ('(1 . 2)) 2))))
807 (interaction-environment))))
809 (with-test-prefix "missing or extra expressions"
811 (pass-if-exception "(define)"
812 exception:missing-expr
814 (interaction-environment)))))
816 (with-test-prefix "internal define"
818 (pass-if "internal defines become letrec"
819 (eval '(let ((a identity) (b identity) (c identity))
820 (define (a x) (if (= x 0) 'a (b (- x 1))))
821 (define (b x) (if (= x 0) 'b (c (- x 1))))
822 (define (c x) (if (= x 0) 'c (a (- x 1))))
823 (and (eq? 'a (a 0) (a 3))
825 (eq? 'c (a 2) (a 5))))
826 (interaction-environment)))
828 (pass-if "binding is created before expression is evaluated"
829 ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
836 (interaction-environment))
839 (pass-if "internal defines with begin"
841 (eval '(let ((a identity) (b identity) (c identity))
842 (define (a x) (if (= x 0) 'a (b (- x 1))))
844 (define (b x) (if (= x 0) 'b (c (- x 1)))))
845 (define (c x) (if (= x 0) 'c (a (- x 1))))
846 (and (eq? 'a (a 0) (a 3))
848 (eq? 'c (a 2) (a 5))))
849 (interaction-environment))))
851 (pass-if "internal defines with empty begin"
853 (eval '(let ((a identity) (b identity) (c identity))
854 (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 "internal defines with macro application"
866 (defmacro my-define forms
867 (cons 'define forms))
868 (let ((a identity) (b identity) (c identity))
869 (define (a x) (if (= x 0) 'a (b (- x 1))))
870 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
871 (define (c x) (if (= x 0) 'c (a (- x 1))))
872 (and (eq? 'a (a 0) (a 3))
874 (eq? 'c (a 2) (a 5)))))
875 (interaction-environment))))
877 (pass-if-exception "missing body expression"
878 exception:missing-body-expr
879 (eval '(let () (define x #t))
880 (interaction-environment)))
882 (pass-if "unmemoization"
890 (procedure-source foo)
891 '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
892 (interaction-environment))))
894 (with-test-prefix "do"
896 (with-test-prefix "unmemoization"
898 (pass-if "normal case"
899 (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
902 (foo) ; make sure, memoization has been performed
903 (equal? (procedure-source foo)
904 '(lambda () (do ((i 1 (+ i 1)) (j 2))
908 (pass-if "reduced case"
909 (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
912 (foo) ; make sure, memoization has been performed
913 (equal? (procedure-source foo)
914 '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
918 (with-test-prefix "set!"
920 (with-test-prefix "unmemoization"
922 (pass-if "normal set!"
923 (let ((foo (lambda (x) (set! x (+ 1 x)))))
924 (foo 1) ; make sure, memoization has been performed
925 (equal? (procedure-source foo)
926 '(lambda (x) (set! x (+ 1 x)))))))
928 (with-test-prefix "missing or extra expressions"
930 (pass-if-exception "(set!)"
931 exception:missing/extra-expr
933 (interaction-environment)))
935 (pass-if-exception "(set! 1)"
936 exception:missing/extra-expr
938 (interaction-environment)))
940 (pass-if-exception "(set! 1 2 3)"
941 exception:missing/extra-expr
943 (interaction-environment))))
945 (with-test-prefix "bad variable"
947 (pass-if-exception "(set! \"\" #t)"
948 exception:bad-variable
950 (interaction-environment)))
952 (pass-if-exception "(set! 1 #t)"
953 exception:bad-variable
955 (interaction-environment)))
957 (pass-if-exception "(set! #t #f)"
958 exception:bad-variable
960 (interaction-environment)))
962 (pass-if-exception "(set! #f #t)"
963 exception:bad-variable
965 (interaction-environment)))
967 (pass-if-exception "(set! #\\space #f)"
968 exception:bad-variable
969 (eval '(set! #\space #f)
970 (interaction-environment)))))
972 (with-test-prefix "quote"
974 (with-test-prefix "missing or extra expression"
976 (pass-if-exception "(quote)"
977 exception:missing/extra-expr
979 (interaction-environment)))
981 (pass-if-exception "(quote a b)"
982 exception:missing/extra-expr
984 (interaction-environment)))))
986 (with-test-prefix "while"
988 (define (unreachable)
989 (error "unreachable code has been reached!"))
991 ;; Return a new procedure COND which when called (COND) will return #t the
992 ;; first N times, then #f, then any further call is an error. N=0 is
993 ;; allowed, in which case #f is returned by the first call.
994 (define (make-iterations-cond n)
997 (error "oops, condition re-tested after giving false"))
1006 (pass-if-exception "too few args" exception:wrong-num-args
1007 (eval '(while) (interaction-environment)))
1009 (with-test-prefix "empty body"
1013 (let ((cond (make-iterations-cond n)))
1017 (pass-if "initially false"
1022 (with-test-prefix "in empty environment"
1024 ;; an environment with no bindings at all
1025 (define empty-environment
1028 ;; these tests are 'unresolved because to work with ice-9 syncase it was
1029 ;; necessary to drop the unquote from `do' in the implementation, and
1030 ;; unfortunately that makes `while' depend on its evaluation environment
1032 (pass-if "empty body"
1038 (pass-if "initially false"
1045 (pass-if "iterating"
1047 (let ((cond (make-iterations-cond 3)))
1048 (eval `(,while (,cond)
1053 (with-test-prefix "iterations"
1057 (let ((cond (make-iterations-cond n))
1063 (with-test-prefix "break"
1065 (pass-if-exception "too many args" exception:wrong-num-args
1069 (with-test-prefix "from cond"
1080 (let ((cond (make-iterations-cond n))
1090 (with-test-prefix "from body"
1100 (let ((cond (make-iterations-cond n))
1110 (pass-if "from nested"
1112 (let ((outer-break break))
1119 (pass-if "from recursive"
1120 (let ((outer-break #f))
1125 (set! outer-break break)
1131 (error "broke only from inner loop")))
1135 (with-test-prefix "continue"
1137 (pass-if-exception "too many args" exception:wrong-num-args
1141 (with-test-prefix "from cond"
1145 (let ((cond (make-iterations-cond n))
1156 (with-test-prefix "from body"
1160 (let ((cond (make-iterations-cond n))
1168 (pass-if "from nested"
1169 (let ((cond (make-iterations-cond 3)))
1171 (let ((outer-continue continue))
1177 (pass-if "from recursive"
1178 (let ((outer-continue #f))
1180 (let ((cond (make-iterations-cond 3))
1183 (if (and (not first)
1185 (error "continued only to inner loop"))
1190 (set! outer-continue continue)