Commit | Line | Data |
---|---|---|
08c608e1 DH |
1 | ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- |
2 | ;;;; | |
9f977dd8 | 3 | ;;;; Copyright (C) 2001, 2003 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 DH |
26 | |
27 | (define exception:missing/extra-expr | |
28 | (cons 'misc-error "^missing or extra expression")) | |
29 | (define exception:missing-expr | |
30 | (cons 'syntax-error "Missing expression")) | |
31 | (define exception:extra-expr | |
32 | (cons 'syntax-error "Extra expression")) | |
33 | ||
08c608e1 DH |
34 | (define exception:bad-bindings |
35 | (cons 'misc-error "^bad bindings")) | |
c0ed1605 MV |
36 | (define exception:duplicate-bindings |
37 | (cons 'misc-error "^duplicate bindings")) | |
08c608e1 DH |
38 | (define exception:bad-body |
39 | (cons 'misc-error "^bad body")) | |
40 | (define exception:bad-formals | |
41 | (cons 'misc-error "^bad formals")) | |
1c54a87c MV |
42 | (define exception:duplicate-formals |
43 | (cons 'misc-error "^duplicate formals")) | |
cc56ba80 | 44 | |
2a6f7afe DH |
45 | (define exception:missing-clauses |
46 | (cons 'syntax-error "Missing clauses")) | |
609a8b86 DH |
47 | (define exception:misplaced-else-clause |
48 | (cons 'syntax-error "Misplaced else clause")) | |
2a6f7afe DH |
49 | (define exception:bad-case-clause |
50 | (cons 'syntax-error "Bad case clause")) | |
2a6f7afe DH |
51 | (define exception:bad-case-labels |
52 | (cons 'syntax-error "Bad case labels")) | |
609a8b86 DH |
53 | (define exception:bad-cond-clause |
54 | (cons 'syntax-error "Bad cond clause")) | |
cc56ba80 | 55 | |
609a8b86 DH |
56 | (define exception:bad-var |
57 | (cons 'misc-error "^bad variable")) | |
08c608e1 DH |
58 | |
59 | ||
60 | (with-test-prefix "expressions" | |
61 | ||
d6e04e7c DH |
62 | (with-test-prefix "Bad argument list" |
63 | ||
64 | (pass-if-exception "improper argument list of length 1" | |
65 | exception:wrong-num-args | |
66 | (eval '(let ((foo (lambda (x y) #t))) | |
67 | (foo . 1)) | |
68 | (interaction-environment))) | |
69 | ||
70 | (pass-if-exception "improper argument list of length 2" | |
71 | exception:wrong-num-args | |
72 | (eval '(let ((foo (lambda (x y) #t))) | |
73 | (foo 1 . 2)) | |
74 | (interaction-environment)))) | |
75 | ||
08c608e1 DH |
76 | (with-test-prefix "missing or extra expression" |
77 | ||
78 | ;; R5RS says: | |
79 | ;; *Note:* In many dialects of Lisp, the empty combination, (), | |
80 | ;; is a legitimate expression. In Scheme, combinations must | |
81 | ;; have at least one subexpression, so () is not a syntactically | |
82 | ;; valid expression. | |
1c54a87c MV |
83 | |
84 | ;; Fixed on 2001-3-3 | |
85 | (pass-if-exception "empty parentheses \"()\"" | |
08c608e1 | 86 | exception:missing/extra-expr |
d6e04e7c DH |
87 | (eval '() |
88 | (interaction-environment))))) | |
08c608e1 | 89 | |
7171f1ab DH |
90 | (with-test-prefix "quote" |
91 | #t) | |
92 | ||
93 | (with-test-prefix "quasiquote" | |
94 | ||
95 | (with-test-prefix "unquote" | |
96 | ||
97 | (pass-if "repeated execution" | |
98 | (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i))))) | |
99 | (and (equal? (foo) '(1)) (equal? (foo) '(2)))))) | |
100 | ||
101 | (with-test-prefix "unquote-splicing" | |
102 | ||
103 | (pass-if-exception "extra arguments" | |
104 | exception:missing/extra-expr | |
105 | (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) | |
106 | ||
107 | (with-test-prefix "begin" | |
108 | ||
109 | (pass-if "legal (begin)" | |
110 | (begin) | |
111 | #t) | |
112 | ||
113 | (expect-fail-exception "illegal (begin)" | |
114 | exception:bad-body | |
115 | (if #t (begin)) | |
116 | #t)) | |
117 | ||
08c608e1 DH |
118 | (with-test-prefix "lambda" |
119 | ||
120 | (with-test-prefix "bad formals" | |
121 | ||
ea6c2147 DH |
122 | (pass-if-exception "(lambda)" |
123 | exception:bad-formals | |
d6e04e7c DH |
124 | (eval '(lambda) |
125 | (interaction-environment))) | |
ea6c2147 DH |
126 | |
127 | (pass-if-exception "(lambda . \"foo\")" | |
128 | exception:bad-formals | |
d6e04e7c DH |
129 | (eval '(lambda . "foo") |
130 | (interaction-environment))) | |
ea6c2147 | 131 | |
ea6c2147 DH |
132 | (pass-if-exception "(lambda \"foo\")" |
133 | exception:bad-formals | |
d6e04e7c DH |
134 | (eval '(lambda "foo") |
135 | (interaction-environment))) | |
ea6c2147 DH |
136 | |
137 | (pass-if-exception "(lambda \"foo\" #f)" | |
138 | exception:bad-formals | |
4dce3c96 DH |
139 | (eval '(lambda "foo" #f) |
140 | (interaction-environment))) | |
ea6c2147 DH |
141 | |
142 | (pass-if-exception "(lambda (x 1) 2)" | |
08c608e1 | 143 | exception:bad-formals |
d6e04e7c DH |
144 | (eval '(lambda (x 1) 2) |
145 | (interaction-environment))) | |
08c608e1 DH |
146 | |
147 | (pass-if-exception "(lambda (1 x) 2)" | |
148 | exception:bad-formals | |
d6e04e7c DH |
149 | (eval '(lambda (1 x) 2) |
150 | (interaction-environment))) | |
08c608e1 DH |
151 | |
152 | (pass-if-exception "(lambda (x \"a\") 2)" | |
153 | exception:bad-formals | |
d6e04e7c DH |
154 | (eval '(lambda (x "a") 2) |
155 | (interaction-environment))) | |
08c608e1 DH |
156 | |
157 | (pass-if-exception "(lambda (\"a\" x) 2)" | |
158 | exception:bad-formals | |
d6e04e7c DH |
159 | (eval '(lambda ("a" x) 2) |
160 | (interaction-environment)))) | |
08c608e1 | 161 | |
1c54a87c MV |
162 | (with-test-prefix "duplicate formals" |
163 | ||
164 | ;; Fixed on 2001-3-3 | |
165 | (pass-if-exception "(lambda (x x) 1)" | |
166 | exception:duplicate-formals | |
d6e04e7c DH |
167 | (eval '(lambda (x x) 1) |
168 | (interaction-environment))) | |
08c608e1 | 169 | |
1c54a87c MV |
170 | ;; Fixed on 2001-3-3 |
171 | (pass-if-exception "(lambda (x x x) 1)" | |
172 | exception:duplicate-formals | |
d6e04e7c DH |
173 | (eval '(lambda (x x x) 1) |
174 | (interaction-environment)))) | |
7171f1ab DH |
175 | |
176 | (with-test-prefix "bad body" | |
177 | ||
178 | (pass-if-exception "(lambda ())" | |
179 | exception:bad-body | |
d6e04e7c DH |
180 | (eval '(lambda ()) |
181 | (interaction-environment))))) | |
08c608e1 DH |
182 | |
183 | (with-test-prefix "let" | |
184 | ||
185 | (with-test-prefix "bindings" | |
186 | ||
187 | (pass-if-exception "late binding" | |
188 | exception:unbound-var | |
189 | (let ((x 1) (y x)) y))) | |
190 | ||
7171f1ab | 191 | (with-test-prefix "bad bindings" |
08c608e1 | 192 | |
08c608e1 | 193 | (pass-if-exception "(let)" |
7171f1ab | 194 | exception:bad-bindings |
d6e04e7c DH |
195 | (eval '(let) |
196 | (interaction-environment))) | |
08c608e1 | 197 | |
08c608e1 | 198 | (pass-if-exception "(let 1)" |
7171f1ab | 199 | exception:bad-bindings |
d6e04e7c DH |
200 | (eval '(let 1) |
201 | (interaction-environment))) | |
08c608e1 | 202 | |
08c608e1 | 203 | (pass-if-exception "(let (x))" |
7171f1ab | 204 | exception:bad-bindings |
d6e04e7c DH |
205 | (eval '(let (x)) |
206 | (interaction-environment))) | |
08c608e1 | 207 | |
7171f1ab DH |
208 | ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? |
209 | ;; (Even although the body is bad as well...) | |
210 | (pass-if-exception "(let ((x)))" | |
211 | exception:bad-body | |
d6e04e7c DH |
212 | (eval '(let ((x))) |
213 | (interaction-environment))) | |
08c608e1 DH |
214 | |
215 | (pass-if-exception "(let (x) 1)" | |
216 | exception:bad-bindings | |
d6e04e7c DH |
217 | (eval '(let (x) 1) |
218 | (interaction-environment))) | |
08c608e1 DH |
219 | |
220 | (pass-if-exception "(let ((x)) 3)" | |
221 | exception:bad-bindings | |
d6e04e7c DH |
222 | (eval '(let ((x)) 3) |
223 | (interaction-environment))) | |
08c608e1 DH |
224 | |
225 | (pass-if-exception "(let ((x 1) y) x)" | |
226 | exception:bad-bindings | |
d6e04e7c DH |
227 | (eval '(let ((x 1) y) x) |
228 | (interaction-environment))) | |
08c608e1 DH |
229 | |
230 | (pass-if-exception "(let ((1 2)) 3)" | |
231 | exception:bad-var | |
4dce3c96 DH |
232 | (eval '(let ((1 2)) 3) |
233 | (interaction-environment)))) | |
08c608e1 | 234 | |
c0ed1605 MV |
235 | (with-test-prefix "duplicate bindings" |
236 | ||
237 | (pass-if-exception "(let ((x 1) (x 2)) x)" | |
238 | exception:duplicate-bindings | |
d6e04e7c DH |
239 | (eval '(let ((x 1) (x 2)) x) |
240 | (interaction-environment)))) | |
7171f1ab DH |
241 | |
242 | (with-test-prefix "bad body" | |
243 | ||
244 | (pass-if-exception "(let ())" | |
245 | exception:bad-body | |
d6e04e7c DH |
246 | (eval '(let ()) |
247 | (interaction-environment))) | |
7171f1ab DH |
248 | |
249 | (pass-if-exception "(let ((x 1)))" | |
250 | exception:bad-body | |
d6e04e7c DH |
251 | (eval '(let ((x 1))) |
252 | (interaction-environment))))) | |
08c608e1 DH |
253 | |
254 | (with-test-prefix "named let" | |
255 | ||
7171f1ab DH |
256 | (with-test-prefix "initializers" |
257 | ||
258 | (pass-if "evaluated in outer environment" | |
259 | (let ((f -)) | |
260 | (eqv? (let f ((n (f 1))) n) -1)))) | |
261 | ||
262 | (with-test-prefix "bad bindings" | |
263 | ||
264 | (pass-if-exception "(let x (y))" | |
265 | exception:bad-bindings | |
d6e04e7c DH |
266 | (eval '(let x (y)) |
267 | (interaction-environment)))) | |
7171f1ab | 268 | |
08c608e1 DH |
269 | (with-test-prefix "bad body" |
270 | ||
271 | (pass-if-exception "(let x ())" | |
272 | exception:bad-body | |
d6e04e7c DH |
273 | (eval '(let x ()) |
274 | (interaction-environment))) | |
08c608e1 DH |
275 | |
276 | (pass-if-exception "(let x ((y 1)))" | |
277 | exception:bad-body | |
d6e04e7c DH |
278 | (eval '(let x ((y 1))) |
279 | (interaction-environment))))) | |
08c608e1 DH |
280 | |
281 | (with-test-prefix "let*" | |
282 | ||
e1a7b2ce DH |
283 | (with-test-prefix "bindings" |
284 | ||
285 | (pass-if "(let* ((x 1) (x 2)) ...)" | |
286 | (let* ((x 1) (x 2)) | |
287 | (= x 2))) | |
288 | ||
289 | (pass-if "(let* ((x 1) (x x)) ...)" | |
290 | (let* ((x 1) (x x)) | |
291 | (= x 1)))) | |
292 | ||
7171f1ab | 293 | (with-test-prefix "bad bindings" |
08c608e1 | 294 | |
08c608e1 | 295 | (pass-if-exception "(let*)" |
7171f1ab | 296 | exception:bad-bindings |
d6e04e7c DH |
297 | (eval '(let*) |
298 | (interaction-environment))) | |
08c608e1 | 299 | |
08c608e1 | 300 | (pass-if-exception "(let* 1)" |
7171f1ab | 301 | exception:bad-bindings |
d6e04e7c DH |
302 | (eval '(let* 1) |
303 | (interaction-environment))) | |
08c608e1 | 304 | |
08c608e1 | 305 | (pass-if-exception "(let* (x))" |
7171f1ab | 306 | exception:bad-bindings |
d6e04e7c DH |
307 | (eval '(let* (x)) |
308 | (interaction-environment))) | |
08c608e1 DH |
309 | |
310 | (pass-if-exception "(let* (x) 1)" | |
311 | exception:bad-bindings | |
d6e04e7c DH |
312 | (eval '(let* (x) 1) |
313 | (interaction-environment))) | |
08c608e1 DH |
314 | |
315 | (pass-if-exception "(let* ((x)) 3)" | |
316 | exception:bad-bindings | |
d6e04e7c DH |
317 | (eval '(let* ((x)) 3) |
318 | (interaction-environment))) | |
08c608e1 DH |
319 | |
320 | (pass-if-exception "(let* ((x 1) y) x)" | |
321 | exception:bad-bindings | |
d6e04e7c DH |
322 | (eval '(let* ((x 1) y) x) |
323 | (interaction-environment))) | |
08c608e1 DH |
324 | |
325 | (pass-if-exception "(let* x ())" | |
326 | exception:bad-bindings | |
4dce3c96 DH |
327 | (eval '(let* x ()) |
328 | (interaction-environment))) | |
08c608e1 DH |
329 | |
330 | (pass-if-exception "(let* x (y))" | |
331 | exception:bad-bindings | |
4dce3c96 DH |
332 | (eval '(let* x (y)) |
333 | (interaction-environment))) | |
08c608e1 DH |
334 | |
335 | (pass-if-exception "(let* ((1 2)) 3)" | |
336 | exception:bad-var | |
4dce3c96 DH |
337 | (eval '(let* ((1 2)) 3) |
338 | (interaction-environment)))) | |
7171f1ab DH |
339 | |
340 | (with-test-prefix "bad body" | |
341 | ||
342 | (pass-if-exception "(let* ())" | |
343 | exception:bad-body | |
d6e04e7c DH |
344 | (eval '(let* ()) |
345 | (interaction-environment))) | |
7171f1ab DH |
346 | |
347 | (pass-if-exception "(let* ((x 1)))" | |
348 | exception:bad-body | |
d6e04e7c DH |
349 | (eval '(let* ((x 1))) |
350 | (interaction-environment))))) | |
08c608e1 DH |
351 | |
352 | (with-test-prefix "letrec" | |
353 | ||
354 | (with-test-prefix "bindings" | |
355 | ||
356 | (pass-if-exception "initial bindings are undefined" | |
357 | exception:unbound-var | |
358 | (let ((x 1)) | |
359 | (letrec ((x 1) (y x)) y)))) | |
360 | ||
7171f1ab | 361 | (with-test-prefix "bad bindings" |
08c608e1 | 362 | |
08c608e1 | 363 | (pass-if-exception "(letrec)" |
7171f1ab | 364 | exception:bad-bindings |
d6e04e7c DH |
365 | (eval '(letrec) |
366 | (interaction-environment))) | |
08c608e1 | 367 | |
08c608e1 | 368 | (pass-if-exception "(letrec 1)" |
7171f1ab | 369 | exception:bad-bindings |
d6e04e7c DH |
370 | (eval '(letrec 1) |
371 | (interaction-environment))) | |
08c608e1 | 372 | |
08c608e1 | 373 | (pass-if-exception "(letrec (x))" |
7171f1ab | 374 | exception:bad-bindings |
d6e04e7c DH |
375 | (eval '(letrec (x)) |
376 | (interaction-environment))) | |
08c608e1 DH |
377 | |
378 | (pass-if-exception "(letrec (x) 1)" | |
379 | exception:bad-bindings | |
d6e04e7c DH |
380 | (eval '(letrec (x) 1) |
381 | (interaction-environment))) | |
08c608e1 DH |
382 | |
383 | (pass-if-exception "(letrec ((x)) 3)" | |
384 | exception:bad-bindings | |
d6e04e7c DH |
385 | (eval '(letrec ((x)) 3) |
386 | (interaction-environment))) | |
08c608e1 DH |
387 | |
388 | (pass-if-exception "(letrec ((x 1) y) x)" | |
389 | exception:bad-bindings | |
d6e04e7c DH |
390 | (eval '(letrec ((x 1) y) x) |
391 | (interaction-environment))) | |
08c608e1 DH |
392 | |
393 | (pass-if-exception "(letrec x ())" | |
394 | exception:bad-bindings | |
4dce3c96 DH |
395 | (eval '(letrec x ()) |
396 | (interaction-environment))) | |
08c608e1 DH |
397 | |
398 | (pass-if-exception "(letrec x (y))" | |
399 | exception:bad-bindings | |
4dce3c96 DH |
400 | (eval '(letrec x (y)) |
401 | (interaction-environment))) | |
08c608e1 DH |
402 | |
403 | (pass-if-exception "(letrec ((1 2)) 3)" | |
404 | exception:bad-var | |
4dce3c96 DH |
405 | (eval '(letrec ((1 2)) 3) |
406 | (interaction-environment)))) | |
08c608e1 | 407 | |
c0ed1605 MV |
408 | (with-test-prefix "duplicate bindings" |
409 | ||
410 | (pass-if-exception "(letrec ((x 1) (x 2)) x)" | |
411 | exception:duplicate-bindings | |
d6e04e7c DH |
412 | (eval '(letrec ((x 1) (x 2)) x) |
413 | (interaction-environment)))) | |
7171f1ab DH |
414 | |
415 | (with-test-prefix "bad body" | |
416 | ||
417 | (pass-if-exception "(letrec ())" | |
418 | exception:bad-body | |
d6e04e7c DH |
419 | (eval '(letrec ()) |
420 | (interaction-environment))) | |
7171f1ab DH |
421 | |
422 | (pass-if-exception "(letrec ((x 1)))" | |
423 | exception:bad-body | |
d6e04e7c DH |
424 | (eval '(letrec ((x 1))) |
425 | (interaction-environment))))) | |
08c608e1 DH |
426 | |
427 | (with-test-prefix "if" | |
428 | ||
429 | (with-test-prefix "missing or extra expressions" | |
430 | ||
431 | (pass-if-exception "(if)" | |
432 | exception:missing/extra-expr | |
4dce3c96 DH |
433 | (eval '(if) |
434 | (interaction-environment))) | |
08c608e1 DH |
435 | |
436 | (pass-if-exception "(if 1 2 3 4)" | |
437 | exception:missing/extra-expr | |
4dce3c96 DH |
438 | (eval '(if 1 2 3 4) |
439 | (interaction-environment))))) | |
08c608e1 DH |
440 | |
441 | (with-test-prefix "cond" | |
442 | ||
443 | (with-test-prefix "bad or missing clauses" | |
444 | ||
445 | (pass-if-exception "(cond)" | |
609a8b86 | 446 | exception:missing-clauses |
d6e04e7c DH |
447 | (eval '(cond) |
448 | (interaction-environment))) | |
08c608e1 DH |
449 | |
450 | (pass-if-exception "(cond #t)" | |
609a8b86 | 451 | exception:bad-cond-clause |
d6e04e7c DH |
452 | (eval '(cond #t) |
453 | (interaction-environment))) | |
08c608e1 DH |
454 | |
455 | (pass-if-exception "(cond 1)" | |
609a8b86 | 456 | exception:bad-cond-clause |
d6e04e7c DH |
457 | (eval '(cond 1) |
458 | (interaction-environment))) | |
08c608e1 DH |
459 | |
460 | (pass-if-exception "(cond 1 2)" | |
609a8b86 | 461 | exception:bad-cond-clause |
d6e04e7c DH |
462 | (eval '(cond 1 2) |
463 | (interaction-environment))) | |
08c608e1 DH |
464 | |
465 | (pass-if-exception "(cond 1 2 3)" | |
609a8b86 | 466 | exception:bad-cond-clause |
d6e04e7c DH |
467 | (eval '(cond 1 2 3) |
468 | (interaction-environment))) | |
08c608e1 DH |
469 | |
470 | (pass-if-exception "(cond 1 2 3 4)" | |
609a8b86 | 471 | exception:bad-cond-clause |
d6e04e7c DH |
472 | (eval '(cond 1 2 3 4) |
473 | (interaction-environment))) | |
08c608e1 DH |
474 | |
475 | (pass-if-exception "(cond ())" | |
609a8b86 | 476 | exception:bad-cond-clause |
d6e04e7c DH |
477 | (eval '(cond ()) |
478 | (interaction-environment))) | |
08c608e1 DH |
479 | |
480 | (pass-if-exception "(cond () 1)" | |
609a8b86 | 481 | exception:bad-cond-clause |
d6e04e7c DH |
482 | (eval '(cond () 1) |
483 | (interaction-environment))) | |
08c608e1 DH |
484 | |
485 | (pass-if-exception "(cond (1) 1)" | |
609a8b86 | 486 | exception:bad-cond-clause |
d6e04e7c DH |
487 | (eval '(cond (1) 1) |
488 | (interaction-environment))))) | |
08c608e1 DH |
489 | |
490 | (with-test-prefix "cond =>" | |
491 | ||
d6e04e7c DH |
492 | (with-test-prefix "cond is hygienic" |
493 | ||
609a8b86 DH |
494 | (pass-if "bound 'else is handled correctly" |
495 | (eq? (let ((else 'ok)) (cond (else))) 'ok)) | |
2a6f7afe | 496 | |
609a8b86 DH |
497 | (pass-if "bound '=> is handled correctly" |
498 | (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok))) | |
d6e04e7c | 499 | |
b461abe7 DH |
500 | (with-test-prefix "else is handled correctly" |
501 | ||
502 | (pass-if "else =>" | |
503 | (let ((=> 'foo)) | |
504 | (eq? (cond (else =>)) 'foo))) | |
505 | ||
506 | (pass-if "else => identity" | |
507 | (let* ((=> 'foo)) | |
508 | (eq? (cond (else => identity)) identity)))) | |
509 | ||
d6e04e7c | 510 | (with-test-prefix "wrong number of arguments" |
08c608e1 | 511 | |
d6e04e7c DH |
512 | (pass-if-exception "=> (lambda (x y) #t)" |
513 | exception:wrong-num-args | |
514 | (cond (1 => (lambda (x y) #t)))))) | |
08c608e1 | 515 | |
27a22666 DH |
516 | (with-test-prefix "case" |
517 | ||
58a2510b DH |
518 | (pass-if "clause with empty labels list" |
519 | (case 1 (() #f) (else #t))) | |
520 | ||
2a6f7afe DH |
521 | (with-test-prefix "case is hygienic" |
522 | ||
523 | (pass-if-exception "bound 'else is handled correctly" | |
524 | exception:bad-case-labels | |
525 | (eval '(let ((else #f)) (case 1 (else #f))) | |
526 | (interaction-environment)))) | |
527 | ||
27a22666 DH |
528 | (with-test-prefix "bad or missing clauses" |
529 | ||
530 | (pass-if-exception "(case)" | |
2a6f7afe | 531 | exception:missing-clauses |
d6e04e7c DH |
532 | (eval '(case) |
533 | (interaction-environment))) | |
27a22666 | 534 | |
27a22666 | 535 | (pass-if-exception "(case . \"foo\")" |
2a6f7afe | 536 | exception:bad-expression |
d6e04e7c DH |
537 | (eval '(case . "foo") |
538 | (interaction-environment))) | |
27a22666 DH |
539 | |
540 | (pass-if-exception "(case 1)" | |
2a6f7afe | 541 | exception:missing-clauses |
d6e04e7c DH |
542 | (eval '(case 1) |
543 | (interaction-environment))) | |
27a22666 | 544 | |
27a22666 | 545 | (pass-if-exception "(case 1 . \"foo\")" |
2a6f7afe | 546 | exception:bad-expression |
d6e04e7c DH |
547 | (eval '(case 1 . "foo") |
548 | (interaction-environment))) | |
27a22666 DH |
549 | |
550 | (pass-if-exception "(case 1 \"foo\")" | |
2a6f7afe | 551 | exception:bad-case-clause |
d6e04e7c DH |
552 | (eval '(case 1 "foo") |
553 | (interaction-environment))) | |
27a22666 DH |
554 | |
555 | (pass-if-exception "(case 1 ())" | |
2a6f7afe | 556 | exception:bad-case-clause |
d6e04e7c DH |
557 | (eval '(case 1 ()) |
558 | (interaction-environment))) | |
27a22666 DH |
559 | |
560 | (pass-if-exception "(case 1 (\"foo\"))" | |
2a6f7afe | 561 | exception:bad-case-clause |
d6e04e7c DH |
562 | (eval '(case 1 ("foo")) |
563 | (interaction-environment))) | |
27a22666 DH |
564 | |
565 | (pass-if-exception "(case 1 (\"foo\" \"bar\"))" | |
2a6f7afe | 566 | exception:bad-case-labels |
d6e04e7c DH |
567 | (eval '(case 1 ("foo" "bar")) |
568 | (interaction-environment))) | |
27a22666 | 569 | |
27a22666 | 570 | (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" |
2a6f7afe | 571 | exception:bad-expression |
d6e04e7c DH |
572 | (eval '(case 1 ((2) "bar") . "foo") |
573 | (interaction-environment))) | |
27a22666 | 574 | |
d6e04e7c | 575 | (pass-if-exception "(case 1 ((2) \"bar\") (else))" |
2a6f7afe | 576 | exception:bad-case-clause |
d6e04e7c DH |
577 | (eval '(case 1 ((2) "bar") (else)) |
578 | (interaction-environment))) | |
27a22666 | 579 | |
27a22666 | 580 | (pass-if-exception "(case 1 (else #f) . \"foo\")" |
2a6f7afe | 581 | exception:bad-expression |
d6e04e7c DH |
582 | (eval '(case 1 (else #f) . "foo") |
583 | (interaction-environment))) | |
27a22666 DH |
584 | |
585 | (pass-if-exception "(case 1 (else #f) ((1) #t))" | |
609a8b86 | 586 | exception:misplaced-else-clause |
d6e04e7c DH |
587 | (eval '(case 1 (else #f) ((1) #t)) |
588 | (interaction-environment))))) | |
27a22666 | 589 | |
08c608e1 DH |
590 | (with-test-prefix "define" |
591 | ||
7171f1ab DH |
592 | (with-test-prefix "currying" |
593 | ||
594 | (pass-if "(define ((foo)) #f)" | |
595 | (define ((foo)) #t) | |
596 | ((foo)))) | |
597 | ||
08c608e1 DH |
598 | (with-test-prefix "missing or extra expressions" |
599 | ||
600 | (pass-if-exception "(define)" | |
cc56ba80 | 601 | exception:missing-expr |
d6e04e7c DH |
602 | (eval '(define) |
603 | (interaction-environment))))) | |
08c608e1 DH |
604 | |
605 | (with-test-prefix "set!" | |
606 | ||
607 | (with-test-prefix "missing or extra expressions" | |
608 | ||
609 | (pass-if-exception "(set!)" | |
610 | exception:missing/extra-expr | |
4dce3c96 DH |
611 | (eval '(set!) |
612 | (interaction-environment))) | |
08c608e1 DH |
613 | |
614 | (pass-if-exception "(set! 1)" | |
615 | exception:missing/extra-expr | |
4dce3c96 DH |
616 | (eval '(set! 1) |
617 | (interaction-environment))) | |
08c608e1 DH |
618 | |
619 | (pass-if-exception "(set! 1 2 3)" | |
620 | exception:missing/extra-expr | |
4dce3c96 DH |
621 | (eval '(set! 1 2 3) |
622 | (interaction-environment)))) | |
08c608e1 DH |
623 | |
624 | (with-test-prefix "bad variable" | |
625 | ||
626 | (pass-if-exception "(set! \"\" #t)" | |
627 | exception:bad-var | |
4dce3c96 DH |
628 | (eval '(set! "" #t) |
629 | (interaction-environment))) | |
08c608e1 DH |
630 | |
631 | (pass-if-exception "(set! 1 #t)" | |
632 | exception:bad-var | |
4dce3c96 DH |
633 | (eval '(set! 1 #t) |
634 | (interaction-environment))) | |
08c608e1 DH |
635 | |
636 | (pass-if-exception "(set! #t #f)" | |
637 | exception:bad-var | |
4dce3c96 DH |
638 | (eval '(set! #t #f) |
639 | (interaction-environment))) | |
08c608e1 DH |
640 | |
641 | (pass-if-exception "(set! #f #t)" | |
642 | exception:bad-var | |
4dce3c96 DH |
643 | (eval '(set! #f #t) |
644 | (interaction-environment))) | |
08c608e1 DH |
645 | |
646 | (pass-if-exception "(set! #\space #f)" | |
647 | exception:bad-var | |
4dce3c96 DH |
648 | (eval '(set! #\space #f) |
649 | (interaction-environment))))) | |
08c608e1 | 650 | |
08c608e1 DH |
651 | (with-test-prefix "quote" |
652 | ||
653 | (with-test-prefix "missing or extra expression" | |
654 | ||
655 | (pass-if-exception "(quote)" | |
656 | exception:missing/extra-expr | |
4dce3c96 DH |
657 | (eval '(quote) |
658 | (interaction-environment))) | |
08c608e1 DH |
659 | |
660 | (pass-if-exception "(quote a b)" | |
661 | exception:missing/extra-expr | |
4dce3c96 DH |
662 | (eval '(quote a b) |
663 | (interaction-environment))))) | |
2798ba71 KR |
664 | |
665 | (with-test-prefix "while" | |
666 | ||
667 | (define (unreachable) | |
668 | (error "unreachable code has been reached!")) | |
669 | ||
2798ba71 KR |
670 | ;; Return a new procedure COND which when called (COND) will return #t the |
671 | ;; first N times, then #f, then any further call is an error. N=0 is | |
672 | ;; allowed, in which case #f is returned by the first call. | |
673 | (define (make-iterations-cond n) | |
674 | (lambda () | |
675 | (cond ((not n) | |
676 | (error "oops, condition re-tested after giving false")) | |
677 | ((= 0 n) | |
678 | (set! n #f) | |
679 | #f) | |
680 | (else | |
681 | (set! n (1- n)) | |
682 | #t)))) | |
683 | ||
684 | ||
685 | (pass-if-exception "too few args" exception:wrong-num-args | |
d6e04e7c | 686 | (eval '(while) (interaction-environment))) |
2798ba71 KR |
687 | |
688 | (with-test-prefix "empty body" | |
689 | (do ((n 0 (1+ n))) | |
690 | ((> n 5)) | |
691 | (pass-if n | |
692 | (let ((cond (make-iterations-cond n))) | |
693 | (while (cond))) | |
694 | #t))) | |
695 | ||
696 | (pass-if "initially false" | |
697 | (while #f | |
698 | (unreachable)) | |
699 | #t) | |
700 | ||
701 | (with-test-prefix "in empty environment" | |
d6e04e7c DH |
702 | |
703 | ;; an environment with no bindings at all | |
704 | (define empty-environment | |
705 | (make-module 1)) | |
706 | ||
2798ba71 KR |
707 | (pass-if "empty body" |
708 | (eval `(,while #f) | |
709 | empty-environment) | |
710 | #t) | |
711 | ||
712 | (pass-if "initially false" | |
713 | (eval `(,while #f | |
714 | #f) | |
715 | empty-environment) | |
716 | #t) | |
717 | ||
718 | (pass-if "iterating" | |
719 | (let ((cond (make-iterations-cond 3))) | |
720 | (eval `(,while (,cond) | |
721 | 123 456) | |
722 | empty-environment)) | |
723 | #t)) | |
724 | ||
725 | (with-test-prefix "iterations" | |
726 | (do ((n 0 (1+ n))) | |
727 | ((> n 5)) | |
728 | (pass-if n | |
729 | (let ((cond (make-iterations-cond n)) | |
730 | (i 0)) | |
731 | (while (cond) | |
732 | (set! i (1+ i))) | |
733 | (= i n))))) | |
734 | ||
735 | (with-test-prefix "break" | |
736 | ||
737 | (pass-if-exception "too many args" exception:wrong-num-args | |
738 | (while #t | |
739 | (break 1))) | |
740 | ||
741 | (with-test-prefix "from cond" | |
742 | (pass-if "first" | |
743 | (while (begin | |
744 | (break) | |
745 | (unreachable)) | |
746 | (unreachable)) | |
747 | #t) | |
748 | ||
749 | (do ((n 0 (1+ n))) | |
750 | ((> n 5)) | |
751 | (pass-if n | |
752 | (let ((cond (make-iterations-cond n)) | |
753 | (i 0)) | |
754 | (while (if (cond) | |
755 | #t | |
756 | (begin | |
757 | (break) | |
758 | (unreachable))) | |
759 | (set! i (1+ i))) | |
760 | (= i n))))) | |
761 | ||
762 | (with-test-prefix "from body" | |
763 | (pass-if "first" | |
764 | (while #t | |
765 | (break) | |
766 | (unreachable)) | |
767 | #t) | |
768 | ||
769 | (do ((n 0 (1+ n))) | |
770 | ((> n 5)) | |
771 | (pass-if n | |
772 | (let ((cond (make-iterations-cond n)) | |
773 | (i 0)) | |
774 | (while #t | |
775 | (if (not (cond)) | |
776 | (begin | |
777 | (break) | |
778 | (unreachable))) | |
779 | (set! i (1+ i))) | |
780 | (= i n))))) | |
781 | ||
782 | (pass-if "from nested" | |
783 | (while #t | |
784 | (let ((outer-break break)) | |
785 | (while #t | |
786 | (outer-break) | |
787 | (unreachable))) | |
788 | (unreachable)) | |
cc08aafd KR |
789 | #t) |
790 | ||
791 | (pass-if "from recursive" | |
792 | (let ((outer-break #f)) | |
793 | (define (r n) | |
794 | (while #t | |
795 | (if (eq? n 'outer) | |
796 | (begin | |
797 | (set! outer-break break) | |
798 | (r 'inner)) | |
799 | (begin | |
800 | (outer-break) | |
801 | (unreachable)))) | |
802 | (if (eq? n 'inner) | |
803 | (error "broke only from inner loop"))) | |
804 | (r 'outer)) | |
2798ba71 KR |
805 | #t)) |
806 | ||
807 | (with-test-prefix "continue" | |
808 | ||
809 | (pass-if-exception "too many args" exception:wrong-num-args | |
810 | (while #t | |
811 | (continue 1))) | |
812 | ||
813 | (with-test-prefix "from cond" | |
814 | (do ((n 0 (1+ n))) | |
815 | ((> n 5)) | |
816 | (pass-if n | |
817 | (let ((cond (make-iterations-cond n)) | |
818 | (i 0)) | |
819 | (while (if (cond) | |
820 | (begin | |
821 | (set! i (1+ i)) | |
822 | (continue) | |
823 | (unreachable)) | |
824 | #f) | |
825 | (unreachable)) | |
826 | (= i n))))) | |
827 | ||
828 | (with-test-prefix "from body" | |
829 | (do ((n 0 (1+ n))) | |
830 | ((> n 5)) | |
831 | (pass-if n | |
832 | (let ((cond (make-iterations-cond n)) | |
833 | (i 0)) | |
834 | (while (cond) | |
835 | (set! i (1+ i)) | |
836 | (continue) | |
837 | (unreachable)) | |
838 | (= i n))))) | |
839 | ||
840 | (pass-if "from nested" | |
841 | (let ((cond (make-iterations-cond 3))) | |
842 | (while (cond) | |
843 | (let ((outer-continue continue)) | |
844 | (while #t | |
845 | (outer-continue) | |
846 | (unreachable))))) | |
cc08aafd KR |
847 | #t) |
848 | ||
849 | (pass-if "from recursive" | |
850 | (let ((outer-continue #f)) | |
851 | (define (r n) | |
852 | (let ((cond (make-iterations-cond 3)) | |
853 | (first #t)) | |
854 | (while (begin | |
855 | (if (and (not first) | |
856 | (eq? n 'inner)) | |
857 | (error "continued only to inner loop")) | |
858 | (cond)) | |
859 | (set! first #f) | |
860 | (if (eq? n 'outer) | |
861 | (begin | |
862 | (set! outer-continue continue) | |
863 | (r 'inner)) | |
864 | (begin | |
865 | (outer-continue) | |
866 | (unreachable)))))) | |
867 | (r 'outer)) | |
2798ba71 | 868 | #t))) |