Commit | Line | Data |
---|---|---|
08c608e1 DH |
1 | ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- |
2 | ;;;; | |
aa498d0c | 3 | ;;;; Copyright (C) 2001,2003,2004 Free Software Foundation, Inc. |
08c608e1 DH |
4 | ;;;; |
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. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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., 59 Temple Place, Suite 330, | |
18 | ;;;; Boston, MA 02111-1307 USA | |
19 | ||
8aa28a91 DH |
20 | (define-module (test-suite test-syntax) |
21 | :use-module (test-suite lib)) | |
08c608e1 | 22 | |
2a6f7afe DH |
23 | |
24 | (define exception:bad-expression | |
25 | (cons 'syntax-error "Bad expression")) | |
cc56ba80 | 26 | |
21628685 | 27 | (define exception:missing/extra-expr |
89bff2fc | 28 | (cons 'syntax-error "Missing or extra expression")) |
cc56ba80 DH |
29 | (define exception:missing-expr |
30 | (cons 'syntax-error "Missing expression")) | |
ced8edb0 DH |
31 | (define exception:missing-body-expr |
32 | (cons 'syntax-error "Missing body expression")) | |
cc56ba80 DH |
33 | (define exception:extra-expr |
34 | (cons 'syntax-error "Extra expression")) | |
89bff2fc DH |
35 | (define exception:illegal-empty-combination |
36 | (cons 'syntax-error "Illegal empty combination")) | |
cc56ba80 | 37 | |
08c608e1 | 38 | (define exception:bad-bindings |
d6754c23 DH |
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")) | |
08c608e1 DH |
44 | (define exception:bad-body |
45 | (cons 'misc-error "^bad body")) | |
46 | (define exception:bad-formals | |
03a3e941 DH |
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")) | |
cc56ba80 | 52 | |
2a6f7afe DH |
53 | (define exception:missing-clauses |
54 | (cons 'syntax-error "Missing clauses")) | |
609a8b86 DH |
55 | (define exception:misplaced-else-clause |
56 | (cons 'syntax-error "Misplaced else clause")) | |
2a6f7afe DH |
57 | (define exception:bad-case-clause |
58 | (cons 'syntax-error "Bad case clause")) | |
2a6f7afe DH |
59 | (define exception:bad-case-labels |
60 | (cons 'syntax-error "Bad case labels")) | |
609a8b86 DH |
61 | (define exception:bad-cond-clause |
62 | (cons 'syntax-error "Bad cond clause")) | |
cc56ba80 | 63 | |
08c608e1 DH |
64 | |
65 | (with-test-prefix "expressions" | |
66 | ||
d6e04e7c DH |
67 | (with-test-prefix "Bad argument list" |
68 | ||
69 | (pass-if-exception "improper argument list of length 1" | |
70 | exception:wrong-num-args | |
71 | (eval '(let ((foo (lambda (x y) #t))) | |
72 | (foo . 1)) | |
73 | (interaction-environment))) | |
74 | ||
75 | (pass-if-exception "improper argument list of length 2" | |
76 | exception:wrong-num-args | |
77 | (eval '(let ((foo (lambda (x y) #t))) | |
78 | (foo 1 . 2)) | |
79 | (interaction-environment)))) | |
80 | ||
08c608e1 DH |
81 | (with-test-prefix "missing or extra expression" |
82 | ||
83 | ;; R5RS says: | |
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 | |
87 | ;; valid expression. | |
1c54a87c MV |
88 | |
89 | ;; Fixed on 2001-3-3 | |
90 | (pass-if-exception "empty parentheses \"()\"" | |
89bff2fc | 91 | exception:illegal-empty-combination |
d6e04e7c DH |
92 | (eval '() |
93 | (interaction-environment))))) | |
08c608e1 | 94 | |
7171f1ab DH |
95 | (with-test-prefix "quote" |
96 | #t) | |
97 | ||
98 | (with-test-prefix "quasiquote" | |
99 | ||
100 | (with-test-prefix "unquote" | |
101 | ||
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)))))) | |
105 | ||
106 | (with-test-prefix "unquote-splicing" | |
107 | ||
108 | (pass-if-exception "extra arguments" | |
109 | exception:missing/extra-expr | |
110 | (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) | |
111 | ||
112 | (with-test-prefix "begin" | |
113 | ||
114 | (pass-if "legal (begin)" | |
115 | (begin) | |
116 | #t) | |
117 | ||
aa498d0c DH |
118 | (with-test-prefix "unmemoization" |
119 | ||
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))))))) | |
125 | ||
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)))))))) | |
131 | ||
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))))))) | |
137 | ||
7171f1ab DH |
138 | (expect-fail-exception "illegal (begin)" |
139 | exception:bad-body | |
140 | (if #t (begin)) | |
141 | #t)) | |
142 | ||
08c608e1 DH |
143 | (with-test-prefix "lambda" |
144 | ||
aa498d0c DH |
145 | (with-test-prefix "unmemoization" |
146 | ||
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)))))) | |
152 | ||
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))))))) | |
158 | ||
08c608e1 DH |
159 | (with-test-prefix "bad formals" |
160 | ||
ea6c2147 | 161 | (pass-if-exception "(lambda)" |
03a3e941 | 162 | exception:missing-expr |
d6e04e7c DH |
163 | (eval '(lambda) |
164 | (interaction-environment))) | |
ea6c2147 DH |
165 | |
166 | (pass-if-exception "(lambda . \"foo\")" | |
03a3e941 | 167 | exception:bad-expression |
d6e04e7c DH |
168 | (eval '(lambda . "foo") |
169 | (interaction-environment))) | |
ea6c2147 | 170 | |
ea6c2147 | 171 | (pass-if-exception "(lambda \"foo\")" |
03a3e941 | 172 | exception:missing-expr |
d6e04e7c DH |
173 | (eval '(lambda "foo") |
174 | (interaction-environment))) | |
ea6c2147 DH |
175 | |
176 | (pass-if-exception "(lambda \"foo\" #f)" | |
177 | exception:bad-formals | |
4dce3c96 DH |
178 | (eval '(lambda "foo" #f) |
179 | (interaction-environment))) | |
ea6c2147 DH |
180 | |
181 | (pass-if-exception "(lambda (x 1) 2)" | |
03a3e941 | 182 | exception:bad-formal |
d6e04e7c DH |
183 | (eval '(lambda (x 1) 2) |
184 | (interaction-environment))) | |
08c608e1 DH |
185 | |
186 | (pass-if-exception "(lambda (1 x) 2)" | |
03a3e941 | 187 | exception:bad-formal |
d6e04e7c DH |
188 | (eval '(lambda (1 x) 2) |
189 | (interaction-environment))) | |
08c608e1 DH |
190 | |
191 | (pass-if-exception "(lambda (x \"a\") 2)" | |
03a3e941 | 192 | exception:bad-formal |
d6e04e7c DH |
193 | (eval '(lambda (x "a") 2) |
194 | (interaction-environment))) | |
08c608e1 DH |
195 | |
196 | (pass-if-exception "(lambda (\"a\" x) 2)" | |
03a3e941 | 197 | exception:bad-formal |
d6e04e7c DH |
198 | (eval '(lambda ("a" x) 2) |
199 | (interaction-environment)))) | |
08c608e1 | 200 | |
1c54a87c MV |
201 | (with-test-prefix "duplicate formals" |
202 | ||
203 | ;; Fixed on 2001-3-3 | |
204 | (pass-if-exception "(lambda (x x) 1)" | |
03a3e941 | 205 | exception:duplicate-formal |
d6e04e7c DH |
206 | (eval '(lambda (x x) 1) |
207 | (interaction-environment))) | |
08c608e1 | 208 | |
1c54a87c MV |
209 | ;; Fixed on 2001-3-3 |
210 | (pass-if-exception "(lambda (x x x) 1)" | |
03a3e941 | 211 | exception:duplicate-formal |
d6e04e7c DH |
212 | (eval '(lambda (x x x) 1) |
213 | (interaction-environment)))) | |
7171f1ab DH |
214 | |
215 | (with-test-prefix "bad body" | |
216 | ||
217 | (pass-if-exception "(lambda ())" | |
03a3e941 | 218 | exception:missing-expr |
d6e04e7c DH |
219 | (eval '(lambda ()) |
220 | (interaction-environment))))) | |
08c608e1 DH |
221 | |
222 | (with-test-prefix "let" | |
223 | ||
aa498d0c DH |
224 | (with-test-prefix "unmemoization" |
225 | ||
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))))))) | |
231 | ||
08c608e1 DH |
232 | (with-test-prefix "bindings" |
233 | ||
234 | (pass-if-exception "late binding" | |
235 | exception:unbound-var | |
236 | (let ((x 1) (y x)) y))) | |
237 | ||
7171f1ab | 238 | (with-test-prefix "bad bindings" |
08c608e1 | 239 | |
08c608e1 | 240 | (pass-if-exception "(let)" |
d6754c23 | 241 | exception:missing-expr |
d6e04e7c DH |
242 | (eval '(let) |
243 | (interaction-environment))) | |
08c608e1 | 244 | |
08c608e1 | 245 | (pass-if-exception "(let 1)" |
d6754c23 | 246 | exception:missing-expr |
d6e04e7c DH |
247 | (eval '(let 1) |
248 | (interaction-environment))) | |
08c608e1 | 249 | |
08c608e1 | 250 | (pass-if-exception "(let (x))" |
d6754c23 | 251 | exception:missing-expr |
d6e04e7c DH |
252 | (eval '(let (x)) |
253 | (interaction-environment))) | |
08c608e1 | 254 | |
7171f1ab | 255 | (pass-if-exception "(let ((x)))" |
d6754c23 | 256 | exception:missing-expr |
d6e04e7c DH |
257 | (eval '(let ((x))) |
258 | (interaction-environment))) | |
08c608e1 DH |
259 | |
260 | (pass-if-exception "(let (x) 1)" | |
d6754c23 | 261 | exception:bad-binding |
d6e04e7c DH |
262 | (eval '(let (x) 1) |
263 | (interaction-environment))) | |
08c608e1 DH |
264 | |
265 | (pass-if-exception "(let ((x)) 3)" | |
d6754c23 | 266 | exception:bad-binding |
d6e04e7c DH |
267 | (eval '(let ((x)) 3) |
268 | (interaction-environment))) | |
08c608e1 DH |
269 | |
270 | (pass-if-exception "(let ((x 1) y) x)" | |
d6754c23 | 271 | exception:bad-binding |
d6e04e7c DH |
272 | (eval '(let ((x 1) y) x) |
273 | (interaction-environment))) | |
08c608e1 DH |
274 | |
275 | (pass-if-exception "(let ((1 2)) 3)" | |
d6754c23 | 276 | exception:bad-variable |
4dce3c96 DH |
277 | (eval '(let ((1 2)) 3) |
278 | (interaction-environment)))) | |
08c608e1 | 279 | |
c0ed1605 MV |
280 | (with-test-prefix "duplicate bindings" |
281 | ||
282 | (pass-if-exception "(let ((x 1) (x 2)) x)" | |
d6754c23 | 283 | exception:duplicate-binding |
d6e04e7c DH |
284 | (eval '(let ((x 1) (x 2)) x) |
285 | (interaction-environment)))) | |
7171f1ab DH |
286 | |
287 | (with-test-prefix "bad body" | |
288 | ||
289 | (pass-if-exception "(let ())" | |
d6754c23 | 290 | exception:missing-expr |
d6e04e7c DH |
291 | (eval '(let ()) |
292 | (interaction-environment))) | |
7171f1ab DH |
293 | |
294 | (pass-if-exception "(let ((x 1)))" | |
d6754c23 | 295 | exception:missing-expr |
d6e04e7c DH |
296 | (eval '(let ((x 1))) |
297 | (interaction-environment))))) | |
08c608e1 DH |
298 | |
299 | (with-test-prefix "named let" | |
300 | ||
7171f1ab DH |
301 | (with-test-prefix "initializers" |
302 | ||
303 | (pass-if "evaluated in outer environment" | |
304 | (let ((f -)) | |
305 | (eqv? (let f ((n (f 1))) n) -1)))) | |
306 | ||
307 | (with-test-prefix "bad bindings" | |
308 | ||
309 | (pass-if-exception "(let x (y))" | |
d6754c23 | 310 | exception:missing-expr |
d6e04e7c DH |
311 | (eval '(let x (y)) |
312 | (interaction-environment)))) | |
7171f1ab | 313 | |
08c608e1 DH |
314 | (with-test-prefix "bad body" |
315 | ||
316 | (pass-if-exception "(let x ())" | |
d6754c23 | 317 | exception:missing-expr |
d6e04e7c DH |
318 | (eval '(let x ()) |
319 | (interaction-environment))) | |
08c608e1 DH |
320 | |
321 | (pass-if-exception "(let x ((y 1)))" | |
d6754c23 | 322 | exception:missing-expr |
d6e04e7c DH |
323 | (eval '(let x ((y 1))) |
324 | (interaction-environment))))) | |
08c608e1 DH |
325 | |
326 | (with-test-prefix "let*" | |
327 | ||
aa498d0c DH |
328 | (with-test-prefix "unmemoization" |
329 | ||
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)))))) | |
335 | ||
336 | (pass-if "let* without bindings" | |
337 | (let ((foo (lambda () (let ((x 1) (y 2)) | |
338 | (let* () | |
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)) | |
343 | (let* () | |
344 | (and (= x 1) (= y 2))))))))) | |
345 | ||
e1a7b2ce DH |
346 | (with-test-prefix "bindings" |
347 | ||
348 | (pass-if "(let* ((x 1) (x 2)) ...)" | |
349 | (let* ((x 1) (x 2)) | |
350 | (= x 2))) | |
351 | ||
352 | (pass-if "(let* ((x 1) (x x)) ...)" | |
353 | (let* ((x 1) (x x)) | |
aa498d0c DH |
354 | (= x 1))) |
355 | ||
356 | (pass-if "(let ((x 1) (y 2)) (let* () ...))" | |
357 | (let ((x 1) (y 2)) | |
358 | (let* () | |
359 | (and (= x 1) (= y 2)))))) | |
e1a7b2ce | 360 | |
7171f1ab | 361 | (with-test-prefix "bad bindings" |
08c608e1 | 362 | |
08c608e1 | 363 | (pass-if-exception "(let*)" |
d6754c23 | 364 | exception:missing-expr |
d6e04e7c DH |
365 | (eval '(let*) |
366 | (interaction-environment))) | |
08c608e1 | 367 | |
08c608e1 | 368 | (pass-if-exception "(let* 1)" |
d6754c23 | 369 | exception:missing-expr |
d6e04e7c DH |
370 | (eval '(let* 1) |
371 | (interaction-environment))) | |
08c608e1 | 372 | |
08c608e1 | 373 | (pass-if-exception "(let* (x))" |
d6754c23 | 374 | exception:missing-expr |
d6e04e7c DH |
375 | (eval '(let* (x)) |
376 | (interaction-environment))) | |
08c608e1 DH |
377 | |
378 | (pass-if-exception "(let* (x) 1)" | |
d6754c23 | 379 | exception:bad-binding |
d6e04e7c DH |
380 | (eval '(let* (x) 1) |
381 | (interaction-environment))) | |
08c608e1 DH |
382 | |
383 | (pass-if-exception "(let* ((x)) 3)" | |
d6754c23 | 384 | exception:bad-binding |
d6e04e7c DH |
385 | (eval '(let* ((x)) 3) |
386 | (interaction-environment))) | |
08c608e1 DH |
387 | |
388 | (pass-if-exception "(let* ((x 1) y) x)" | |
d6754c23 | 389 | exception:bad-binding |
d6e04e7c DH |
390 | (eval '(let* ((x 1) y) x) |
391 | (interaction-environment))) | |
08c608e1 DH |
392 | |
393 | (pass-if-exception "(let* x ())" | |
394 | exception:bad-bindings | |
4dce3c96 DH |
395 | (eval '(let* x ()) |
396 | (interaction-environment))) | |
08c608e1 DH |
397 | |
398 | (pass-if-exception "(let* x (y))" | |
399 | exception:bad-bindings | |
4dce3c96 DH |
400 | (eval '(let* x (y)) |
401 | (interaction-environment))) | |
08c608e1 DH |
402 | |
403 | (pass-if-exception "(let* ((1 2)) 3)" | |
d6754c23 | 404 | exception:bad-variable |
4dce3c96 DH |
405 | (eval '(let* ((1 2)) 3) |
406 | (interaction-environment)))) | |
7171f1ab DH |
407 | |
408 | (with-test-prefix "bad body" | |
409 | ||
410 | (pass-if-exception "(let* ())" | |
d6754c23 | 411 | exception:missing-expr |
d6e04e7c DH |
412 | (eval '(let* ()) |
413 | (interaction-environment))) | |
7171f1ab DH |
414 | |
415 | (pass-if-exception "(let* ((x 1)))" | |
d6754c23 | 416 | exception:missing-expr |
d6e04e7c DH |
417 | (eval '(let* ((x 1))) |
418 | (interaction-environment))))) | |
08c608e1 DH |
419 | |
420 | (with-test-prefix "letrec" | |
421 | ||
aa498d0c DH |
422 | (with-test-prefix "unmemoization" |
423 | ||
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))))))) | |
429 | ||
08c608e1 DH |
430 | (with-test-prefix "bindings" |
431 | ||
432 | (pass-if-exception "initial bindings are undefined" | |
0ac46745 | 433 | exception:used-before-defined |
08c608e1 DH |
434 | (let ((x 1)) |
435 | (letrec ((x 1) (y x)) y)))) | |
436 | ||
7171f1ab | 437 | (with-test-prefix "bad bindings" |
08c608e1 | 438 | |
08c608e1 | 439 | (pass-if-exception "(letrec)" |
d6754c23 | 440 | exception:missing-expr |
d6e04e7c DH |
441 | (eval '(letrec) |
442 | (interaction-environment))) | |
08c608e1 | 443 | |
08c608e1 | 444 | (pass-if-exception "(letrec 1)" |
d6754c23 | 445 | exception:missing-expr |
d6e04e7c DH |
446 | (eval '(letrec 1) |
447 | (interaction-environment))) | |
08c608e1 | 448 | |
08c608e1 | 449 | (pass-if-exception "(letrec (x))" |
d6754c23 | 450 | exception:missing-expr |
d6e04e7c DH |
451 | (eval '(letrec (x)) |
452 | (interaction-environment))) | |
08c608e1 DH |
453 | |
454 | (pass-if-exception "(letrec (x) 1)" | |
d6754c23 | 455 | exception:bad-binding |
d6e04e7c DH |
456 | (eval '(letrec (x) 1) |
457 | (interaction-environment))) | |
08c608e1 DH |
458 | |
459 | (pass-if-exception "(letrec ((x)) 3)" | |
d6754c23 | 460 | exception:bad-binding |
d6e04e7c DH |
461 | (eval '(letrec ((x)) 3) |
462 | (interaction-environment))) | |
08c608e1 DH |
463 | |
464 | (pass-if-exception "(letrec ((x 1) y) x)" | |
d6754c23 | 465 | exception:bad-binding |
d6e04e7c DH |
466 | (eval '(letrec ((x 1) y) x) |
467 | (interaction-environment))) | |
08c608e1 DH |
468 | |
469 | (pass-if-exception "(letrec x ())" | |
470 | exception:bad-bindings | |
4dce3c96 DH |
471 | (eval '(letrec x ()) |
472 | (interaction-environment))) | |
08c608e1 DH |
473 | |
474 | (pass-if-exception "(letrec x (y))" | |
475 | exception:bad-bindings | |
4dce3c96 DH |
476 | (eval '(letrec x (y)) |
477 | (interaction-environment))) | |
08c608e1 DH |
478 | |
479 | (pass-if-exception "(letrec ((1 2)) 3)" | |
d6754c23 | 480 | exception:bad-variable |
4dce3c96 DH |
481 | (eval '(letrec ((1 2)) 3) |
482 | (interaction-environment)))) | |
08c608e1 | 483 | |
c0ed1605 MV |
484 | (with-test-prefix "duplicate bindings" |
485 | ||
486 | (pass-if-exception "(letrec ((x 1) (x 2)) x)" | |
d6754c23 | 487 | exception:duplicate-binding |
d6e04e7c DH |
488 | (eval '(letrec ((x 1) (x 2)) x) |
489 | (interaction-environment)))) | |
7171f1ab DH |
490 | |
491 | (with-test-prefix "bad body" | |
492 | ||
493 | (pass-if-exception "(letrec ())" | |
d6754c23 | 494 | exception:missing-expr |
d6e04e7c DH |
495 | (eval '(letrec ()) |
496 | (interaction-environment))) | |
7171f1ab DH |
497 | |
498 | (pass-if-exception "(letrec ((x 1)))" | |
d6754c23 | 499 | exception:missing-expr |
d6e04e7c DH |
500 | (eval '(letrec ((x 1))) |
501 | (interaction-environment))))) | |
08c608e1 DH |
502 | |
503 | (with-test-prefix "if" | |
504 | ||
aa498d0c DH |
505 | (with-test-prefix "unmemoization" |
506 | ||
507 | (pass-if "normal if" | |
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)))))) | |
513 | ||
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)))))) | |
520 | ||
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)))))) | |
526 | ||
08c608e1 DH |
527 | (with-test-prefix "missing or extra expressions" |
528 | ||
529 | (pass-if-exception "(if)" | |
21628685 | 530 | exception:missing/extra-expr |
4dce3c96 DH |
531 | (eval '(if) |
532 | (interaction-environment))) | |
08c608e1 DH |
533 | |
534 | (pass-if-exception "(if 1 2 3 4)" | |
21628685 | 535 | exception:missing/extra-expr |
4dce3c96 DH |
536 | (eval '(if 1 2 3 4) |
537 | (interaction-environment))))) | |
08c608e1 DH |
538 | |
539 | (with-test-prefix "cond" | |
540 | ||
aa498d0c DH |
541 | (with-test-prefix "cond is hygienic" |
542 | ||
543 | (pass-if "bound 'else is handled correctly" | |
544 | (eq? (let ((else 'ok)) (cond (else))) 'ok)) | |
545 | ||
546 | (with-test-prefix "bound '=> is handled correctly" | |
547 | ||
548 | (pass-if "#t => 'ok" | |
549 | (let ((=> 'foo)) | |
550 | (eq? (cond (#t => 'ok)) 'ok))) | |
551 | ||
552 | (pass-if "else =>" | |
553 | (let ((=> 'foo)) | |
554 | (eq? (cond (else =>)) 'foo))) | |
555 | ||
556 | (pass-if "else => identity" | |
557 | (let ((=> 'foo)) | |
558 | (eq? (cond (else => identity)) identity))))) | |
559 | ||
560 | (with-test-prefix "unmemoization" | |
561 | ||
562 | (pass-if "normal clauses" | |
563 | (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) | |
564 | (foo 1) ; make sure, memoization has been performed | |
565 | (foo 2) ; make sure, memoization has been performed | |
566 | (equal? (procedure-source foo) | |
567 | '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) | |
568 | ||
569 | (pass-if "else" | |
570 | (let ((foo (lambda () (cond (else 'bar))))) | |
571 | (foo) ; make sure, memoization has been performed | |
572 | (equal? (procedure-source foo) | |
573 | '(lambda () (cond (else 'bar)))))) | |
574 | ||
575 | (pass-if "=>" | |
576 | (let ((foo (lambda () (cond (#t => identity))))) | |
577 | (foo) ; make sure, memoization has been performed | |
578 | (equal? (procedure-source foo) | |
579 | '(lambda () (cond (#t => identity))))))) | |
580 | ||
08c608e1 DH |
581 | (with-test-prefix "bad or missing clauses" |
582 | ||
583 | (pass-if-exception "(cond)" | |
609a8b86 | 584 | exception:missing-clauses |
d6e04e7c DH |
585 | (eval '(cond) |
586 | (interaction-environment))) | |
08c608e1 DH |
587 | |
588 | (pass-if-exception "(cond #t)" | |
609a8b86 | 589 | exception:bad-cond-clause |
d6e04e7c DH |
590 | (eval '(cond #t) |
591 | (interaction-environment))) | |
08c608e1 DH |
592 | |
593 | (pass-if-exception "(cond 1)" | |
609a8b86 | 594 | exception:bad-cond-clause |
d6e04e7c DH |
595 | (eval '(cond 1) |
596 | (interaction-environment))) | |
08c608e1 DH |
597 | |
598 | (pass-if-exception "(cond 1 2)" | |
609a8b86 | 599 | exception:bad-cond-clause |
d6e04e7c DH |
600 | (eval '(cond 1 2) |
601 | (interaction-environment))) | |
08c608e1 DH |
602 | |
603 | (pass-if-exception "(cond 1 2 3)" | |
609a8b86 | 604 | exception:bad-cond-clause |
d6e04e7c DH |
605 | (eval '(cond 1 2 3) |
606 | (interaction-environment))) | |
08c608e1 DH |
607 | |
608 | (pass-if-exception "(cond 1 2 3 4)" | |
609a8b86 | 609 | exception:bad-cond-clause |
d6e04e7c DH |
610 | (eval '(cond 1 2 3 4) |
611 | (interaction-environment))) | |
08c608e1 DH |
612 | |
613 | (pass-if-exception "(cond ())" | |
609a8b86 | 614 | exception:bad-cond-clause |
d6e04e7c DH |
615 | (eval '(cond ()) |
616 | (interaction-environment))) | |
08c608e1 DH |
617 | |
618 | (pass-if-exception "(cond () 1)" | |
609a8b86 | 619 | exception:bad-cond-clause |
d6e04e7c DH |
620 | (eval '(cond () 1) |
621 | (interaction-environment))) | |
08c608e1 DH |
622 | |
623 | (pass-if-exception "(cond (1) 1)" | |
609a8b86 | 624 | exception:bad-cond-clause |
d6e04e7c | 625 | (eval '(cond (1) 1) |
aa498d0c | 626 | (interaction-environment)))) |
b461abe7 | 627 | |
d6e04e7c | 628 | (with-test-prefix "wrong number of arguments" |
08c608e1 | 629 | |
d6e04e7c DH |
630 | (pass-if-exception "=> (lambda (x y) #t)" |
631 | exception:wrong-num-args | |
632 | (cond (1 => (lambda (x y) #t)))))) | |
08c608e1 | 633 | |
27a22666 DH |
634 | (with-test-prefix "case" |
635 | ||
58a2510b DH |
636 | (pass-if "clause with empty labels list" |
637 | (case 1 (() #f) (else #t))) | |
638 | ||
2a6f7afe DH |
639 | (with-test-prefix "case is hygienic" |
640 | ||
641 | (pass-if-exception "bound 'else is handled correctly" | |
642 | exception:bad-case-labels | |
643 | (eval '(let ((else #f)) (case 1 (else #f))) | |
644 | (interaction-environment)))) | |
645 | ||
aa498d0c DH |
646 | (with-test-prefix "unmemoization" |
647 | ||
648 | (pass-if "normal clauses" | |
649 | (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) | |
650 | (foo 1) ; make sure, memoization has been performed | |
651 | (foo 2) ; make sure, memoization has been performed | |
652 | (foo 3) ; make sure, memoization has been performed | |
653 | (equal? (procedure-source foo) | |
654 | '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) | |
655 | ||
656 | (pass-if "empty labels" | |
657 | (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) | |
658 | (foo 1) ; make sure, memoization has been performed | |
659 | (foo 2) ; make sure, memoization has been performed | |
660 | (foo 3) ; make sure, memoization has been performed | |
661 | (equal? (procedure-source foo) | |
662 | '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) | |
663 | ||
27a22666 DH |
664 | (with-test-prefix "bad or missing clauses" |
665 | ||
666 | (pass-if-exception "(case)" | |
2a6f7afe | 667 | exception:missing-clauses |
d6e04e7c DH |
668 | (eval '(case) |
669 | (interaction-environment))) | |
27a22666 | 670 | |
27a22666 | 671 | (pass-if-exception "(case . \"foo\")" |
2a6f7afe | 672 | exception:bad-expression |
d6e04e7c DH |
673 | (eval '(case . "foo") |
674 | (interaction-environment))) | |
27a22666 DH |
675 | |
676 | (pass-if-exception "(case 1)" | |
2a6f7afe | 677 | exception:missing-clauses |
d6e04e7c DH |
678 | (eval '(case 1) |
679 | (interaction-environment))) | |
27a22666 | 680 | |
27a22666 | 681 | (pass-if-exception "(case 1 . \"foo\")" |
2a6f7afe | 682 | exception:bad-expression |
d6e04e7c DH |
683 | (eval '(case 1 . "foo") |
684 | (interaction-environment))) | |
27a22666 DH |
685 | |
686 | (pass-if-exception "(case 1 \"foo\")" | |
2a6f7afe | 687 | exception:bad-case-clause |
d6e04e7c DH |
688 | (eval '(case 1 "foo") |
689 | (interaction-environment))) | |
27a22666 DH |
690 | |
691 | (pass-if-exception "(case 1 ())" | |
2a6f7afe | 692 | exception:bad-case-clause |
d6e04e7c DH |
693 | (eval '(case 1 ()) |
694 | (interaction-environment))) | |
27a22666 DH |
695 | |
696 | (pass-if-exception "(case 1 (\"foo\"))" | |
2a6f7afe | 697 | exception:bad-case-clause |
d6e04e7c DH |
698 | (eval '(case 1 ("foo")) |
699 | (interaction-environment))) | |
27a22666 DH |
700 | |
701 | (pass-if-exception "(case 1 (\"foo\" \"bar\"))" | |
2a6f7afe | 702 | exception:bad-case-labels |
d6e04e7c DH |
703 | (eval '(case 1 ("foo" "bar")) |
704 | (interaction-environment))) | |
27a22666 | 705 | |
27a22666 | 706 | (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" |
2a6f7afe | 707 | exception:bad-expression |
d6e04e7c DH |
708 | (eval '(case 1 ((2) "bar") . "foo") |
709 | (interaction-environment))) | |
27a22666 | 710 | |
d6e04e7c | 711 | (pass-if-exception "(case 1 ((2) \"bar\") (else))" |
2a6f7afe | 712 | exception:bad-case-clause |
d6e04e7c DH |
713 | (eval '(case 1 ((2) "bar") (else)) |
714 | (interaction-environment))) | |
27a22666 | 715 | |
27a22666 | 716 | (pass-if-exception "(case 1 (else #f) . \"foo\")" |
2a6f7afe | 717 | exception:bad-expression |
d6e04e7c DH |
718 | (eval '(case 1 (else #f) . "foo") |
719 | (interaction-environment))) | |
27a22666 DH |
720 | |
721 | (pass-if-exception "(case 1 (else #f) ((1) #t))" | |
609a8b86 | 722 | exception:misplaced-else-clause |
d6e04e7c DH |
723 | (eval '(case 1 (else #f) ((1) #t)) |
724 | (interaction-environment))))) | |
27a22666 | 725 | |
ced8edb0 | 726 | (with-test-prefix "top-level define" |
08c608e1 | 727 | |
36245b66 DH |
728 | (pass-if "binding is created before expression is evaluated" |
729 | (= (eval '(begin | |
730 | (define foo | |
731 | (begin | |
732 | (set! foo 1) | |
733 | (+ foo 1))) | |
734 | foo) | |
735 | (interaction-environment)) | |
736 | 2)) | |
737 | ||
7171f1ab DH |
738 | (with-test-prefix "currying" |
739 | ||
740 | (pass-if "(define ((foo)) #f)" | |
ced8edb0 DH |
741 | (eval '(begin |
742 | (define ((foo)) #t) | |
743 | ((foo))) | |
744 | (interaction-environment)))) | |
7171f1ab | 745 | |
08c608e1 DH |
746 | (with-test-prefix "missing or extra expressions" |
747 | ||
748 | (pass-if-exception "(define)" | |
cc56ba80 | 749 | exception:missing-expr |
d6e04e7c DH |
750 | (eval '(define) |
751 | (interaction-environment))))) | |
08c608e1 | 752 | |
ced8edb0 DH |
753 | (with-test-prefix "internal define" |
754 | ||
755 | (pass-if "internal defines become letrec" | |
756 | (eval '(let ((a identity) (b identity) (c identity)) | |
757 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
758 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
759 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
760 | (and (eq? 'a (a 0) (a 3)) | |
761 | (eq? 'b (a 1) (a 4)) | |
762 | (eq? 'c (a 2) (a 5)))) | |
763 | (interaction-environment))) | |
764 | ||
c86c440b | 765 | (pass-if "internal defines with begin" |
ced8edb0 DH |
766 | (false-if-exception |
767 | (eval '(let ((a identity) (b identity) (c identity)) | |
768 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
769 | (begin | |
770 | (define (b x) (if (= x 0) 'b (c (- x 1))))) | |
771 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
772 | (and (eq? 'a (a 0) (a 3)) | |
773 | (eq? 'b (a 1) (a 4)) | |
774 | (eq? 'c (a 2) (a 5)))) | |
775 | (interaction-environment)))) | |
776 | ||
c86c440b | 777 | (pass-if "internal defines with empty begin" |
ced8edb0 DH |
778 | (false-if-exception |
779 | (eval '(let ((a identity) (b identity) (c identity)) | |
780 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
781 | (begin) | |
782 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
783 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
784 | (and (eq? 'a (a 0) (a 3)) | |
785 | (eq? 'b (a 1) (a 4)) | |
786 | (eq? 'c (a 2) (a 5)))) | |
787 | (interaction-environment)))) | |
788 | ||
c3d94801 | 789 | (pass-if "internal defines with macro application" |
560434b3 DH |
790 | (false-if-exception |
791 | (eval '(begin | |
c3d94801 | 792 | (defmacro my-define forms |
560434b3 | 793 | (cons 'define forms)) |
c3d94801 DH |
794 | (let ((a identity) (b identity) (c identity)) |
795 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
796 | (my-define (b x) (if (= x 0) 'b (c (- x 1)))) | |
797 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
798 | (and (eq? 'a (a 0) (a 3)) | |
799 | (eq? 'b (a 1) (a 4)) | |
800 | (eq? 'c (a 2) (a 5))))) | |
560434b3 DH |
801 | (interaction-environment)))) |
802 | ||
ced8edb0 DH |
803 | (pass-if-exception "missing body expression" |
804 | exception:missing-body-expr | |
805 | (eval '(let () (define x #t)) | |
a264c013 DH |
806 | (interaction-environment))) |
807 | ||
808 | (pass-if "unmemoization" | |
809 | (eval '(begin | |
810 | (define (foo) | |
811 | (define (bar) | |
812 | 'ok) | |
813 | (bar)) | |
814 | (foo) | |
815 | (equal? | |
816 | (procedure-source foo) | |
817 | '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) | |
ced8edb0 DH |
818 | (interaction-environment)))) |
819 | ||
aa498d0c DH |
820 | (with-test-prefix "do" |
821 | ||
822 | (with-test-prefix "unmemoization" | |
823 | ||
824 | (pass-if "normal case" | |
825 | (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) | |
826 | ((> i 9) (+ i j)) | |
827 | (identity i))))) | |
828 | (foo) ; make sure, memoization has been performed | |
829 | (equal? (procedure-source foo) | |
830 | '(lambda () (do ((i 1 (+ i 1)) (j 2)) | |
831 | ((> i 9) (+ i j)) | |
832 | (identity i)))))) | |
833 | ||
834 | (pass-if "reduced case" | |
835 | (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j | |
836 | ((> i 9) (+ i j)) | |
837 | (identity i))))) | |
838 | (foo) ; make sure, memoization has been performed | |
839 | (equal? (procedure-source foo) | |
840 | '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here | |
841 | ((> i 9) (+ i j)) | |
842 | (identity i)))))))) | |
843 | ||
08c608e1 DH |
844 | (with-test-prefix "set!" |
845 | ||
aa498d0c DH |
846 | (with-test-prefix "unmemoization" |
847 | ||
848 | (pass-if "normal set!" | |
849 | (let ((foo (lambda (x) (set! x (+ 1 x))))) | |
850 | (foo 1) ; make sure, memoization has been performed | |
851 | (equal? (procedure-source foo) | |
852 | '(lambda (x) (set! x (+ 1 x))))))) | |
853 | ||
08c608e1 DH |
854 | (with-test-prefix "missing or extra expressions" |
855 | ||
856 | (pass-if-exception "(set!)" | |
da48db62 | 857 | exception:missing/extra-expr |
4dce3c96 DH |
858 | (eval '(set!) |
859 | (interaction-environment))) | |
08c608e1 DH |
860 | |
861 | (pass-if-exception "(set! 1)" | |
da48db62 | 862 | exception:missing/extra-expr |
4dce3c96 DH |
863 | (eval '(set! 1) |
864 | (interaction-environment))) | |
08c608e1 DH |
865 | |
866 | (pass-if-exception "(set! 1 2 3)" | |
da48db62 | 867 | exception:missing/extra-expr |
4dce3c96 DH |
868 | (eval '(set! 1 2 3) |
869 | (interaction-environment)))) | |
08c608e1 DH |
870 | |
871 | (with-test-prefix "bad variable" | |
872 | ||
873 | (pass-if-exception "(set! \"\" #t)" | |
da48db62 | 874 | exception:bad-variable |
4dce3c96 DH |
875 | (eval '(set! "" #t) |
876 | (interaction-environment))) | |
08c608e1 DH |
877 | |
878 | (pass-if-exception "(set! 1 #t)" | |
da48db62 | 879 | exception:bad-variable |
4dce3c96 DH |
880 | (eval '(set! 1 #t) |
881 | (interaction-environment))) | |
08c608e1 DH |
882 | |
883 | (pass-if-exception "(set! #t #f)" | |
da48db62 | 884 | exception:bad-variable |
4dce3c96 DH |
885 | (eval '(set! #t #f) |
886 | (interaction-environment))) | |
08c608e1 DH |
887 | |
888 | (pass-if-exception "(set! #f #t)" | |
da48db62 | 889 | exception:bad-variable |
4dce3c96 DH |
890 | (eval '(set! #f #t) |
891 | (interaction-environment))) | |
08c608e1 | 892 | |
96dfea7d | 893 | (pass-if-exception "(set! #\\space #f)" |
da48db62 | 894 | exception:bad-variable |
4dce3c96 DH |
895 | (eval '(set! #\space #f) |
896 | (interaction-environment))))) | |
08c608e1 | 897 | |
08c608e1 DH |
898 | (with-test-prefix "quote" |
899 | ||
900 | (with-test-prefix "missing or extra expression" | |
901 | ||
902 | (pass-if-exception "(quote)" | |
903 | exception:missing/extra-expr | |
4dce3c96 DH |
904 | (eval '(quote) |
905 | (interaction-environment))) | |
08c608e1 DH |
906 | |
907 | (pass-if-exception "(quote a b)" | |
908 | exception:missing/extra-expr | |
4dce3c96 DH |
909 | (eval '(quote a b) |
910 | (interaction-environment))))) | |
2798ba71 KR |
911 | |
912 | (with-test-prefix "while" | |
913 | ||
914 | (define (unreachable) | |
915 | (error "unreachable code has been reached!")) | |
916 | ||
2798ba71 KR |
917 | ;; Return a new procedure COND which when called (COND) will return #t the |
918 | ;; first N times, then #f, then any further call is an error. N=0 is | |
919 | ;; allowed, in which case #f is returned by the first call. | |
920 | (define (make-iterations-cond n) | |
921 | (lambda () | |
922 | (cond ((not n) | |
923 | (error "oops, condition re-tested after giving false")) | |
924 | ((= 0 n) | |
925 | (set! n #f) | |
926 | #f) | |
927 | (else | |
928 | (set! n (1- n)) | |
929 | #t)))) | |
930 | ||
931 | ||
932 | (pass-if-exception "too few args" exception:wrong-num-args | |
d6e04e7c | 933 | (eval '(while) (interaction-environment))) |
2798ba71 KR |
934 | |
935 | (with-test-prefix "empty body" | |
936 | (do ((n 0 (1+ n))) | |
937 | ((> n 5)) | |
938 | (pass-if n | |
939 | (let ((cond (make-iterations-cond n))) | |
940 | (while (cond))) | |
941 | #t))) | |
942 | ||
943 | (pass-if "initially false" | |
944 | (while #f | |
945 | (unreachable)) | |
946 | #t) | |
947 | ||
948 | (with-test-prefix "in empty environment" | |
d6e04e7c DH |
949 | |
950 | ;; an environment with no bindings at all | |
951 | (define empty-environment | |
952 | (make-module 1)) | |
953 | ||
2798ba71 KR |
954 | (pass-if "empty body" |
955 | (eval `(,while #f) | |
956 | empty-environment) | |
957 | #t) | |
958 | ||
959 | (pass-if "initially false" | |
960 | (eval `(,while #f | |
961 | #f) | |
962 | empty-environment) | |
963 | #t) | |
964 | ||
965 | (pass-if "iterating" | |
966 | (let ((cond (make-iterations-cond 3))) | |
967 | (eval `(,while (,cond) | |
968 | 123 456) | |
969 | empty-environment)) | |
970 | #t)) | |
971 | ||
972 | (with-test-prefix "iterations" | |
973 | (do ((n 0 (1+ n))) | |
974 | ((> n 5)) | |
975 | (pass-if n | |
976 | (let ((cond (make-iterations-cond n)) | |
977 | (i 0)) | |
978 | (while (cond) | |
979 | (set! i (1+ i))) | |
980 | (= i n))))) | |
981 | ||
982 | (with-test-prefix "break" | |
983 | ||
984 | (pass-if-exception "too many args" exception:wrong-num-args | |
985 | (while #t | |
986 | (break 1))) | |
987 | ||
988 | (with-test-prefix "from cond" | |
989 | (pass-if "first" | |
990 | (while (begin | |
991 | (break) | |
992 | (unreachable)) | |
993 | (unreachable)) | |
994 | #t) | |
995 | ||
996 | (do ((n 0 (1+ n))) | |
997 | ((> n 5)) | |
998 | (pass-if n | |
999 | (let ((cond (make-iterations-cond n)) | |
1000 | (i 0)) | |
1001 | (while (if (cond) | |
1002 | #t | |
1003 | (begin | |
1004 | (break) | |
1005 | (unreachable))) | |
1006 | (set! i (1+ i))) | |
1007 | (= i n))))) | |
1008 | ||
1009 | (with-test-prefix "from body" | |
1010 | (pass-if "first" | |
1011 | (while #t | |
1012 | (break) | |
1013 | (unreachable)) | |
1014 | #t) | |
1015 | ||
1016 | (do ((n 0 (1+ n))) | |
1017 | ((> n 5)) | |
1018 | (pass-if n | |
1019 | (let ((cond (make-iterations-cond n)) | |
1020 | (i 0)) | |
1021 | (while #t | |
1022 | (if (not (cond)) | |
1023 | (begin | |
1024 | (break) | |
1025 | (unreachable))) | |
1026 | (set! i (1+ i))) | |
1027 | (= i n))))) | |
1028 | ||
1029 | (pass-if "from nested" | |
1030 | (while #t | |
1031 | (let ((outer-break break)) | |
1032 | (while #t | |
1033 | (outer-break) | |
1034 | (unreachable))) | |
1035 | (unreachable)) | |
cc08aafd KR |
1036 | #t) |
1037 | ||
1038 | (pass-if "from recursive" | |
1039 | (let ((outer-break #f)) | |
1040 | (define (r n) | |
1041 | (while #t | |
1042 | (if (eq? n 'outer) | |
1043 | (begin | |
1044 | (set! outer-break break) | |
1045 | (r 'inner)) | |
1046 | (begin | |
1047 | (outer-break) | |
1048 | (unreachable)))) | |
1049 | (if (eq? n 'inner) | |
1050 | (error "broke only from inner loop"))) | |
1051 | (r 'outer)) | |
2798ba71 KR |
1052 | #t)) |
1053 | ||
1054 | (with-test-prefix "continue" | |
1055 | ||
1056 | (pass-if-exception "too many args" exception:wrong-num-args | |
1057 | (while #t | |
1058 | (continue 1))) | |
1059 | ||
1060 | (with-test-prefix "from cond" | |
1061 | (do ((n 0 (1+ n))) | |
1062 | ((> n 5)) | |
1063 | (pass-if n | |
1064 | (let ((cond (make-iterations-cond n)) | |
1065 | (i 0)) | |
1066 | (while (if (cond) | |
1067 | (begin | |
1068 | (set! i (1+ i)) | |
1069 | (continue) | |
1070 | (unreachable)) | |
1071 | #f) | |
1072 | (unreachable)) | |
1073 | (= i n))))) | |
1074 | ||
1075 | (with-test-prefix "from body" | |
1076 | (do ((n 0 (1+ n))) | |
1077 | ((> n 5)) | |
1078 | (pass-if n | |
1079 | (let ((cond (make-iterations-cond n)) | |
1080 | (i 0)) | |
1081 | (while (cond) | |
1082 | (set! i (1+ i)) | |
1083 | (continue) | |
1084 | (unreachable)) | |
1085 | (= i n))))) | |
1086 | ||
1087 | (pass-if "from nested" | |
1088 | (let ((cond (make-iterations-cond 3))) | |
1089 | (while (cond) | |
1090 | (let ((outer-continue continue)) | |
1091 | (while #t | |
1092 | (outer-continue) | |
1093 | (unreachable))))) | |
cc08aafd KR |
1094 | #t) |
1095 | ||
1096 | (pass-if "from recursive" | |
1097 | (let ((outer-continue #f)) | |
1098 | (define (r n) | |
1099 | (let ((cond (make-iterations-cond 3)) | |
1100 | (first #t)) | |
1101 | (while (begin | |
1102 | (if (and (not first) | |
1103 | (eq? n 'inner)) | |
1104 | (error "continued only to inner loop")) | |
1105 | (cond)) | |
1106 | (set! first #f) | |
1107 | (if (eq? n 'outer) | |
1108 | (begin | |
1109 | (set! outer-continue continue) | |
1110 | (r 'inner)) | |
1111 | (begin | |
1112 | (outer-continue) | |
1113 | (unreachable)))))) | |
1114 | (r 'outer)) | |
2798ba71 | 1115 | #t))) |