Commit | Line | Data |
---|---|---|
08c608e1 DH |
1 | ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- |
2 | ;;;; | |
6e7d5622 | 3 | ;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc. |
08c608e1 | 4 | ;;;; |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
08c608e1 | 9 | ;;;; |
53befeb7 | 10 | ;;;; This library is distributed in the hope that it will be useful, |
08c608e1 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
08c608e1 | 14 | ;;;; |
53befeb7 NJ |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
08c608e1 | 18 | |
8aa28a91 DH |
19 | (define-module (test-suite test-syntax) |
20 | :use-module (test-suite lib)) | |
08c608e1 | 21 | |
2a6f7afe | 22 | |
40b36cfb | 23 | (define exception:generic-syncase-error |
02604212 | 24 | (cons 'syntax-error "source expression failed to match")) |
40b36cfb AW |
25 | (define exception:unexpected-syntax |
26 | (cons 'syntax-error "unexpected syntax")) | |
27 | ||
2a6f7afe DH |
28 | (define exception:bad-expression |
29 | (cons 'syntax-error "Bad expression")) | |
cc56ba80 | 30 | |
21628685 | 31 | (define exception:missing/extra-expr |
89bff2fc | 32 | (cons 'syntax-error "Missing or extra expression")) |
cc56ba80 DH |
33 | (define exception:missing-expr |
34 | (cons 'syntax-error "Missing expression")) | |
ced8edb0 | 35 | (define exception:missing-body-expr |
9ecac781 | 36 | (cons 'syntax-error "no expressions in body")) |
cc56ba80 DH |
37 | (define exception:extra-expr |
38 | (cons 'syntax-error "Extra expression")) | |
89bff2fc DH |
39 | (define exception:illegal-empty-combination |
40 | (cons 'syntax-error "Illegal empty combination")) | |
cc56ba80 | 41 | |
dc1eed52 AW |
42 | (define exception:bad-lambda |
43 | '(syntax-error . "bad lambda")) | |
44 | (define exception:bad-let | |
45 | '(syntax-error . "bad let ")) | |
46 | (define exception:bad-letrec | |
47 | '(syntax-error . "bad letrec ")) | |
9ecac781 AW |
48 | (define exception:bad-set! |
49 | '(syntax-error . "bad set!")) | |
50 | (define exception:bad-quote | |
51 | '(syntax-error . "quote: bad syntax")) | |
08c608e1 | 52 | (define exception:bad-bindings |
d6754c23 DH |
53 | (cons 'syntax-error "Bad bindings")) |
54 | (define exception:bad-binding | |
55 | (cons 'syntax-error "Bad binding")) | |
56 | (define exception:duplicate-binding | |
dc1eed52 | 57 | (cons 'syntax-error "duplicate bound variable")) |
08c608e1 DH |
58 | (define exception:bad-body |
59 | (cons 'misc-error "^bad body")) | |
60 | (define exception:bad-formals | |
dc1eed52 | 61 | '(syntax-error . "invalid parameter list")) |
03a3e941 DH |
62 | (define exception:bad-formal |
63 | (cons 'syntax-error "Bad formal")) | |
64 | (define exception:duplicate-formal | |
65 | (cons 'syntax-error "Duplicate formal")) | |
cc56ba80 | 66 | |
2a6f7afe DH |
67 | (define exception:missing-clauses |
68 | (cons 'syntax-error "Missing clauses")) | |
609a8b86 DH |
69 | (define exception:misplaced-else-clause |
70 | (cons 'syntax-error "Misplaced else clause")) | |
2a6f7afe DH |
71 | (define exception:bad-case-clause |
72 | (cons 'syntax-error "Bad case clause")) | |
2a6f7afe DH |
73 | (define exception:bad-case-labels |
74 | (cons 'syntax-error "Bad case labels")) | |
609a8b86 DH |
75 | (define exception:bad-cond-clause |
76 | (cons 'syntax-error "Bad cond clause")) | |
cc56ba80 | 77 | |
08c608e1 DH |
78 | |
79 | (with-test-prefix "expressions" | |
80 | ||
d6e04e7c DH |
81 | (with-test-prefix "Bad argument list" |
82 | ||
83 | (pass-if-exception "improper argument list of length 1" | |
40b36cfb | 84 | exception:generic-syncase-error |
d6e04e7c DH |
85 | (eval '(let ((foo (lambda (x y) #t))) |
86 | (foo . 1)) | |
87 | (interaction-environment))) | |
88 | ||
89 | (pass-if-exception "improper argument list of length 2" | |
40b36cfb | 90 | exception:generic-syncase-error |
d6e04e7c DH |
91 | (eval '(let ((foo (lambda (x y) #t))) |
92 | (foo 1 . 2)) | |
93 | (interaction-environment)))) | |
94 | ||
08c608e1 DH |
95 | (with-test-prefix "missing or extra expression" |
96 | ||
97 | ;; R5RS says: | |
98 | ;; *Note:* In many dialects of Lisp, the empty combination, (), | |
99 | ;; is a legitimate expression. In Scheme, combinations must | |
100 | ;; have at least one subexpression, so () is not a syntactically | |
101 | ;; valid expression. | |
1c54a87c MV |
102 | |
103 | ;; Fixed on 2001-3-3 | |
104 | (pass-if-exception "empty parentheses \"()\"" | |
40b36cfb | 105 | exception:unexpected-syntax |
d6e04e7c DH |
106 | (eval '() |
107 | (interaction-environment))))) | |
08c608e1 | 108 | |
7171f1ab DH |
109 | (with-test-prefix "quote" |
110 | #t) | |
111 | ||
112 | (with-test-prefix "quasiquote" | |
113 | ||
114 | (with-test-prefix "unquote" | |
115 | ||
116 | (pass-if "repeated execution" | |
117 | (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i))))) | |
118 | (and (equal? (foo) '(1)) (equal? (foo) '(2)))))) | |
119 | ||
120 | (with-test-prefix "unquote-splicing" | |
121 | ||
122 | (pass-if-exception "extra arguments" | |
02604212 AW |
123 | '(syntax-error . "unquote-splicing takes exactly one argument") |
124 | (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) | |
125 | (interaction-environment))))) | |
7171f1ab DH |
126 | |
127 | (with-test-prefix "begin" | |
128 | ||
129 | (pass-if "legal (begin)" | |
ce09ee19 | 130 | (eval '(begin (begin) #t) (interaction-environment))) |
7171f1ab | 131 | |
aa498d0c DH |
132 | (with-test-prefix "unmemoization" |
133 | ||
02604212 AW |
134 | ;; FIXME. I have no idea why, but the expander is filling in (if #f |
135 | ;; #f) as the second arm of the if, if the second arm is missing. I | |
136 | ;; thought I made it not do that. But in the meantime, let's adapt, | |
137 | ;; since that's not what we're testing. | |
138 | ||
aa498d0c | 139 | (pass-if "normal begin" |
02604212 | 140 | (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) |
aa498d0c | 141 | (equal? (procedure-source foo) |
02604212 | 142 | '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) |
aa498d0c DH |
143 | |
144 | (pass-if "redundant nested begin" | |
02604212 | 145 | (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) |
aa498d0c DH |
146 | (foo) ; make sure, memoization has been performed |
147 | (equal? (procedure-source foo) | |
02604212 | 148 | '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) |
aa498d0c DH |
149 | |
150 | (pass-if "redundant begin at start of body" | |
151 | (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized | |
152 | (foo) ; make sure, memoization has been performed | |
153 | (equal? (procedure-source foo) | |
154 | '(lambda () (begin (+ 1) (+ 2))))))) | |
155 | ||
02604212 AW |
156 | (pass-if-exception "illegal (begin)" |
157 | exception:generic-syncase-error | |
ce09ee19 | 158 | (eval '(begin (if #t (begin)) #t) (interaction-environment)))) |
7171f1ab | 159 | |
02604212 AW |
160 | (define-syntax matches? |
161 | (syntax-rules (_) | |
162 | ((_ (op arg ...) pat) (let ((x (op arg ...))) | |
163 | (matches? x pat))) | |
164 | ((_ x ()) (null? x)) | |
165 | ((_ x (a . b)) (and (pair? x) | |
166 | (matches? (car x) a) | |
167 | (matches? (cdr x) b))) | |
168 | ((_ x _) #t) | |
169 | ((_ x pat) (equal? x 'pat)))) | |
170 | ||
08c608e1 DH |
171 | (with-test-prefix "lambda" |
172 | ||
aa498d0c DH |
173 | (with-test-prefix "unmemoization" |
174 | ||
175 | (pass-if "normal lambda" | |
176 | (let ((foo (lambda () (lambda (x y) (+ x y))))) | |
02604212 AW |
177 | (matches? (procedure-source foo) |
178 | (lambda () (lambda (_ _) (+ _ _)))))) | |
aa498d0c DH |
179 | |
180 | (pass-if "lambda with documentation" | |
181 | (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) | |
02604212 AW |
182 | (matches? (procedure-source foo) |
183 | (lambda () (lambda (_ _) "docstring" (+ _ _))))))) | |
aa498d0c | 184 | |
08c608e1 DH |
185 | (with-test-prefix "bad formals" |
186 | ||
ea6c2147 | 187 | (pass-if-exception "(lambda)" |
dc1eed52 | 188 | exception:bad-lambda |
d6e04e7c DH |
189 | (eval '(lambda) |
190 | (interaction-environment))) | |
ea6c2147 DH |
191 | |
192 | (pass-if-exception "(lambda . \"foo\")" | |
dc1eed52 | 193 | exception:bad-lambda |
d6e04e7c DH |
194 | (eval '(lambda . "foo") |
195 | (interaction-environment))) | |
ea6c2147 | 196 | |
ea6c2147 | 197 | (pass-if-exception "(lambda \"foo\")" |
dc1eed52 | 198 | exception:bad-lambda |
d6e04e7c DH |
199 | (eval '(lambda "foo") |
200 | (interaction-environment))) | |
ea6c2147 DH |
201 | |
202 | (pass-if-exception "(lambda \"foo\" #f)" | |
203 | exception:bad-formals | |
4dce3c96 DH |
204 | (eval '(lambda "foo" #f) |
205 | (interaction-environment))) | |
ea6c2147 DH |
206 | |
207 | (pass-if-exception "(lambda (x 1) 2)" | |
dc1eed52 | 208 | exception:bad-formals |
d6e04e7c DH |
209 | (eval '(lambda (x 1) 2) |
210 | (interaction-environment))) | |
08c608e1 DH |
211 | |
212 | (pass-if-exception "(lambda (1 x) 2)" | |
dc1eed52 | 213 | exception:bad-formals |
d6e04e7c DH |
214 | (eval '(lambda (1 x) 2) |
215 | (interaction-environment))) | |
08c608e1 DH |
216 | |
217 | (pass-if-exception "(lambda (x \"a\") 2)" | |
dc1eed52 | 218 | exception:bad-formals |
d6e04e7c DH |
219 | (eval '(lambda (x "a") 2) |
220 | (interaction-environment))) | |
08c608e1 DH |
221 | |
222 | (pass-if-exception "(lambda (\"a\" x) 2)" | |
dc1eed52 | 223 | exception:bad-formals |
d6e04e7c DH |
224 | (eval '(lambda ("a" x) 2) |
225 | (interaction-environment)))) | |
08c608e1 | 226 | |
1c54a87c MV |
227 | (with-test-prefix "duplicate formals" |
228 | ||
229 | ;; Fixed on 2001-3-3 | |
230 | (pass-if-exception "(lambda (x x) 1)" | |
dc1eed52 | 231 | exception:bad-formals |
d6e04e7c DH |
232 | (eval '(lambda (x x) 1) |
233 | (interaction-environment))) | |
08c608e1 | 234 | |
1c54a87c MV |
235 | ;; Fixed on 2001-3-3 |
236 | (pass-if-exception "(lambda (x x x) 1)" | |
dc1eed52 | 237 | exception:bad-formals |
d6e04e7c DH |
238 | (eval '(lambda (x x x) 1) |
239 | (interaction-environment)))) | |
7171f1ab DH |
240 | |
241 | (with-test-prefix "bad body" | |
242 | ||
243 | (pass-if-exception "(lambda ())" | |
dc1eed52 | 244 | exception:bad-lambda |
d6e04e7c DH |
245 | (eval '(lambda ()) |
246 | (interaction-environment))))) | |
08c608e1 DH |
247 | |
248 | (with-test-prefix "let" | |
249 | ||
aa498d0c DH |
250 | (with-test-prefix "unmemoization" |
251 | ||
252 | (pass-if "normal let" | |
253 | (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) | |
dc1eed52 AW |
254 | (matches? (procedure-source foo) |
255 | (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) | |
aa498d0c | 256 | |
08c608e1 DH |
257 | (with-test-prefix "bindings" |
258 | ||
259 | (pass-if-exception "late binding" | |
260 | exception:unbound-var | |
261 | (let ((x 1) (y x)) y))) | |
262 | ||
7171f1ab | 263 | (with-test-prefix "bad bindings" |
08c608e1 | 264 | |
08c608e1 | 265 | (pass-if-exception "(let)" |
dc1eed52 | 266 | exception:bad-let |
d6e04e7c DH |
267 | (eval '(let) |
268 | (interaction-environment))) | |
08c608e1 | 269 | |
08c608e1 | 270 | (pass-if-exception "(let 1)" |
dc1eed52 | 271 | exception:bad-let |
d6e04e7c DH |
272 | (eval '(let 1) |
273 | (interaction-environment))) | |
08c608e1 | 274 | |
08c608e1 | 275 | (pass-if-exception "(let (x))" |
dc1eed52 | 276 | exception:bad-let |
d6e04e7c DH |
277 | (eval '(let (x)) |
278 | (interaction-environment))) | |
08c608e1 | 279 | |
7171f1ab | 280 | (pass-if-exception "(let ((x)))" |
dc1eed52 | 281 | exception:bad-let |
d6e04e7c DH |
282 | (eval '(let ((x))) |
283 | (interaction-environment))) | |
08c608e1 DH |
284 | |
285 | (pass-if-exception "(let (x) 1)" | |
dc1eed52 | 286 | exception:bad-let |
d6e04e7c DH |
287 | (eval '(let (x) 1) |
288 | (interaction-environment))) | |
08c608e1 DH |
289 | |
290 | (pass-if-exception "(let ((x)) 3)" | |
dc1eed52 | 291 | exception:bad-let |
d6e04e7c DH |
292 | (eval '(let ((x)) 3) |
293 | (interaction-environment))) | |
08c608e1 DH |
294 | |
295 | (pass-if-exception "(let ((x 1) y) x)" | |
dc1eed52 | 296 | exception:bad-let |
d6e04e7c DH |
297 | (eval '(let ((x 1) y) x) |
298 | (interaction-environment))) | |
08c608e1 DH |
299 | |
300 | (pass-if-exception "(let ((1 2)) 3)" | |
dc1eed52 | 301 | exception:bad-let |
4dce3c96 DH |
302 | (eval '(let ((1 2)) 3) |
303 | (interaction-environment)))) | |
08c608e1 | 304 | |
c0ed1605 MV |
305 | (with-test-prefix "duplicate bindings" |
306 | ||
307 | (pass-if-exception "(let ((x 1) (x 2)) x)" | |
d6754c23 | 308 | exception:duplicate-binding |
d6e04e7c DH |
309 | (eval '(let ((x 1) (x 2)) x) |
310 | (interaction-environment)))) | |
7171f1ab DH |
311 | |
312 | (with-test-prefix "bad body" | |
313 | ||
314 | (pass-if-exception "(let ())" | |
dc1eed52 | 315 | exception:bad-let |
d6e04e7c DH |
316 | (eval '(let ()) |
317 | (interaction-environment))) | |
7171f1ab DH |
318 | |
319 | (pass-if-exception "(let ((x 1)))" | |
dc1eed52 | 320 | exception:bad-let |
d6e04e7c DH |
321 | (eval '(let ((x 1))) |
322 | (interaction-environment))))) | |
08c608e1 DH |
323 | |
324 | (with-test-prefix "named let" | |
325 | ||
7171f1ab DH |
326 | (with-test-prefix "initializers" |
327 | ||
328 | (pass-if "evaluated in outer environment" | |
329 | (let ((f -)) | |
330 | (eqv? (let f ((n (f 1))) n) -1)))) | |
331 | ||
332 | (with-test-prefix "bad bindings" | |
333 | ||
334 | (pass-if-exception "(let x (y))" | |
dc1eed52 | 335 | exception:bad-let |
d6e04e7c DH |
336 | (eval '(let x (y)) |
337 | (interaction-environment)))) | |
7171f1ab | 338 | |
08c608e1 DH |
339 | (with-test-prefix "bad body" |
340 | ||
341 | (pass-if-exception "(let x ())" | |
dc1eed52 | 342 | exception:bad-let |
d6e04e7c DH |
343 | (eval '(let x ()) |
344 | (interaction-environment))) | |
08c608e1 DH |
345 | |
346 | (pass-if-exception "(let x ((y 1)))" | |
dc1eed52 | 347 | exception:bad-let |
d6e04e7c DH |
348 | (eval '(let x ((y 1))) |
349 | (interaction-environment))))) | |
08c608e1 DH |
350 | |
351 | (with-test-prefix "let*" | |
352 | ||
aa498d0c DH |
353 | (with-test-prefix "unmemoization" |
354 | ||
355 | (pass-if "normal let*" | |
356 | (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) | |
dc1eed52 AW |
357 | (matches? (procedure-source foo) |
358 | (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) | |
aa498d0c DH |
359 | |
360 | (pass-if "let* without bindings" | |
361 | (let ((foo (lambda () (let ((x 1) (y 2)) | |
362 | (let* () | |
363 | (and (= x 1) (= y 2))))))) | |
dc1eed52 AW |
364 | (matches? (procedure-source foo) |
365 | (lambda () (let ((_ 1) (_ 2)) | |
366 | (if (= _ 1) (= _ 2) #f))))))) | |
aa498d0c | 367 | |
e1a7b2ce DH |
368 | (with-test-prefix "bindings" |
369 | ||
370 | (pass-if "(let* ((x 1) (x 2)) ...)" | |
371 | (let* ((x 1) (x 2)) | |
372 | (= x 2))) | |
373 | ||
374 | (pass-if "(let* ((x 1) (x x)) ...)" | |
375 | (let* ((x 1) (x x)) | |
aa498d0c DH |
376 | (= x 1))) |
377 | ||
378 | (pass-if "(let ((x 1) (y 2)) (let* () ...))" | |
379 | (let ((x 1) (y 2)) | |
380 | (let* () | |
381 | (and (= x 1) (= y 2)))))) | |
e1a7b2ce | 382 | |
7171f1ab | 383 | (with-test-prefix "bad bindings" |
08c608e1 | 384 | |
08c608e1 | 385 | (pass-if-exception "(let*)" |
dc1eed52 | 386 | exception:generic-syncase-error |
d6e04e7c DH |
387 | (eval '(let*) |
388 | (interaction-environment))) | |
08c608e1 | 389 | |
08c608e1 | 390 | (pass-if-exception "(let* 1)" |
dc1eed52 | 391 | exception:generic-syncase-error |
d6e04e7c DH |
392 | (eval '(let* 1) |
393 | (interaction-environment))) | |
08c608e1 | 394 | |
08c608e1 | 395 | (pass-if-exception "(let* (x))" |
dc1eed52 | 396 | exception:generic-syncase-error |
d6e04e7c DH |
397 | (eval '(let* (x)) |
398 | (interaction-environment))) | |
08c608e1 DH |
399 | |
400 | (pass-if-exception "(let* (x) 1)" | |
dc1eed52 | 401 | exception:generic-syncase-error |
d6e04e7c DH |
402 | (eval '(let* (x) 1) |
403 | (interaction-environment))) | |
08c608e1 DH |
404 | |
405 | (pass-if-exception "(let* ((x)) 3)" | |
dc1eed52 | 406 | exception:generic-syncase-error |
d6e04e7c DH |
407 | (eval '(let* ((x)) 3) |
408 | (interaction-environment))) | |
08c608e1 DH |
409 | |
410 | (pass-if-exception "(let* ((x 1) y) x)" | |
dc1eed52 | 411 | exception:generic-syncase-error |
d6e04e7c DH |
412 | (eval '(let* ((x 1) y) x) |
413 | (interaction-environment))) | |
08c608e1 DH |
414 | |
415 | (pass-if-exception "(let* x ())" | |
dc1eed52 | 416 | exception:generic-syncase-error |
4dce3c96 DH |
417 | (eval '(let* x ()) |
418 | (interaction-environment))) | |
08c608e1 DH |
419 | |
420 | (pass-if-exception "(let* x (y))" | |
dc1eed52 | 421 | exception:generic-syncase-error |
4dce3c96 DH |
422 | (eval '(let* x (y)) |
423 | (interaction-environment))) | |
08c608e1 DH |
424 | |
425 | (pass-if-exception "(let* ((1 2)) 3)" | |
dc1eed52 | 426 | exception:generic-syncase-error |
4dce3c96 DH |
427 | (eval '(let* ((1 2)) 3) |
428 | (interaction-environment)))) | |
7171f1ab DH |
429 | |
430 | (with-test-prefix "bad body" | |
431 | ||
432 | (pass-if-exception "(let* ())" | |
dc1eed52 | 433 | exception:generic-syncase-error |
d6e04e7c DH |
434 | (eval '(let* ()) |
435 | (interaction-environment))) | |
7171f1ab DH |
436 | |
437 | (pass-if-exception "(let* ((x 1)))" | |
dc1eed52 | 438 | exception:generic-syncase-error |
d6e04e7c DH |
439 | (eval '(let* ((x 1))) |
440 | (interaction-environment))))) | |
08c608e1 DH |
441 | |
442 | (with-test-prefix "letrec" | |
443 | ||
aa498d0c DH |
444 | (with-test-prefix "unmemoization" |
445 | ||
446 | (pass-if "normal letrec" | |
447 | (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) | |
dc1eed52 AW |
448 | (matches? (procedure-source foo) |
449 | (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) | |
aa498d0c | 450 | |
08c608e1 DH |
451 | (with-test-prefix "bindings" |
452 | ||
453 | (pass-if-exception "initial bindings are undefined" | |
0ac46745 | 454 | exception:used-before-defined |
08c608e1 DH |
455 | (let ((x 1)) |
456 | (letrec ((x 1) (y x)) y)))) | |
457 | ||
7171f1ab | 458 | (with-test-prefix "bad bindings" |
08c608e1 | 459 | |
08c608e1 | 460 | (pass-if-exception "(letrec)" |
dc1eed52 | 461 | exception:bad-letrec |
d6e04e7c DH |
462 | (eval '(letrec) |
463 | (interaction-environment))) | |
08c608e1 | 464 | |
08c608e1 | 465 | (pass-if-exception "(letrec 1)" |
dc1eed52 | 466 | exception:bad-letrec |
d6e04e7c DH |
467 | (eval '(letrec 1) |
468 | (interaction-environment))) | |
08c608e1 | 469 | |
08c608e1 | 470 | (pass-if-exception "(letrec (x))" |
dc1eed52 | 471 | exception:bad-letrec |
d6e04e7c DH |
472 | (eval '(letrec (x)) |
473 | (interaction-environment))) | |
08c608e1 DH |
474 | |
475 | (pass-if-exception "(letrec (x) 1)" | |
dc1eed52 | 476 | exception:bad-letrec |
d6e04e7c DH |
477 | (eval '(letrec (x) 1) |
478 | (interaction-environment))) | |
08c608e1 DH |
479 | |
480 | (pass-if-exception "(letrec ((x)) 3)" | |
dc1eed52 | 481 | exception:bad-letrec |
d6e04e7c DH |
482 | (eval '(letrec ((x)) 3) |
483 | (interaction-environment))) | |
08c608e1 DH |
484 | |
485 | (pass-if-exception "(letrec ((x 1) y) x)" | |
dc1eed52 | 486 | exception:bad-letrec |
d6e04e7c DH |
487 | (eval '(letrec ((x 1) y) x) |
488 | (interaction-environment))) | |
08c608e1 DH |
489 | |
490 | (pass-if-exception "(letrec x ())" | |
dc1eed52 | 491 | exception:bad-letrec |
4dce3c96 DH |
492 | (eval '(letrec x ()) |
493 | (interaction-environment))) | |
08c608e1 DH |
494 | |
495 | (pass-if-exception "(letrec x (y))" | |
dc1eed52 | 496 | exception:bad-letrec |
4dce3c96 DH |
497 | (eval '(letrec x (y)) |
498 | (interaction-environment))) | |
08c608e1 DH |
499 | |
500 | (pass-if-exception "(letrec ((1 2)) 3)" | |
dc1eed52 | 501 | exception:bad-letrec |
4dce3c96 DH |
502 | (eval '(letrec ((1 2)) 3) |
503 | (interaction-environment)))) | |
08c608e1 | 504 | |
c0ed1605 MV |
505 | (with-test-prefix "duplicate bindings" |
506 | ||
507 | (pass-if-exception "(letrec ((x 1) (x 2)) x)" | |
d6754c23 | 508 | exception:duplicate-binding |
d6e04e7c DH |
509 | (eval '(letrec ((x 1) (x 2)) x) |
510 | (interaction-environment)))) | |
7171f1ab DH |
511 | |
512 | (with-test-prefix "bad body" | |
513 | ||
514 | (pass-if-exception "(letrec ())" | |
dc1eed52 | 515 | exception:bad-letrec |
d6e04e7c DH |
516 | (eval '(letrec ()) |
517 | (interaction-environment))) | |
7171f1ab DH |
518 | |
519 | (pass-if-exception "(letrec ((x 1)))" | |
dc1eed52 | 520 | exception:bad-letrec |
d6e04e7c DH |
521 | (eval '(letrec ((x 1))) |
522 | (interaction-environment))))) | |
08c608e1 DH |
523 | |
524 | (with-test-prefix "if" | |
525 | ||
aa498d0c DH |
526 | (with-test-prefix "unmemoization" |
527 | ||
528 | (pass-if "normal if" | |
529 | (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) | |
530 | (foo #t) ; make sure, memoization has been performed | |
531 | (foo #f) ; make sure, memoization has been performed | |
dc1eed52 AW |
532 | (matches? (procedure-source foo) |
533 | (lambda (_) (if _ (+ 1) (+ 2)))))) | |
aa498d0c | 534 | |
dc1eed52 | 535 | (expect-fail "if without else" |
aa498d0c DH |
536 | (let ((foo (lambda (x) (if x (+ 1))))) |
537 | (foo #t) ; make sure, memoization has been performed | |
538 | (foo #f) ; make sure, memoization has been performed | |
539 | (equal? (procedure-source foo) | |
540 | '(lambda (x) (if x (+ 1)))))) | |
541 | ||
dc1eed52 | 542 | (expect-fail "if #f without else" |
aa498d0c DH |
543 | (let ((foo (lambda () (if #f #f)))) |
544 | (foo) ; make sure, memoization has been performed | |
545 | (equal? (procedure-source foo) | |
546 | `(lambda () (if #f #f)))))) | |
547 | ||
08c608e1 DH |
548 | (with-test-prefix "missing or extra expressions" |
549 | ||
550 | (pass-if-exception "(if)" | |
dc1eed52 | 551 | exception:generic-syncase-error |
4dce3c96 DH |
552 | (eval '(if) |
553 | (interaction-environment))) | |
08c608e1 DH |
554 | |
555 | (pass-if-exception "(if 1 2 3 4)" | |
dc1eed52 | 556 | exception:generic-syncase-error |
4dce3c96 DH |
557 | (eval '(if 1 2 3 4) |
558 | (interaction-environment))))) | |
08c608e1 DH |
559 | |
560 | (with-test-prefix "cond" | |
561 | ||
aa498d0c DH |
562 | (with-test-prefix "cond is hygienic" |
563 | ||
564 | (pass-if "bound 'else is handled correctly" | |
565 | (eq? (let ((else 'ok)) (cond (else))) 'ok)) | |
566 | ||
567 | (with-test-prefix "bound '=> is handled correctly" | |
568 | ||
569 | (pass-if "#t => 'ok" | |
570 | (let ((=> 'foo)) | |
571 | (eq? (cond (#t => 'ok)) 'ok))) | |
572 | ||
573 | (pass-if "else =>" | |
574 | (let ((=> 'foo)) | |
575 | (eq? (cond (else =>)) 'foo))) | |
576 | ||
577 | (pass-if "else => identity" | |
578 | (let ((=> 'foo)) | |
579 | (eq? (cond (else => identity)) identity))))) | |
580 | ||
9ee0f678 LC |
581 | (with-test-prefix "SRFI-61" |
582 | ||
583 | (pass-if "always available" | |
584 | (cond-expand (srfi-61 #t) (else #f))) | |
585 | ||
586 | (pass-if "single value consequent" | |
587 | (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f)))) | |
588 | ||
589 | (pass-if "single value alternate" | |
590 | (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok)))) | |
591 | ||
592 | (pass-if-exception "doesn't affect standard =>" | |
593 | exception:wrong-num-args | |
594 | (cond ((values 1 2) => (lambda (x y) #t)))) | |
595 | ||
596 | (pass-if "multiple values consequent" | |
597 | (equal? '(2 1) (cond ((values 1 2) | |
598 | (lambda (one two) | |
599 | (and (= 1 one) (= 2 two))) => | |
600 | (lambda (one two) (list two one))) | |
601 | (else #f)))) | |
602 | ||
603 | (pass-if "multiple values alternate" | |
604 | (eq? 'ok (cond ((values 2 3 4) | |
605 | (lambda args (equal? '(1 2 3) args)) => | |
606 | (lambda (x y z) #f)) | |
607 | (else 'ok)))) | |
608 | ||
609 | (pass-if "zero values" | |
610 | (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok)) | |
611 | (else #f)))) | |
612 | ||
613 | (pass-if "bound => is handled correctly" | |
614 | (let ((=> 'ok)) | |
615 | (eq? 'ok (cond (#t identity =>) (else #f))))) | |
616 | ||
617 | (pass-if-exception "missing recipient" | |
dc1eed52 | 618 | '(syntax-error . "cond: wrong number of receiver expressions") |
9ee0f678 LC |
619 | (cond (#t identity =>))) |
620 | ||
621 | (pass-if-exception "extra recipient" | |
dc1eed52 | 622 | '(syntax-error . "cond: wrong number of receiver expressions") |
9ee0f678 LC |
623 | (cond (#t identity => identity identity)))) |
624 | ||
aa498d0c DH |
625 | (with-test-prefix "unmemoization" |
626 | ||
dc1eed52 | 627 | ;; FIXME: the (if #f #f) is a hack! |
aa498d0c | 628 | (pass-if "normal clauses" |
dc1eed52 | 629 | (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) |
aa498d0c | 630 | (equal? (procedure-source foo) |
dc1eed52 | 631 | '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) |
aa498d0c DH |
632 | |
633 | (pass-if "else" | |
634 | (let ((foo (lambda () (cond (else 'bar))))) | |
aa498d0c | 635 | (equal? (procedure-source foo) |
dc1eed52 | 636 | '(lambda () 'bar)))) |
aa498d0c | 637 | |
dc1eed52 | 638 | ;; FIXME: the (if #f #f) is a hack! |
aa498d0c DH |
639 | (pass-if "=>" |
640 | (let ((foo (lambda () (cond (#t => identity))))) | |
dc1eed52 AW |
641 | (matches? (procedure-source foo) |
642 | (lambda () (let ((_ #t)) | |
643 | (if _ (identity _) (if #f #f)))))))) | |
aa498d0c | 644 | |
08c608e1 DH |
645 | (with-test-prefix "bad or missing clauses" |
646 | ||
647 | (pass-if-exception "(cond)" | |
dc1eed52 | 648 | exception:generic-syncase-error |
d6e04e7c DH |
649 | (eval '(cond) |
650 | (interaction-environment))) | |
08c608e1 DH |
651 | |
652 | (pass-if-exception "(cond #t)" | |
dc1eed52 | 653 | exception:generic-syncase-error |
d6e04e7c DH |
654 | (eval '(cond #t) |
655 | (interaction-environment))) | |
08c608e1 DH |
656 | |
657 | (pass-if-exception "(cond 1)" | |
dc1eed52 | 658 | exception:generic-syncase-error |
d6e04e7c DH |
659 | (eval '(cond 1) |
660 | (interaction-environment))) | |
08c608e1 DH |
661 | |
662 | (pass-if-exception "(cond 1 2)" | |
dc1eed52 | 663 | exception:generic-syncase-error |
d6e04e7c DH |
664 | (eval '(cond 1 2) |
665 | (interaction-environment))) | |
08c608e1 DH |
666 | |
667 | (pass-if-exception "(cond 1 2 3)" | |
dc1eed52 | 668 | exception:generic-syncase-error |
d6e04e7c DH |
669 | (eval '(cond 1 2 3) |
670 | (interaction-environment))) | |
08c608e1 DH |
671 | |
672 | (pass-if-exception "(cond 1 2 3 4)" | |
dc1eed52 | 673 | exception:generic-syncase-error |
d6e04e7c DH |
674 | (eval '(cond 1 2 3 4) |
675 | (interaction-environment))) | |
08c608e1 DH |
676 | |
677 | (pass-if-exception "(cond ())" | |
dc1eed52 | 678 | exception:generic-syncase-error |
d6e04e7c DH |
679 | (eval '(cond ()) |
680 | (interaction-environment))) | |
08c608e1 DH |
681 | |
682 | (pass-if-exception "(cond () 1)" | |
dc1eed52 | 683 | exception:generic-syncase-error |
d6e04e7c DH |
684 | (eval '(cond () 1) |
685 | (interaction-environment))) | |
08c608e1 DH |
686 | |
687 | (pass-if-exception "(cond (1) 1)" | |
dc1eed52 | 688 | exception:generic-syncase-error |
d6e04e7c | 689 | (eval '(cond (1) 1) |
aa498d0c | 690 | (interaction-environment)))) |
b461abe7 | 691 | |
d6e04e7c | 692 | (with-test-prefix "wrong number of arguments" |
08c608e1 | 693 | |
d6e04e7c DH |
694 | (pass-if-exception "=> (lambda (x y) #t)" |
695 | exception:wrong-num-args | |
696 | (cond (1 => (lambda (x y) #t)))))) | |
08c608e1 | 697 | |
27a22666 DH |
698 | (with-test-prefix "case" |
699 | ||
58a2510b DH |
700 | (pass-if "clause with empty labels list" |
701 | (case 1 (() #f) (else #t))) | |
702 | ||
2a6f7afe DH |
703 | (with-test-prefix "case is hygienic" |
704 | ||
705 | (pass-if-exception "bound 'else is handled correctly" | |
dc1eed52 | 706 | exception:generic-syncase-error |
2a6f7afe DH |
707 | (eval '(let ((else #f)) (case 1 (else #f))) |
708 | (interaction-environment)))) | |
709 | ||
aa498d0c DH |
710 | (with-test-prefix "unmemoization" |
711 | ||
712 | (pass-if "normal clauses" | |
713 | (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) | |
dc1eed52 AW |
714 | (matches? (procedure-source foo) |
715 | (lambda (_) | |
716 | (if ((@@ (guile) memv) _ '(1)) | |
717 | 'bar | |
718 | (if ((@@ (guile) memv) _ '(2)) | |
719 | 'baz | |
720 | 'foobar)))))) | |
aa498d0c DH |
721 | |
722 | (pass-if "empty labels" | |
723 | (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) | |
dc1eed52 AW |
724 | (matches? (procedure-source foo) |
725 | (lambda (_) | |
726 | (if ((@@ (guile) memv) _ '(1)) | |
727 | 'bar | |
728 | (if ((@@ (guile) memv) _ '()) | |
729 | 'baz | |
730 | 'foobar))))))) | |
aa498d0c | 731 | |
27a22666 DH |
732 | (with-test-prefix "bad or missing clauses" |
733 | ||
734 | (pass-if-exception "(case)" | |
dc1eed52 | 735 | exception:generic-syncase-error |
d6e04e7c DH |
736 | (eval '(case) |
737 | (interaction-environment))) | |
27a22666 | 738 | |
27a22666 | 739 | (pass-if-exception "(case . \"foo\")" |
dc1eed52 | 740 | exception:generic-syncase-error |
d6e04e7c DH |
741 | (eval '(case . "foo") |
742 | (interaction-environment))) | |
27a22666 DH |
743 | |
744 | (pass-if-exception "(case 1)" | |
dc1eed52 | 745 | exception:generic-syncase-error |
d6e04e7c DH |
746 | (eval '(case 1) |
747 | (interaction-environment))) | |
27a22666 | 748 | |
27a22666 | 749 | (pass-if-exception "(case 1 . \"foo\")" |
dc1eed52 | 750 | exception:generic-syncase-error |
d6e04e7c DH |
751 | (eval '(case 1 . "foo") |
752 | (interaction-environment))) | |
27a22666 DH |
753 | |
754 | (pass-if-exception "(case 1 \"foo\")" | |
dc1eed52 | 755 | exception:generic-syncase-error |
d6e04e7c DH |
756 | (eval '(case 1 "foo") |
757 | (interaction-environment))) | |
27a22666 DH |
758 | |
759 | (pass-if-exception "(case 1 ())" | |
dc1eed52 | 760 | exception:generic-syncase-error |
d6e04e7c DH |
761 | (eval '(case 1 ()) |
762 | (interaction-environment))) | |
27a22666 DH |
763 | |
764 | (pass-if-exception "(case 1 (\"foo\"))" | |
dc1eed52 | 765 | exception:generic-syncase-error |
d6e04e7c DH |
766 | (eval '(case 1 ("foo")) |
767 | (interaction-environment))) | |
27a22666 DH |
768 | |
769 | (pass-if-exception "(case 1 (\"foo\" \"bar\"))" | |
dc1eed52 | 770 | exception:generic-syncase-error |
d6e04e7c DH |
771 | (eval '(case 1 ("foo" "bar")) |
772 | (interaction-environment))) | |
27a22666 | 773 | |
27a22666 | 774 | (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" |
dc1eed52 | 775 | exception:generic-syncase-error |
d6e04e7c DH |
776 | (eval '(case 1 ((2) "bar") . "foo") |
777 | (interaction-environment))) | |
27a22666 | 778 | |
d6e04e7c | 779 | (pass-if-exception "(case 1 ((2) \"bar\") (else))" |
dc1eed52 | 780 | exception:generic-syncase-error |
d6e04e7c DH |
781 | (eval '(case 1 ((2) "bar") (else)) |
782 | (interaction-environment))) | |
27a22666 | 783 | |
27a22666 | 784 | (pass-if-exception "(case 1 (else #f) . \"foo\")" |
dc1eed52 | 785 | exception:generic-syncase-error |
d6e04e7c DH |
786 | (eval '(case 1 (else #f) . "foo") |
787 | (interaction-environment))) | |
27a22666 DH |
788 | |
789 | (pass-if-exception "(case 1 (else #f) ((1) #t))" | |
dc1eed52 | 790 | exception:generic-syncase-error |
d6e04e7c DH |
791 | (eval '(case 1 (else #f) ((1) #t)) |
792 | (interaction-environment))))) | |
27a22666 | 793 | |
ced8edb0 | 794 | (with-test-prefix "top-level define" |
08c608e1 | 795 | |
3dcf3373 LC |
796 | (pass-if "redefinition" |
797 | (let ((m (make-module))) | |
798 | (beautify-user-module! m) | |
799 | ||
800 | ;; The previous value of `round' must still be visible at the time the | |
801 | ;; new `round' is defined. According to R5RS (Section 5.2.1), `define' | |
802 | ;; should behave like `set!' in this case (except that in the case of | |
803 | ;; Guile, we respect module boundaries). | |
804 | (eval '(define round round) m) | |
805 | (eq? (module-ref m 'round) round))) | |
36245b66 | 806 | |
c454c4e6 DH |
807 | (with-test-prefix "unmemoization" |
808 | ||
809 | (pass-if "definition unmemoized without prior execution" | |
810 | (eval '(begin | |
811 | (define (blub) (cons ('(1 . 2)) 2)) | |
812 | (equal? | |
813 | (procedure-source blub) | |
814 | '(lambda () (cons ('(1 . 2)) 2)))) | |
815 | (interaction-environment))) | |
816 | ||
817 | (pass-if "definition with documentation unmemoized without prior execution" | |
818 | (eval '(begin | |
819 | (define (blub) "Comment" (cons ('(1 . 2)) 2)) | |
820 | (equal? | |
821 | (procedure-source blub) | |
822 | '(lambda () "Comment" (cons ('(1 . 2)) 2)))) | |
823 | (interaction-environment)))) | |
824 | ||
08c608e1 DH |
825 | (with-test-prefix "missing or extra expressions" |
826 | ||
827 | (pass-if-exception "(define)" | |
9ecac781 | 828 | exception:generic-syncase-error |
d6e04e7c DH |
829 | (eval '(define) |
830 | (interaction-environment))))) | |
08c608e1 | 831 | |
ced8edb0 DH |
832 | (with-test-prefix "internal define" |
833 | ||
834 | (pass-if "internal defines become letrec" | |
835 | (eval '(let ((a identity) (b identity) (c identity)) | |
836 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
837 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
838 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
839 | (and (eq? 'a (a 0) (a 3)) | |
840 | (eq? 'b (a 1) (a 4)) | |
841 | (eq? 'c (a 2) (a 5)))) | |
842 | (interaction-environment))) | |
843 | ||
3dcf3373 LC |
844 | (pass-if "binding is created before expression is evaluated" |
845 | ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2). | |
846 | (= (eval '(let () | |
847 | (define foo | |
848 | (begin | |
849 | (set! foo 1) | |
850 | (+ foo 1))) | |
851 | foo) | |
852 | (interaction-environment)) | |
853 | 2)) | |
854 | ||
c86c440b | 855 | (pass-if "internal defines with begin" |
ced8edb0 DH |
856 | (false-if-exception |
857 | (eval '(let ((a identity) (b identity) (c identity)) | |
858 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
859 | (begin | |
860 | (define (b x) (if (= x 0) 'b (c (- x 1))))) | |
861 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
862 | (and (eq? 'a (a 0) (a 3)) | |
863 | (eq? 'b (a 1) (a 4)) | |
864 | (eq? 'c (a 2) (a 5)))) | |
865 | (interaction-environment)))) | |
866 | ||
c86c440b | 867 | (pass-if "internal defines with empty begin" |
ced8edb0 DH |
868 | (false-if-exception |
869 | (eval '(let ((a identity) (b identity) (c identity)) | |
870 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
871 | (begin) | |
872 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
873 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
874 | (and (eq? 'a (a 0) (a 3)) | |
875 | (eq? 'b (a 1) (a 4)) | |
876 | (eq? 'c (a 2) (a 5)))) | |
877 | (interaction-environment)))) | |
878 | ||
c3d94801 | 879 | (pass-if "internal defines with macro application" |
560434b3 DH |
880 | (false-if-exception |
881 | (eval '(begin | |
c3d94801 | 882 | (defmacro my-define forms |
560434b3 | 883 | (cons 'define forms)) |
c3d94801 DH |
884 | (let ((a identity) (b identity) (c identity)) |
885 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
886 | (my-define (b x) (if (= x 0) 'b (c (- x 1)))) | |
887 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
888 | (and (eq? 'a (a 0) (a 3)) | |
889 | (eq? 'b (a 1) (a 4)) | |
890 | (eq? 'c (a 2) (a 5))))) | |
560434b3 DH |
891 | (interaction-environment)))) |
892 | ||
ced8edb0 DH |
893 | (pass-if-exception "missing body expression" |
894 | exception:missing-body-expr | |
895 | (eval '(let () (define x #t)) | |
a264c013 DH |
896 | (interaction-environment))) |
897 | ||
898 | (pass-if "unmemoization" | |
899 | (eval '(begin | |
900 | (define (foo) | |
901 | (define (bar) | |
902 | 'ok) | |
903 | (bar)) | |
904 | (foo) | |
9ecac781 | 905 | (matches? |
a264c013 | 906 | (procedure-source foo) |
9ecac781 AW |
907 | (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))) |
908 | (current-module)))) | |
aa498d0c | 909 | |
08c608e1 DH |
910 | (with-test-prefix "set!" |
911 | ||
aa498d0c DH |
912 | (with-test-prefix "unmemoization" |
913 | ||
914 | (pass-if "normal set!" | |
915 | (let ((foo (lambda (x) (set! x (+ 1 x))))) | |
916 | (foo 1) ; make sure, memoization has been performed | |
9ecac781 AW |
917 | (matches? (procedure-source foo) |
918 | (lambda (_) (set! _ (+ 1 _))))))) | |
aa498d0c | 919 | |
08c608e1 DH |
920 | (with-test-prefix "missing or extra expressions" |
921 | ||
922 | (pass-if-exception "(set!)" | |
9ecac781 | 923 | exception:bad-set! |
4dce3c96 DH |
924 | (eval '(set!) |
925 | (interaction-environment))) | |
08c608e1 DH |
926 | |
927 | (pass-if-exception "(set! 1)" | |
9ecac781 | 928 | exception:bad-set! |
4dce3c96 DH |
929 | (eval '(set! 1) |
930 | (interaction-environment))) | |
08c608e1 DH |
931 | |
932 | (pass-if-exception "(set! 1 2 3)" | |
9ecac781 | 933 | exception:bad-set! |
4dce3c96 DH |
934 | (eval '(set! 1 2 3) |
935 | (interaction-environment)))) | |
08c608e1 DH |
936 | |
937 | (with-test-prefix "bad variable" | |
938 | ||
939 | (pass-if-exception "(set! \"\" #t)" | |
9ecac781 | 940 | exception:bad-set! |
4dce3c96 DH |
941 | (eval '(set! "" #t) |
942 | (interaction-environment))) | |
08c608e1 DH |
943 | |
944 | (pass-if-exception "(set! 1 #t)" | |
9ecac781 | 945 | exception:bad-set! |
4dce3c96 DH |
946 | (eval '(set! 1 #t) |
947 | (interaction-environment))) | |
08c608e1 DH |
948 | |
949 | (pass-if-exception "(set! #t #f)" | |
9ecac781 | 950 | exception:bad-set! |
4dce3c96 DH |
951 | (eval '(set! #t #f) |
952 | (interaction-environment))) | |
08c608e1 DH |
953 | |
954 | (pass-if-exception "(set! #f #t)" | |
9ecac781 | 955 | exception:bad-set! |
4dce3c96 DH |
956 | (eval '(set! #f #t) |
957 | (interaction-environment))) | |
08c608e1 | 958 | |
96dfea7d | 959 | (pass-if-exception "(set! #\\space #f)" |
9ecac781 | 960 | exception:bad-set! |
4dce3c96 DH |
961 | (eval '(set! #\space #f) |
962 | (interaction-environment))))) | |
08c608e1 | 963 | |
08c608e1 DH |
964 | (with-test-prefix "quote" |
965 | ||
966 | (with-test-prefix "missing or extra expression" | |
967 | ||
968 | (pass-if-exception "(quote)" | |
9ecac781 | 969 | exception:bad-quote |
4dce3c96 DH |
970 | (eval '(quote) |
971 | (interaction-environment))) | |
08c608e1 DH |
972 | |
973 | (pass-if-exception "(quote a b)" | |
9ecac781 | 974 | exception:bad-quote |
4dce3c96 DH |
975 | (eval '(quote a b) |
976 | (interaction-environment))))) | |
2798ba71 KR |
977 | |
978 | (with-test-prefix "while" | |
979 | ||
980 | (define (unreachable) | |
981 | (error "unreachable code has been reached!")) | |
982 | ||
2798ba71 KR |
983 | ;; Return a new procedure COND which when called (COND) will return #t the |
984 | ;; first N times, then #f, then any further call is an error. N=0 is | |
985 | ;; allowed, in which case #f is returned by the first call. | |
986 | (define (make-iterations-cond n) | |
987 | (lambda () | |
988 | (cond ((not n) | |
989 | (error "oops, condition re-tested after giving false")) | |
990 | ((= 0 n) | |
991 | (set! n #f) | |
992 | #f) | |
993 | (else | |
994 | (set! n (1- n)) | |
995 | #t)))) | |
996 | ||
997 | ||
998 | (pass-if-exception "too few args" exception:wrong-num-args | |
d6e04e7c | 999 | (eval '(while) (interaction-environment))) |
2798ba71 KR |
1000 | |
1001 | (with-test-prefix "empty body" | |
1002 | (do ((n 0 (1+ n))) | |
1003 | ((> n 5)) | |
1004 | (pass-if n | |
ce09ee19 AW |
1005 | (eval `(letrec ((make-iterations-cond |
1006 | (lambda (n) | |
1007 | (lambda () | |
1008 | (cond ((not n) | |
1009 | (error "oops, condition re-tested after giving false")) | |
1010 | ((= 0 n) | |
1011 | (set! n #f) | |
1012 | #f) | |
1013 | (else | |
1014 | (set! n (1- n)) | |
1015 | #t)))))) | |
1016 | (let ((cond (make-iterations-cond ,n))) | |
1017 | (while (cond)) | |
1018 | #t)) | |
1019 | (interaction-environment))))) | |
2798ba71 KR |
1020 | |
1021 | (pass-if "initially false" | |
1022 | (while #f | |
1023 | (unreachable)) | |
1024 | #t) | |
1025 | ||
2798ba71 KR |
1026 | (with-test-prefix "iterations" |
1027 | (do ((n 0 (1+ n))) | |
1028 | ((> n 5)) | |
1029 | (pass-if n | |
1030 | (let ((cond (make-iterations-cond n)) | |
1031 | (i 0)) | |
1032 | (while (cond) | |
1033 | (set! i (1+ i))) | |
1034 | (= i n))))) | |
1035 | ||
1036 | (with-test-prefix "break" | |
1037 | ||
1038 | (pass-if-exception "too many args" exception:wrong-num-args | |
9ecac781 AW |
1039 | (eval '(while #t |
1040 | (break 1)) | |
1041 | (interaction-environment))) | |
2798ba71 KR |
1042 | |
1043 | (with-test-prefix "from cond" | |
1044 | (pass-if "first" | |
1045 | (while (begin | |
1046 | (break) | |
1047 | (unreachable)) | |
1048 | (unreachable)) | |
1049 | #t) | |
1050 | ||
1051 | (do ((n 0 (1+ n))) | |
1052 | ((> n 5)) | |
1053 | (pass-if n | |
1054 | (let ((cond (make-iterations-cond n)) | |
1055 | (i 0)) | |
1056 | (while (if (cond) | |
1057 | #t | |
1058 | (begin | |
1059 | (break) | |
1060 | (unreachable))) | |
1061 | (set! i (1+ i))) | |
1062 | (= i n))))) | |
1063 | ||
1064 | (with-test-prefix "from body" | |
1065 | (pass-if "first" | |
1066 | (while #t | |
1067 | (break) | |
1068 | (unreachable)) | |
1069 | #t) | |
1070 | ||
1071 | (do ((n 0 (1+ n))) | |
1072 | ((> n 5)) | |
1073 | (pass-if n | |
1074 | (let ((cond (make-iterations-cond n)) | |
1075 | (i 0)) | |
1076 | (while #t | |
1077 | (if (not (cond)) | |
1078 | (begin | |
1079 | (break) | |
1080 | (unreachable))) | |
1081 | (set! i (1+ i))) | |
1082 | (= i n))))) | |
1083 | ||
1084 | (pass-if "from nested" | |
1085 | (while #t | |
1086 | (let ((outer-break break)) | |
1087 | (while #t | |
1088 | (outer-break) | |
1089 | (unreachable))) | |
1090 | (unreachable)) | |
cc08aafd KR |
1091 | #t) |
1092 | ||
1093 | (pass-if "from recursive" | |
1094 | (let ((outer-break #f)) | |
1095 | (define (r n) | |
1096 | (while #t | |
1097 | (if (eq? n 'outer) | |
1098 | (begin | |
1099 | (set! outer-break break) | |
1100 | (r 'inner)) | |
1101 | (begin | |
1102 | (outer-break) | |
1103 | (unreachable)))) | |
1104 | (if (eq? n 'inner) | |
1105 | (error "broke only from inner loop"))) | |
1106 | (r 'outer)) | |
2798ba71 KR |
1107 | #t)) |
1108 | ||
1109 | (with-test-prefix "continue" | |
1110 | ||
1111 | (pass-if-exception "too many args" exception:wrong-num-args | |
9ecac781 AW |
1112 | (eval '(while #t |
1113 | (continue 1)) | |
1114 | (interaction-environment))) | |
2798ba71 KR |
1115 | |
1116 | (with-test-prefix "from cond" | |
1117 | (do ((n 0 (1+ n))) | |
1118 | ((> n 5)) | |
1119 | (pass-if n | |
1120 | (let ((cond (make-iterations-cond n)) | |
1121 | (i 0)) | |
1122 | (while (if (cond) | |
1123 | (begin | |
1124 | (set! i (1+ i)) | |
1125 | (continue) | |
1126 | (unreachable)) | |
1127 | #f) | |
1128 | (unreachable)) | |
1129 | (= i n))))) | |
1130 | ||
1131 | (with-test-prefix "from body" | |
1132 | (do ((n 0 (1+ n))) | |
1133 | ((> n 5)) | |
1134 | (pass-if n | |
1135 | (let ((cond (make-iterations-cond n)) | |
1136 | (i 0)) | |
1137 | (while (cond) | |
1138 | (set! i (1+ i)) | |
1139 | (continue) | |
1140 | (unreachable)) | |
1141 | (= i n))))) | |
1142 | ||
1143 | (pass-if "from nested" | |
1144 | (let ((cond (make-iterations-cond 3))) | |
1145 | (while (cond) | |
1146 | (let ((outer-continue continue)) | |
1147 | (while #t | |
1148 | (outer-continue) | |
1149 | (unreachable))))) | |
cc08aafd KR |
1150 | #t) |
1151 | ||
1152 | (pass-if "from recursive" | |
1153 | (let ((outer-continue #f)) | |
1154 | (define (r n) | |
1155 | (let ((cond (make-iterations-cond 3)) | |
1156 | (first #t)) | |
1157 | (while (begin | |
1158 | (if (and (not first) | |
1159 | (eq? n 'inner)) | |
1160 | (error "continued only to inner loop")) | |
1161 | (cond)) | |
1162 | (set! first #f) | |
1163 | (if (eq? n 'outer) | |
1164 | (begin | |
1165 | (set! outer-continue continue) | |
1166 | (r 'inner)) | |
1167 | (begin | |
1168 | (outer-continue) | |
1169 | (unreachable)))))) | |
1170 | (r 'outer)) | |
2798ba71 | 1171 | #t))) |