1;;;
2;;; primitive syntax test
3;;;
4
5(use gauche.test)
6
7(test-start "primitive syntax")
8
9;; We use prim-test instead of test, for error-handler is not tested yet.
10
11;;----------------------------------------------------------------
12(test-section "conditionals")
13
14(prim-test "if" 5 (lambda ()  (if #f 2 5)))
15(prim-test "if" 2 (lambda ()  (if (not #f) 2 5)))
16
17(prim-test "and" #t (lambda ()  (and)))
18(prim-test "and" 5  (lambda ()  (and 5)))
19(prim-test "and" #f (lambda ()  (and 5 #f 2)))
20(prim-test "and" #f (lambda ()  (and 5 #f unbound-var)))
21(prim-test "and" 'a (lambda ()  (and 3 4 'a)))
22
23(prim-test "or"  #f (lambda ()  (or)))
24(prim-test "or"  3  (lambda ()  (or 3 9)))
25(prim-test "or"  3  (lambda ()  (or #f 3 unbound-var)))
26
27(prim-test "when" 4          (lambda ()  (when 3 5 4)))
28(prim-test "when" (undefined)    (lambda ()  (when #f 5 4)))
29(prim-test "when" (undefined)    (lambda ()  (when #f unbound-var)))
30(prim-test "unless" (undefined)  (lambda ()  (unless 3 5 4)))
31(prim-test "unless" (undefined)  (lambda ()  (unless #t unbound-var)))
32(prim-test "unless" 4        (lambda ()  (unless #f 5 4)))
33
34(prim-test "cond" (undefined)  (lambda ()  (cond (#f 2))))
35(prim-test "cond" 5        (lambda ()  (cond (#f 2) (else 5))))
36(prim-test "cond" 2        (lambda ()  (cond (1 2) (else 5))))
37(prim-test "cond" 8        (lambda ()  (cond (#f 2) (1 8) (else 5))))
38(prim-test "cond" 3        (lambda ()  (cond (1 => (lambda (x) (+ x 2))) (else 8))))
39(prim-test "cond (srfi-61)" 1 (lambda () (cond (1 number? => values) (else 8))))
40(prim-test "cond (srfi-61)" 8 (lambda () (cond (1 string? => values) (else 8))))
41(prim-test "cond (srfi-61)" '(1 2)
42           (lambda () (cond ((values 1 2)
43                             (lambda (x y) (and (= x 1) (= y 2)))
44                             => list))))
45
46(prim-test "case" #t (lambda ()  (case (+ 2 3) ((1 3 5 7 9) #t) ((0 2 4 6 8) #f))))
47(prim-test "case" #t (lambda () (undefined? (case 1 ((2 3) #t)))))
48(prim-test "case" #t (lambda () (case 1 (() #f) ((1) #t))))
49(prim-test "case" #t (lambda () (case 1 (() #f) (else #t))))
50(prim-test "case" #t (lambda () (undefined? (case 1 (() #t)))))
51(prim-test "case (srfi-87)" 0 (lambda () (case (+ 2 3) ((1 3 5) 0) (else => values))))
52(prim-test "case (srfi-87)" 6 (lambda () (case (+ 2 3) ((1 3 5) => (cut + 1 <>)) (else => values))))
53(prim-test "case (srfi-87)" 5 (lambda () (case (+ 2 3) ((2 4 6) 0) (else => values))))
54
55;;----------------------------------------------------------------
56(test-section "binding")
57
58(prim-test "let" 35
59      (lambda ()
60        (let ((x 2) (y 3))
61          (let ((x 7) (z (+ x y)))
62            (* z x)))))
63(prim-test "let*" 70
64      (lambda ()
65        (let ((x 2) (y 3))
66          (let* ((x 7) (z (+ x y)))
67            (* z x)))))
68(prim-test "let*" 2
69      (lambda ()
70        (let* ((x 1) (x (+ x 1))) x)))
71
72(prim-test "named let" -3
73      (lambda ()
74        (let ((f -))
75          (let f ((a (f 3)))
76            a))))
77
78;;----------------------------------------------------------------
79(test-section "closure and saved env")
80
81(prim-test "lambda" 5  (lambda ()  ((lambda (x) (car x)) '(5 6 7))))
82(prim-test "lambda" 12
83      (lambda ()
84        ((lambda (x y)
85           ((lambda (z) (* (car z) (cdr z))) (cons x y))) 3 4)))
86
87(define (addN n) (lambda (a) (+ a n)))
88(prim-test "lambda" 5 (lambda ()  ((addN 2) 3)))
89(define add3 (addN 3))
90(prim-test "lambda" 9 (lambda ()  (add3 6)))
91
92(define count (let ((c 0)) (lambda () (set! c (+ c 1)) c)))
93(prim-test "lambda" 1 (lambda ()  (count)))
94(prim-test "lambda" 2 (lambda ()  (count)))
95
96;;----------------------------------------------------------------
97(test-section "application")
98
99(define Apply apply) ; avoid inline expansion
100
101(prim-test "apply" '(1 2 3) (lambda ()  (Apply list '(1 2 3))))
102(prim-test "apply" '(2 3 4) (lambda ()  (Apply list 2 '(3 4))))
103(prim-test "apply" '(3 4 5) (lambda ()  (Apply list 3 4 '(5))))
104(prim-test "apply" '(4 5 6) (lambda ()  (Apply list 4 5 6 '())))
105
106(prim-test "apply^2" '() (lambda () (Apply Apply list '() '())))
107(prim-test "Apply^2" '() (lambda () (Apply Apply list '(()))))
108(prim-test "apply^2" '(1 . 2) (lambda () (Apply Apply cons '((1 2)))))
109(prim-test "apply^2" '(3 . 4) (lambda () (Apply Apply cons 3 '((4)))))
110(prim-test "apply^2" '(5 . 6) (lambda () (Apply Apply (list cons 5 '(6)))))
111
112
113(prim-test "apply" '(6 7 8) (lambda ()  (Apply Apply (list list 6 7 '(8)))))
114
115
116;; This tests 'unfolding' path in ADJUST_ARGUMENT_FRAME.
117(prim-test "apply, copying args" '(1 2 3)
118           (lambda ()
119             (let ((orig (list 1 2 3)))
120               (let ((new (Apply list orig)))
121                 (set-car! (cdr new) '100)
122                 orig))))
123
124;; This tests 'folding' path in ADJUST_ARGUMENT_FRAME
125(prim-test "apply, copying args" '(2 3)
126           (lambda ()
127             (let ((orig (list 2 3)))
128               (let ((new (Apply list 1 orig)))
129                 (set-car! (cdr new) '100)
130                 orig))))
131
132;; Detect circular list in the argument
133;; https://github.com/shirok/Gauche/issues/684
134;; NB: At this point, we haven't tested #0= reader notation,
135;; and to avoid optimization, these data should be in global space.
136(define *apply-circular-data-1*
137  (let ((x (list 'a)))
138    (set-cdr! x x)
139    x))
140(define *apply-circular-data-2*
141  (let ((x (list 'a 'a)))
142    (set-cdr! (cdr x) x)
143    x))
144
145(prim-test "apply, circular list 1"
146           "improper list not allowed: #0=(a . #0#)"
147           (lambda ()
148             (with-error-handler
149                 (lambda (e) (slot-ref e 'message))
150               (lambda ()
151                 (apply list *apply-circular-data-1*)))))
152(prim-test "apply, circular list 2"
153           "improper list not allowed: #0=(a . #0#)"
154           (lambda ()
155             (with-error-handler
156                 (lambda (e) (slot-ref e 'message))
157               (lambda ()
158                 (apply list 'a *apply-circular-data-1*)))))
159(prim-test "apply, circular list 3"
160           "improper list not allowed: #0=(a a . #0#)"
161           (lambda ()
162             (with-error-handler
163                 (lambda (e) (slot-ref e 'message))
164               (lambda ()
165                 (apply list 'a *apply-circular-data-2*)))))
166(prim-test "apply, circular list 4"
167           "improper list not allowed: #0=(a a . #0#)"
168           (lambda ()
169             (with-error-handler
170                 (lambda (e) (slot-ref e 'message))
171               (lambda ()
172                 ;; This is caught in different place (#<subr apply>),
173                 ;; rather than VM APPLY instruction.
174                 (Apply list 'a *apply-circular-data-2*)))))
175
176;; This test exhibits the optimizer bug reported by Michael Campbell.
177(define bug-optimizer-local-inliner
178  (lambda (flag)
179    (define (a . args)
180      (receive x args
181        (cons x x)
182        (Apply values x))
183      (Apply format args))
184    (define (b bar)
185      (a "~a" bar))
186    (b 1)
187    (cond
188     (flag (b 1))
189     (else (a "~a" 1)))))
190(prim-test "apply local inliner optimizer" "1"
191           (lambda () (bug-optimizer-local-inliner #f)) equal?)
192(prim-test "apply local inliner optimizer" "1"
193           (lambda () (bug-optimizer-local-inliner #t)) equal?)
194
195(prim-test "map" '()         (lambda ()  (map car '())))
196(prim-test "map" '(1 2 3)    (lambda ()  (map car '((1) (2) (3)))))
197(prim-test "map" '(() () ()) (lambda ()  (map cdr '((1) (2) (3)))))
198(prim-test "map" '((1 . 4) (2 . 5) (3 . 6))  (lambda ()  (map cons '(1 2 3) '(4 5 6))))
199
200;;----------------------------------------------------------------
201(test-section "loop")
202
203(define (fact-non-tail-rec n)
204  (if (<= n 1) n (* n (fact-non-tail-rec (- n 1)))))
205(prim-test "loop non-tail-rec" 120 (lambda ()  (fact-non-tail-rec 5)))
206
207(define (fact-tail-rec n r)
208  (if (<= n 1) r (fact-tail-rec (- n 1) (* n r))))
209(prim-test "loop tail-rec"     120 (lambda ()  (fact-tail-rec 5 1)))
210
211(define (fact-named-let n)
212  (let loop ((n n) (r 1)) (if (<= n 1) r (loop (- n 1) (* n r)))))
213(prim-test "loop named-let"    120 (lambda ()  (fact-named-let 5)))
214
215(define (fact-int-define n)
216  (define (rec n r) (if (<= n 1) r (rec (- n 1) (* n r))))
217  (rec n 1))
218(prim-test "loop int-define"   120 (lambda ()  (fact-int-define 5)))
219
220(define (fact-do n)
221  (do ((n n (- n 1)) (r 1 (* n r))) ((<= n 1) r)))
222(prim-test "loop do"           120 (lambda ()  (fact-do 5)))
223
224;; tricky case
225(prim-test "do" #f (lambda () (do () (#t #f) #t)))
226
227;;----------------------------------------------------------------
228(test-section "quasiquote")
229
230;; The new compiler generates constant list for much wider
231;; range of quasiquoted forms (e.g. constant numerical expressions
232;; and constant variable definitions are folded at the compile time).
233
234(define-constant quasi0 99)
235(define quasi1 101)
236(define-constant quasi2 '(a b))
237(define quasi3 '(c d))
238
239(prim-test "qq" '(1 2 3)        (lambda ()  `(1 2 3)))
240(prim-test "qq" '()             (lambda ()  `()))
241(prim-test "qq"  99             (lambda ()  `,quasi0))
242(prim-test "qq"  101            (lambda ()  `,quasi1))
243(prim-test "qq," '((1 . 2))     (lambda ()  `(,(cons 1 2))))
244(prim-test "qq," '((1 . 2) 3)   (lambda ()  `(,(cons 1 2) 3)))
245(prim-test "qq," '(0 (1 . 2))   (lambda ()  `(0 ,(cons 1 2))))
246(prim-test "qq," '(0 (1 . 2) 3) (lambda ()  `(0 ,(cons 1 2) 3)))
247(prim-test "qq," '(((1 . 2)))   (lambda ()  `((,(cons 1 2)))))
248(prim-test "qq," '(((1 . 2)) 3) (lambda ()  `((,(cons 1 2)) 3)))
249(prim-test "qq," '(99 3)        (lambda ()  `(,quasi0 3)))
250(prim-test "qq," '(3 99)        (lambda ()  `(3 ,quasi0)))
251(prim-test "qq," '(3 99 3)      (lambda ()  `(3 ,quasi0 3)))
252(prim-test "qq," '(100 3)       (lambda ()  `(,(+ quasi0 1) 3)))
253(prim-test "qq," '(3 100)       (lambda ()  `(3 ,(+ quasi0 1))))
254(prim-test "qq," '(101 3)       (lambda ()  `(,quasi1 3)))
255(prim-test "qq," '(3 101)       (lambda ()  `(3 ,quasi1)))
256(prim-test "qq," '(102 3)       (lambda ()  `(,(+ quasi1 1) 3)))
257(prim-test "qq," '(3 102)       (lambda ()  `(3 ,(+ quasi1 1))))
258(prim-test "qq,(r6rs)" '(98 99 (a b) 100)
259           (lambda () `(98 (unquote quasi0 quasi2) 100)))
260(prim-test "qq,(r6rs)" '(98 99 101 100)
261           (lambda () `(98 (unquote quasi0 quasi1) 100)))
262(prim-test "qq,(r6rs)" '(98 99 (a b) 100)
263           (lambda () `(98 (unquote quasi0 quasi2) 100)))
264(prim-test "qq,(r6rs)" '(98 99 (a b) (1 2) (3 4))
265           (lambda () `(98 (unquote quasi0 quasi2) (unquote (list 1 2) (list 3 4)))))
266(prim-test "qq@" '(1 2 3 4)     (lambda ()  `(1 ,@(list 2 3) 4)))
267(prim-test "qq@" '(1 2 3 4)     (lambda ()  `(1 2 ,@(list 3 4))))
268(prim-test "qq@" '(a b c d)     (lambda ()  `(,@quasi2 ,@quasi3)))
269(prim-test "qq@(r6rs)" '(1 a b a b 2)
270           (lambda () `(1 (unquote-splicing quasi2 quasi2) 2)))
271(prim-test "qq@(r6rs)" '(1 a b c d 2)
272           (lambda () `(1 (unquote-splicing quasi2 quasi3) 2)))
273(prim-test "qq@(r6rs)" '(1 a b c d 2)
274           (lambda () `(1 (unquote-splicing (list 'a 'b) '(c d)) ,@(list 2))))
275(prim-test "qq." '(1 2 3 4)     (lambda ()  `(1 2 . ,(list 3 4))))
276(prim-test "qq." '(a b c d)     (lambda ()  `(,@quasi2 . ,quasi3)))
277(prim-test "qq#," '#((1 . 2) 3) (lambda ()  `#(,(cons 1 2) 3)))
278(prim-test "qq#," '#(99 3)      (lambda ()  `#(,quasi0 3)))
279(prim-test "qq#," '#(100 3)     (lambda ()  `#(,(+ quasi0 1) 3)))
280(prim-test "qq#," '#(3 101)     (lambda ()  `#(3 ,quasi1)))
281(prim-test "qq#," '#(3 102)     (lambda ()  `#(3 ,(+ quasi1 1))))
282(prim-test "qq#@" '#(1 2 3 4)   (lambda ()  `#(1 ,@(list 2 3) 4)))
283(prim-test "qq#@" '#(1 2 3 4)   (lambda ()  `#(1 2 ,@(list 3 4))))
284(prim-test "qq#@" '#(a b c d)   (lambda ()  `#(,@quasi2 ,@quasi3)))
285(prim-test "qq#@" '#(a b (c d)) (lambda ()  `#(,@quasi2 ,quasi3)))
286(prim-test "qq#@" '#((a b) c d) (lambda ()  `#(,quasi2  ,@quasi3)))
287(prim-test "qq#"  '#()          (lambda ()  `#()))
288(prim-test "qq#@" '#()          (lambda ()  `#(,@(list))))
289
290(prim-test "qq@@" '(1 2 1 2)    (lambda ()  `(,@(list 1 2) ,@(list 1 2))))
291(prim-test "qq@@" '(1 2 a 1 2)  (lambda ()  `(,@(list 1 2) a ,@(list 1 2))))
292(prim-test "qq@@" '(a 1 2 1 2)  (lambda ()  `(a ,@(list 1 2) ,@(list 1 2))))
293(prim-test "qq@@" '(1 2 1 2 a)  (lambda ()  `(,@(list 1 2) ,@(list 1 2) a)))
294(prim-test "qq@@" '(1 2 1 2 a b) (lambda ()  `(,@(list 1 2) ,@(list 1 2) a b)))
295(prim-test "qq@." '(1 2 1 2 . a)
296      (lambda ()  `(,@(list 1 2) ,@(list 1 2) . a)))
297(prim-test "qq@." '(1 2 1 2 1 . 2)
298      (lambda ()  `(,@(list 1 2) ,@(list 1 2) . ,(cons 1 2))))
299(prim-test "qq@." '(1 2 1 2 a b)
300      (lambda ()  `(,@(list 1 2) ,@(list 1 2) . ,quasi2)))
301(prim-test "qq@." '(1 2 1 2 a 1 . 2)
302      (lambda ()  `(,@(list 1 2) ,@(list 1 2) a . ,(cons 1 2))))
303(prim-test "qq@." '(1 2 1 2 a c d)
304      (lambda ()  `(,@(list 1 2) ,@(list 1 2) a . ,quasi3)))
305
306(prim-test "qq#@@" '#(1 2 1 2)    (lambda ()  `#(,@(list 1 2) ,@(list 1 2))))
307(prim-test "qq#@@" '#(1 2 a 1 2)  (lambda ()  `#(,@(list 1 2) a ,@(list 1 2))))
308(prim-test "qq#@@" '#(a 1 2 1 2)  (lambda ()  `#(a ,@(list 1 2) ,@(list 1 2))))
309(prim-test "qq#@@" '#(1 2 1 2 a)  (lambda ()  `#(,@(list 1 2) ,@(list 1 2) a)))
310(prim-test "qq#@@" '#(1 2 1 2 a b) (lambda () `#(,@(list 1 2) ,@(list 1 2) a b)))
311
312(prim-test "qqq"   '(1 `(1 ,2 ,3) 1)
313           (lambda ()  `(1 `(1 ,2 ,,(+ 1 2)) 1)))
314(prim-test "qqq"   '(1 `(1 ,99 ,101) 1)
315           (lambda ()  `(1 `(1 ,,quasi0 ,,quasi1) 1)))
316(prim-test "qqq"   '(1 `(1 ,@2 ,@(1 2)))
317           (lambda () `(1 `(1 ,@2 ,@,(list 1 2)))))
318(prim-test "qqq"   '(1 `(1 ,@2 (unquote 1 2)))
319           (lambda () `(1 `(1 ,@2 ,,@(list 1 2)))))
320(prim-test "qqq"   '(1 `(1 ,@2 (unquote-splicing 1 2)))
321           (lambda () `(1 `(1 ,@2 ,@,@(list 1 2)))))
322(prim-test "qqq"   '(1 `(1 ,@(a b) ,@(c d)))
323           (lambda () `(1 `(1 ,@,quasi2 ,@,quasi3))))
324(prim-test "qqq"   '(1 `(1 ,(a b x) ,(y c d)))
325           (lambda () `(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
326(prim-test "qqq#"  '#(1 `(1 ,2 ,3) 1)
327           (lambda ()  `#(1 `(1 ,2 ,,(+ 1 2)) 1)))
328(prim-test "qqq#"  '#(1 `(1 ,99 ,101) 1)
329           (lambda ()  `#(1 `(1 ,,quasi0 ,,quasi1) 1)))
330(prim-test "qqq#"  '#(1 `(1 ,@2 ,@(1 2)))
331           (lambda () `#(1 `(1 ,@2 ,@,(list 1 2)))))
332(prim-test "qqq#"  '#(1 `(1 ,@(a b) ,@(c d)))
333           (lambda () `#(1 `(1 ,@,quasi2 ,@,quasi3))))
334(prim-test "qqq#"  '#(1 `(1 ,(a b x) ,(y c d)))
335           (lambda () `#(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
336(prim-test "qqq#"  '(1 `#(1 ,(a b x) ,(y c d)))
337           (lambda () `(1 `#(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
338
339(prim-test "qq-hygiene 0" '(2 1)
340           (lambda () (let ((quasiquote reverse)) `(list 1 2))))
341(prim-test "qq-hygiene 1" '(,(+ 1 2))
342           (lambda () (let ((unquote 3)) `(,(+ 1 2)))))
343(prim-test "qq-hygiene 2" '(,@(+ 1 2))
344           (lambda () (let ((unquote-splicing 3)) `(,@(+ 1 2)))))
345
346;;----------------------------------------------------------------
347(test-section "multiple values")
348
349(prim-test "receive" '(1 2 3)
350      (lambda ()  (receive (a b c) (values 1 2 3) (list a b c))))
351(prim-test "receive" '(1 2 3)
352      (lambda ()  (receive (a . r) (values 1 2 3) (cons a r))))
353(prim-test "receive" '(1 2 3)
354      (lambda ()  (receive x (values 1 2 3) x)))
355(prim-test "receive" 1
356      (lambda ()  (receive (a) 1 a)))
357(prim-test "call-with-values" '(1 2 3)
358      (lambda ()  (call-with-values (lambda () (values 1 2 3)) list)))
359(prim-test "call-with-values" '()
360      (lambda ()  (call-with-values (lambda () (values)) list)))
361
362;; This is not 'right' in R5RS sense---for now, I just tolerate it
363;; by CommonLisp way, i.e. if more than one value is passed to an
364;; implicit continuation that expects one value, the second and after
365;; values are just discarded.  This behavior may be changed later,
366;; so do not count on it.   The test just make sure it doesn't screw
367;; up anything.
368(prim-test "receive" '((0 0))
369      (lambda ()  (receive l (list 0 (values 0 1 2)) l)))
370
371;;----------------------------------------------------------------
372(test-section "eval")
373
374(prim-test "eval" '(1 . 2)
375      (lambda () (eval '(cons 1 2) (interaction-environment))))
376
377(define (vector-ref x y) 'foo)
378
379(prim-test "eval" '(foo foo 3)
380      (lambda ()
381        (list (vector-ref '#(3) 0)
382              (eval '(vector-ref '#(3) 0) (interaction-environment))
383              (eval '(vector-ref '#(3) 0) (scheme-report-environment 5)))))
384
385(define vector-ref (with-module scheme vector-ref))
386
387(prim-test "eval" #t
388      (lambda ()
389        (with-error-handler
390         (lambda (e) #t)
391         (lambda () (eval '(car '(3 2)) (null-environment 5))))))
392
393;; check interaction w/ modules
394(define-module primsyn.test (define foo 'a))
395(define foo '(x y))
396
397(prim-test "eval (module)" '(a b (x y))
398      (lambda ()
399        (let* ((m (find-module 'primsyn.test))
400               (a (eval 'foo m))
401               (b (eval '(begin (set! foo 'b) foo) m)))
402          (list a b foo))))
403
404(prim-test "eval (module)" '(x y)
405      (lambda ()
406        (with-error-handler
407            (lambda (e) foo)
408          (lambda ()
409            (eval '(Apply car foo '()) (find-module 'primsyn.test))))))
410
411;;----------------------------------------------------------------
412(test-section "max literal arguments")
413
414;; Fix this after we have separate compile-error condition.
415(define (test-max-literal-args msg expr)
416  (prim-test (string-append "max literal arguments for " msg)
417             'caught
418             (lambda ()
419               (with-error-handler (lambda (e) 'caught)
420                 (lambda () (eval expr (interaction-environment)))))))
421
422(test-max-literal-args "inliner" `(list ,@(make-list 10000 #f)))
423(test-max-literal-args "global proc" `(make ,@(make-list 10000 #f)))
424(test-max-literal-args "local proc"
425                       `(let ((foo (lambda x x)))
426                          (foo ,@(make-list 10000 #f))))
427
428;;----------------------------------------------------------------
429(test-section "local procedure optimization")
430
431;; this caused an internal compiler error in 0.8.6.
432;; (found and fixed by Jun Inoue)
433(prim-test "internal-define inilining" '(1)
434           (lambda ()
435             (with-error-handler
436                 (lambda (e) 'ouch!)
437               (lambda ()
438                 (eval '(let ()
439                          (define (a x) x)
440                          (define (b x) (a x))
441                          (define (c x) (b x))
442                          (list 1))
443                       (interaction-environment))))))
444
445;; this caused an internal compiler error in 0.8.6
446;; (found and fixed by Kazuki Tsujimoto)
447(prim-test "multiple inlining" 0
448           (lambda ()
449             (let ((f (lambda (i) (set! i 0) i))) (f (f 1)))))
450
451;; this caused an internal compiler error in 0.9.1
452(define (zero) 0)
453(prim-test "pass3 inlining with pass3/$call optimization" #t
454           (lambda ()
455             (eval '((letrec ((f (lambda (a b)
456                                   (do ((x a (+ x 1)))
457                                       ((>= x b))))))
458                       f)
459                     (zero) (zero))
460                   (interaction-environment))))
461
462;; This caused internal error in 0.9.1, and infinite loop in dev version
463;; after it.
464(prim-test "pass3/$call inlining problem" #t
465           (lambda ()
466             (procedure?
467              (eval '(lambda (n p t)
468                       (define (y a r s f)
469                         (let loop ([e 0])
470                           (cond [(a n) (unwind-protect (s) (r n))]
471                                 [(< e 10) (loop (+ 1 e))]
472                                 [else (f)])))
473                       (define (l0 a r)
474                         (y a r (^() (r n)) (^() (error "oo"))))
475                       ;; Main locker
476                       (define (l1 a r)
477                         (y a r p (^() (if (and-let* ([ t ]
478                                                      [m (file-mtime n)])
479                                             (< (+ m t) 10))
480                                         (begin (l0 a r) (l1 a r))))))
481                       (error "zz"))
482                    (interaction-environment)))))
483
484;;----------------------------------------------------------------
485(test-section "optimized frames")
486
487;; Empty environment frame is omitted by compiler optimization.
488;; The following tests makes sure if it works correctly.
489
490(prim-test "lambda (empty env)" 1
491      (lambda ()
492        (let* ((a 1)
493               (b (lambda ()
494                    ((lambda () a)))))
495          (b))))
496
497(prim-test "let (empty env)" 1
498      (lambda ()
499        (let ((a 1))
500          (let ()
501            (let ()
502              a)))))
503
504(prim-test "let (empty env)" '(1 . 1)
505      (lambda ()
506        (let ((a 1))
507          (cons (let () (let () a))
508                (let* () (letrec () a))))))
509
510(prim-test "let (empty env)" '(3 . 1)
511      (lambda ()
512        (let ((a 1)
513              (b 0))
514          (cons (let () (let () (set! b 3)) b)
515                (let () (let () a))))))
516
517(prim-test "named let (empty env)" 1
518      (lambda ()
519        (let ((a -1))
520          (let loop ()
521            (unless (positive? a)
522              (set! a (+ a 1))
523              (loop)))
524          a)))
525
526(prim-test "do (empty env)" 1
527      (lambda () (let ((a 0)) (do () ((positive? a) a) (set! a (+ a 1))))))
528
529;;----------------------------------------------------------------
530(test-section "hygienity")
531
532(prim-test "hygienity (named let)" 4
533      (lambda ()
534        (let ((lambda list))
535          (let loop ((x 0))
536            (if (> x 3) x (loop (+ x 1)))))))
537
538(prim-test "hygienity (internal defines)" 4
539      (lambda ()
540        (let ((lambda list))
541          (define (x) 4)
542          (x))))
543
544(prim-test "hygienity (do)" 4
545      (lambda ()
546        (let ((lambda #f)
547              (begin  #f)
548              (if     #f)
549              (letrec #f))
550          (do ((x 0 (+ x 1)))
551              ((> x 3) x)
552            #f))))
553
554;;----------------------------------------------------------------
555(test-section "letrec and letrec*")
556
557(prim-test "letrec reordering" '((1 3) . (2 3 1))
558           (lambda ()
559             (let ((r '()))
560               (cons (letrec ((a (begin (set! r (cons 1 r)) 1))
561                              (b (begin (set! r (cons 2 r)) 2))
562                              (c (begin (set! r (cons 3 r)) 3)))
563                       (list a c))
564                     r))))
565
566(prim-test "letrec* non-reordering" '((1 3) . (3 2 1))
567           (lambda ()
568             (let ((r '()))
569               (cons (letrec* ((a (begin (set! r (cons 1 r)) 1))
570                               (b (begin (set! r (cons 2 r)) 2))
571                               (c (begin (set! r (cons 3 r)) 3)))
572                       (list a c))
573                     r))))
574
575
576(test-end)
577
578