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