Commit | Line | Data |
---|---|---|
08c608e1 DH |
1 | ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- |
2 | ;;;; | |
f78a1cce | 3 | ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, |
2d6a3144 | 4 | ;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
f78a1cce | 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 | 21 | #:use-module (ice-9 regex) |
1624e149 | 22 | #:use-module (ice-9 local-eval) |
e75184d5 | 23 | #:use-module (test-suite lib)) |
08c608e1 | 24 | |
2a6f7afe | 25 | |
40b36cfb | 26 | (define exception:generic-syncase-error |
e75184d5 | 27 | "source expression failed to match") |
40b36cfb | 28 | (define exception:unexpected-syntax |
e75184d5 | 29 | "unexpected syntax") |
40b36cfb | 30 | |
2a6f7afe | 31 | (define exception:bad-expression |
e75184d5 | 32 | "Bad expression") |
cc56ba80 | 33 | |
21628685 | 34 | (define exception:missing/extra-expr |
e75184d5 | 35 | "Missing or extra expression") |
cc56ba80 | 36 | (define exception:missing-expr |
e75184d5 | 37 | "Missing expression") |
ced8edb0 | 38 | (define exception:missing-body-expr |
e75184d5 | 39 | "no expressions in body") |
cc56ba80 | 40 | (define exception:extra-expr |
e75184d5 | 41 | "Extra expression") |
89bff2fc | 42 | (define exception:illegal-empty-combination |
e75184d5 | 43 | "Illegal empty combination") |
cc56ba80 | 44 | |
dc1eed52 | 45 | (define exception:bad-lambda |
e75184d5 | 46 | "bad lambda") |
dc1eed52 | 47 | (define exception:bad-let |
e75184d5 | 48 | "bad let$") |
dc1eed52 | 49 | (define exception:bad-letrec |
e75184d5 | 50 | "bad letrec$") |
5f8c55ce | 51 | (define exception:bad-letrec* |
e75184d5 | 52 | "bad letrec\\*$") |
9ecac781 | 53 | (define exception:bad-set! |
e75184d5 | 54 | "bad set!") |
9ecac781 | 55 | (define exception:bad-quote |
e75184d5 | 56 | '(quote . "bad syntax")) |
08c608e1 | 57 | (define exception:bad-bindings |
e75184d5 | 58 | "Bad bindings") |
d6754c23 | 59 | (define exception:bad-binding |
e75184d5 | 60 | "Bad binding") |
d6754c23 | 61 | (define exception:duplicate-binding |
e75184d5 | 62 | "duplicate bound variable") |
08c608e1 | 63 | (define exception:bad-body |
e75184d5 | 64 | "^bad body") |
08c608e1 | 65 | (define exception:bad-formals |
e75184d5 | 66 | "invalid argument list") |
03a3e941 | 67 | (define exception:bad-formal |
e75184d5 | 68 | "Bad formal") |
c89222f8 | 69 | (define exception:duplicate-formals |
e75184d5 | 70 | "duplicate identifier in argument list") |
cc56ba80 | 71 | |
2a6f7afe | 72 | (define exception:missing-clauses |
e75184d5 | 73 | "Missing clauses") |
609a8b86 | 74 | (define exception:misplaced-else-clause |
e75184d5 | 75 | "Misplaced else clause") |
2a6f7afe | 76 | (define exception:bad-case-clause |
e75184d5 | 77 | "Bad case clause") |
2a6f7afe | 78 | (define exception:bad-case-labels |
e75184d5 | 79 | "Bad case labels") |
609a8b86 | 80 | (define exception:bad-cond-clause |
e75184d5 | 81 | "Bad cond clause") |
cc56ba80 | 82 | |
10e69149 | 83 | (define exception:too-many-args |
e75184d5 | 84 | "too many arguments") |
b00c9b22 AW |
85 | (define exception:wrong-number-of-values |
86 | '(wrong-number-of-args . "number of (values)|(arguments)")) | |
9133716f LC |
87 | (define exception:zero-expression-sequence |
88 | "sequence of zero expressions") | |
e75184d5 AW |
89 | |
90 | ||
91 | ;; (put 'pass-if-syntax-error 'scheme-indent-function 1) | |
92 | (define-syntax pass-if-syntax-error | |
93 | (syntax-rules () | |
94 | ((_ name pat exp) | |
95 | (pass-if name | |
96 | (catch 'syntax-error | |
f78a1cce | 97 | (lambda () exp (error "expected syntax-error exception")) |
e75184d5 AW |
98 | (lambda (k who what where form . maybe-subform) |
99 | (if (if (pair? pat) | |
100 | (and (eq? who (car pat)) | |
101 | (string-match (cdr pat) what)) | |
102 | (string-match pat what)) | |
103 | #t | |
104 | (error "unexpected syntax-error exception" what pat)))))))) | |
08c608e1 DH |
105 | |
106 | (with-test-prefix "expressions" | |
107 | ||
d6e04e7c DH |
108 | (with-test-prefix "Bad argument list" |
109 | ||
e75184d5 | 110 | (pass-if-syntax-error "improper argument list of length 1" |
40b36cfb | 111 | exception:generic-syncase-error |
d6e04e7c DH |
112 | (eval '(let ((foo (lambda (x y) #t))) |
113 | (foo . 1)) | |
114 | (interaction-environment))) | |
115 | ||
e75184d5 | 116 | (pass-if-syntax-error "improper argument list of length 2" |
40b36cfb | 117 | exception:generic-syncase-error |
d6e04e7c DH |
118 | (eval '(let ((foo (lambda (x y) #t))) |
119 | (foo 1 . 2)) | |
120 | (interaction-environment)))) | |
121 | ||
08c608e1 DH |
122 | (with-test-prefix "missing or extra expression" |
123 | ||
124 | ;; R5RS says: | |
125 | ;; *Note:* In many dialects of Lisp, the empty combination, (), | |
126 | ;; is a legitimate expression. In Scheme, combinations must | |
127 | ;; have at least one subexpression, so () is not a syntactically | |
128 | ;; valid expression. | |
1c54a87c MV |
129 | |
130 | ;; Fixed on 2001-3-3 | |
e75184d5 | 131 | (pass-if-syntax-error "empty parentheses \"()\"" |
40b36cfb | 132 | exception:unexpected-syntax |
d6e04e7c DH |
133 | (eval '() |
134 | (interaction-environment))))) | |
08c608e1 | 135 | |
7171f1ab DH |
136 | (with-test-prefix "quote" |
137 | #t) | |
138 | ||
139 | (with-test-prefix "quasiquote" | |
140 | ||
141 | (with-test-prefix "unquote" | |
142 | ||
143 | (pass-if "repeated execution" | |
144 | (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i))))) | |
145 | (and (equal? (foo) '(1)) (equal? (foo) '(2)))))) | |
146 | ||
147 | (with-test-prefix "unquote-splicing" | |
148 | ||
36ad2533 AW |
149 | (pass-if "extra arguments" |
150 | (equal? (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) | |
151 | (interaction-environment)) | |
152 | '(1 2 3 4))))) | |
7171f1ab DH |
153 | |
154 | (with-test-prefix "begin" | |
155 | ||
9133716f | 156 | (pass-if "valid (begin)" |
ce09ee19 | 157 | (eval '(begin (begin) #t) (interaction-environment))) |
7171f1ab | 158 | |
dc65d1cf | 159 | (if (not (include-deprecated-features)) |
9133716f LC |
160 | (pass-if-syntax-error "invalid (begin)" |
161 | exception:zero-expression-sequence | |
dc65d1cf | 162 | (eval '(begin (if #t (begin)) #t) (interaction-environment))))) |
7171f1ab | 163 | |
02604212 | 164 | (define-syntax matches? |
31fe1202 | 165 | (syntax-rules (<>) |
02604212 AW |
166 | ((_ (op arg ...) pat) (let ((x (op arg ...))) |
167 | (matches? x pat))) | |
168 | ((_ x ()) (null? x)) | |
169 | ((_ x (a . b)) (and (pair? x) | |
170 | (matches? (car x) a) | |
171 | (matches? (cdr x) b))) | |
31fe1202 | 172 | ((_ x <>) #t) |
02604212 AW |
173 | ((_ x pat) (equal? x 'pat)))) |
174 | ||
08c608e1 DH |
175 | (with-test-prefix "lambda" |
176 | ||
177 | (with-test-prefix "bad formals" | |
178 | ||
e75184d5 | 179 | (pass-if-syntax-error "(lambda)" |
dc1eed52 | 180 | exception:bad-lambda |
d6e04e7c DH |
181 | (eval '(lambda) |
182 | (interaction-environment))) | |
ea6c2147 | 183 | |
e75184d5 | 184 | (pass-if-syntax-error "(lambda . \"foo\")" |
dc1eed52 | 185 | exception:bad-lambda |
d6e04e7c DH |
186 | (eval '(lambda . "foo") |
187 | (interaction-environment))) | |
ea6c2147 | 188 | |
e75184d5 | 189 | (pass-if-syntax-error "(lambda \"foo\")" |
dc1eed52 | 190 | exception:bad-lambda |
d6e04e7c DH |
191 | (eval '(lambda "foo") |
192 | (interaction-environment))) | |
ea6c2147 | 193 | |
e75184d5 | 194 | (pass-if-syntax-error "(lambda \"foo\" #f)" |
ea6c2147 | 195 | exception:bad-formals |
4dce3c96 DH |
196 | (eval '(lambda "foo" #f) |
197 | (interaction-environment))) | |
ea6c2147 | 198 | |
e75184d5 | 199 | (pass-if-syntax-error "(lambda (x 1) 2)" |
dc1eed52 | 200 | exception:bad-formals |
d6e04e7c DH |
201 | (eval '(lambda (x 1) 2) |
202 | (interaction-environment))) | |
08c608e1 | 203 | |
e75184d5 | 204 | (pass-if-syntax-error "(lambda (1 x) 2)" |
dc1eed52 | 205 | exception:bad-formals |
d6e04e7c DH |
206 | (eval '(lambda (1 x) 2) |
207 | (interaction-environment))) | |
08c608e1 | 208 | |
e75184d5 | 209 | (pass-if-syntax-error "(lambda (x \"a\") 2)" |
dc1eed52 | 210 | exception:bad-formals |
d6e04e7c DH |
211 | (eval '(lambda (x "a") 2) |
212 | (interaction-environment))) | |
08c608e1 | 213 | |
e75184d5 | 214 | (pass-if-syntax-error "(lambda (\"a\" x) 2)" |
dc1eed52 | 215 | exception:bad-formals |
d6e04e7c DH |
216 | (eval '(lambda ("a" x) 2) |
217 | (interaction-environment)))) | |
08c608e1 | 218 | |
1c54a87c MV |
219 | (with-test-prefix "duplicate formals" |
220 | ||
221 | ;; Fixed on 2001-3-3 | |
e75184d5 | 222 | (pass-if-syntax-error "(lambda (x x) 1)" |
c89222f8 | 223 | exception:duplicate-formals |
d6e04e7c DH |
224 | (eval '(lambda (x x) 1) |
225 | (interaction-environment))) | |
08c608e1 | 226 | |
1c54a87c | 227 | ;; Fixed on 2001-3-3 |
e75184d5 | 228 | (pass-if-syntax-error "(lambda (x x x) 1)" |
c89222f8 | 229 | exception:duplicate-formals |
d6e04e7c DH |
230 | (eval '(lambda (x x x) 1) |
231 | (interaction-environment)))) | |
7171f1ab DH |
232 | |
233 | (with-test-prefix "bad body" | |
234 | ||
e75184d5 | 235 | (pass-if-syntax-error "(lambda ())" |
dc1eed52 | 236 | exception:bad-lambda |
d6e04e7c DH |
237 | (eval '(lambda ()) |
238 | (interaction-environment))))) | |
08c608e1 DH |
239 | |
240 | (with-test-prefix "let" | |
241 | ||
242 | (with-test-prefix "bindings" | |
243 | ||
244 | (pass-if-exception "late binding" | |
245 | exception:unbound-var | |
246 | (let ((x 1) (y x)) y))) | |
247 | ||
7171f1ab | 248 | (with-test-prefix "bad bindings" |
08c608e1 | 249 | |
e75184d5 | 250 | (pass-if-syntax-error "(let)" |
dc1eed52 | 251 | exception:bad-let |
d6e04e7c DH |
252 | (eval '(let) |
253 | (interaction-environment))) | |
08c608e1 | 254 | |
e75184d5 | 255 | (pass-if-syntax-error "(let 1)" |
dc1eed52 | 256 | exception:bad-let |
d6e04e7c DH |
257 | (eval '(let 1) |
258 | (interaction-environment))) | |
08c608e1 | 259 | |
e75184d5 | 260 | (pass-if-syntax-error "(let (x))" |
dc1eed52 | 261 | exception:bad-let |
d6e04e7c DH |
262 | (eval '(let (x)) |
263 | (interaction-environment))) | |
08c608e1 | 264 | |
e75184d5 | 265 | (pass-if-syntax-error "(let ((x)))" |
dc1eed52 | 266 | exception:bad-let |
d6e04e7c DH |
267 | (eval '(let ((x))) |
268 | (interaction-environment))) | |
08c608e1 | 269 | |
e75184d5 | 270 | (pass-if-syntax-error "(let (x) 1)" |
dc1eed52 | 271 | exception:bad-let |
d6e04e7c DH |
272 | (eval '(let (x) 1) |
273 | (interaction-environment))) | |
08c608e1 | 274 | |
e75184d5 | 275 | (pass-if-syntax-error "(let ((x)) 3)" |
dc1eed52 | 276 | exception:bad-let |
d6e04e7c DH |
277 | (eval '(let ((x)) 3) |
278 | (interaction-environment))) | |
08c608e1 | 279 | |
e75184d5 | 280 | (pass-if-syntax-error "(let ((x 1) y) x)" |
dc1eed52 | 281 | exception:bad-let |
d6e04e7c DH |
282 | (eval '(let ((x 1) y) x) |
283 | (interaction-environment))) | |
08c608e1 | 284 | |
e75184d5 | 285 | (pass-if-syntax-error "(let ((1 2)) 3)" |
dc1eed52 | 286 | exception:bad-let |
4dce3c96 DH |
287 | (eval '(let ((1 2)) 3) |
288 | (interaction-environment)))) | |
08c608e1 | 289 | |
c0ed1605 MV |
290 | (with-test-prefix "duplicate bindings" |
291 | ||
e75184d5 | 292 | (pass-if-syntax-error "(let ((x 1) (x 2)) x)" |
d6754c23 | 293 | exception:duplicate-binding |
d6e04e7c DH |
294 | (eval '(let ((x 1) (x 2)) x) |
295 | (interaction-environment)))) | |
7171f1ab DH |
296 | |
297 | (with-test-prefix "bad body" | |
298 | ||
e75184d5 | 299 | (pass-if-syntax-error "(let ())" |
dc1eed52 | 300 | exception:bad-let |
d6e04e7c DH |
301 | (eval '(let ()) |
302 | (interaction-environment))) | |
7171f1ab | 303 | |
e75184d5 | 304 | (pass-if-syntax-error "(let ((x 1)))" |
dc1eed52 | 305 | exception:bad-let |
d6e04e7c DH |
306 | (eval '(let ((x 1))) |
307 | (interaction-environment))))) | |
08c608e1 DH |
308 | |
309 | (with-test-prefix "named let" | |
310 | ||
7171f1ab DH |
311 | (with-test-prefix "initializers" |
312 | ||
313 | (pass-if "evaluated in outer environment" | |
314 | (let ((f -)) | |
315 | (eqv? (let f ((n (f 1))) n) -1)))) | |
316 | ||
317 | (with-test-prefix "bad bindings" | |
318 | ||
e75184d5 | 319 | (pass-if-syntax-error "(let x (y))" |
dc1eed52 | 320 | exception:bad-let |
d6e04e7c DH |
321 | (eval '(let x (y)) |
322 | (interaction-environment)))) | |
7171f1ab | 323 | |
08c608e1 DH |
324 | (with-test-prefix "bad body" |
325 | ||
e75184d5 | 326 | (pass-if-syntax-error "(let x ())" |
dc1eed52 | 327 | exception:bad-let |
d6e04e7c DH |
328 | (eval '(let x ()) |
329 | (interaction-environment))) | |
08c608e1 | 330 | |
e75184d5 | 331 | (pass-if-syntax-error "(let x ((y 1)))" |
dc1eed52 | 332 | exception:bad-let |
d6e04e7c DH |
333 | (eval '(let x ((y 1))) |
334 | (interaction-environment))))) | |
08c608e1 DH |
335 | |
336 | (with-test-prefix "let*" | |
337 | ||
e1a7b2ce DH |
338 | (with-test-prefix "bindings" |
339 | ||
340 | (pass-if "(let* ((x 1) (x 2)) ...)" | |
341 | (let* ((x 1) (x 2)) | |
342 | (= x 2))) | |
343 | ||
344 | (pass-if "(let* ((x 1) (x x)) ...)" | |
345 | (let* ((x 1) (x x)) | |
aa498d0c DH |
346 | (= x 1))) |
347 | ||
348 | (pass-if "(let ((x 1) (y 2)) (let* () ...))" | |
349 | (let ((x 1) (y 2)) | |
350 | (let* () | |
351 | (and (= x 1) (= y 2)))))) | |
e1a7b2ce | 352 | |
7171f1ab | 353 | (with-test-prefix "bad bindings" |
08c608e1 | 354 | |
e75184d5 | 355 | (pass-if-syntax-error "(let*)" |
dc1eed52 | 356 | exception:generic-syncase-error |
d6e04e7c DH |
357 | (eval '(let*) |
358 | (interaction-environment))) | |
08c608e1 | 359 | |
e75184d5 | 360 | (pass-if-syntax-error "(let* 1)" |
dc1eed52 | 361 | exception:generic-syncase-error |
d6e04e7c DH |
362 | (eval '(let* 1) |
363 | (interaction-environment))) | |
08c608e1 | 364 | |
e75184d5 | 365 | (pass-if-syntax-error "(let* (x))" |
dc1eed52 | 366 | exception:generic-syncase-error |
d6e04e7c DH |
367 | (eval '(let* (x)) |
368 | (interaction-environment))) | |
08c608e1 | 369 | |
e75184d5 | 370 | (pass-if-syntax-error "(let* (x) 1)" |
dc1eed52 | 371 | exception:generic-syncase-error |
d6e04e7c DH |
372 | (eval '(let* (x) 1) |
373 | (interaction-environment))) | |
08c608e1 | 374 | |
e75184d5 | 375 | (pass-if-syntax-error "(let* ((x)) 3)" |
dc1eed52 | 376 | exception:generic-syncase-error |
d6e04e7c DH |
377 | (eval '(let* ((x)) 3) |
378 | (interaction-environment))) | |
08c608e1 | 379 | |
e75184d5 | 380 | (pass-if-syntax-error "(let* ((x 1) y) x)" |
dc1eed52 | 381 | exception:generic-syncase-error |
d6e04e7c DH |
382 | (eval '(let* ((x 1) y) x) |
383 | (interaction-environment))) | |
08c608e1 | 384 | |
e75184d5 | 385 | (pass-if-syntax-error "(let* x ())" |
dc1eed52 | 386 | exception:generic-syncase-error |
4dce3c96 DH |
387 | (eval '(let* x ()) |
388 | (interaction-environment))) | |
08c608e1 | 389 | |
e75184d5 | 390 | (pass-if-syntax-error "(let* x (y))" |
dc1eed52 | 391 | exception:generic-syncase-error |
4dce3c96 DH |
392 | (eval '(let* x (y)) |
393 | (interaction-environment))) | |
08c608e1 | 394 | |
e75184d5 | 395 | (pass-if-syntax-error "(let* ((1 2)) 3)" |
dc1eed52 | 396 | exception:generic-syncase-error |
4dce3c96 DH |
397 | (eval '(let* ((1 2)) 3) |
398 | (interaction-environment)))) | |
7171f1ab DH |
399 | |
400 | (with-test-prefix "bad body" | |
401 | ||
e75184d5 | 402 | (pass-if-syntax-error "(let* ())" |
dc1eed52 | 403 | exception:generic-syncase-error |
d6e04e7c DH |
404 | (eval '(let* ()) |
405 | (interaction-environment))) | |
7171f1ab | 406 | |
e75184d5 | 407 | (pass-if-syntax-error "(let* ((x 1)))" |
dc1eed52 | 408 | exception:generic-syncase-error |
d6e04e7c DH |
409 | (eval '(let* ((x 1))) |
410 | (interaction-environment))))) | |
08c608e1 DH |
411 | |
412 | (with-test-prefix "letrec" | |
413 | ||
414 | (with-test-prefix "bindings" | |
415 | ||
e75184d5 | 416 | (pass-if-syntax-error "initial bindings are undefined" |
0ac46745 | 417 | exception:used-before-defined |
08c608e1 | 418 | (let ((x 1)) |
5f161164 AW |
419 | ;; FIXME: the memoizer does initialize the var to undefined, but |
420 | ;; the Scheme evaluator has no way of checking what's an | |
421 | ;; undefined value. Not sure how to do this. | |
422 | (throw 'unresolved) | |
08c608e1 DH |
423 | (letrec ((x 1) (y x)) y)))) |
424 | ||
7171f1ab | 425 | (with-test-prefix "bad bindings" |
08c608e1 | 426 | |
e75184d5 | 427 | (pass-if-syntax-error "(letrec)" |
dc1eed52 | 428 | exception:bad-letrec |
d6e04e7c DH |
429 | (eval '(letrec) |
430 | (interaction-environment))) | |
08c608e1 | 431 | |
e75184d5 | 432 | (pass-if-syntax-error "(letrec 1)" |
dc1eed52 | 433 | exception:bad-letrec |
d6e04e7c DH |
434 | (eval '(letrec 1) |
435 | (interaction-environment))) | |
08c608e1 | 436 | |
e75184d5 | 437 | (pass-if-syntax-error "(letrec (x))" |
dc1eed52 | 438 | exception:bad-letrec |
d6e04e7c DH |
439 | (eval '(letrec (x)) |
440 | (interaction-environment))) | |
08c608e1 | 441 | |
e75184d5 | 442 | (pass-if-syntax-error "(letrec (x) 1)" |
dc1eed52 | 443 | exception:bad-letrec |
d6e04e7c DH |
444 | (eval '(letrec (x) 1) |
445 | (interaction-environment))) | |
08c608e1 | 446 | |
e75184d5 | 447 | (pass-if-syntax-error "(letrec ((x)) 3)" |
dc1eed52 | 448 | exception:bad-letrec |
d6e04e7c DH |
449 | (eval '(letrec ((x)) 3) |
450 | (interaction-environment))) | |
08c608e1 | 451 | |
e75184d5 | 452 | (pass-if-syntax-error "(letrec ((x 1) y) x)" |
dc1eed52 | 453 | exception:bad-letrec |
d6e04e7c DH |
454 | (eval '(letrec ((x 1) y) x) |
455 | (interaction-environment))) | |
08c608e1 | 456 | |
e75184d5 | 457 | (pass-if-syntax-error "(letrec x ())" |
dc1eed52 | 458 | exception:bad-letrec |
4dce3c96 DH |
459 | (eval '(letrec x ()) |
460 | (interaction-environment))) | |
08c608e1 | 461 | |
e75184d5 | 462 | (pass-if-syntax-error "(letrec x (y))" |
dc1eed52 | 463 | exception:bad-letrec |
4dce3c96 DH |
464 | (eval '(letrec x (y)) |
465 | (interaction-environment))) | |
08c608e1 | 466 | |
e75184d5 | 467 | (pass-if-syntax-error "(letrec ((1 2)) 3)" |
dc1eed52 | 468 | exception:bad-letrec |
4dce3c96 DH |
469 | (eval '(letrec ((1 2)) 3) |
470 | (interaction-environment)))) | |
08c608e1 | 471 | |
c0ed1605 MV |
472 | (with-test-prefix "duplicate bindings" |
473 | ||
e75184d5 | 474 | (pass-if-syntax-error "(letrec ((x 1) (x 2)) x)" |
d6754c23 | 475 | exception:duplicate-binding |
d6e04e7c DH |
476 | (eval '(letrec ((x 1) (x 2)) x) |
477 | (interaction-environment)))) | |
7171f1ab DH |
478 | |
479 | (with-test-prefix "bad body" | |
480 | ||
e75184d5 | 481 | (pass-if-syntax-error "(letrec ())" |
dc1eed52 | 482 | exception:bad-letrec |
d6e04e7c DH |
483 | (eval '(letrec ()) |
484 | (interaction-environment))) | |
7171f1ab | 485 | |
e75184d5 | 486 | (pass-if-syntax-error "(letrec ((x 1)))" |
dc1eed52 | 487 | exception:bad-letrec |
d6e04e7c DH |
488 | (eval '(letrec ((x 1))) |
489 | (interaction-environment))))) | |
08c608e1 | 490 | |
5f8c55ce AW |
491 | (with-test-prefix "letrec*" |
492 | ||
493 | (with-test-prefix "bindings" | |
494 | ||
e75184d5 | 495 | (pass-if-syntax-error "initial bindings are undefined" |
5f8c55ce AW |
496 | exception:used-before-defined |
497 | (begin | |
498 | ;; FIXME: the memoizer does initialize the var to undefined, but | |
499 | ;; the Scheme evaluator has no way of checking what's an | |
500 | ;; undefined value. Not sure how to do this. | |
501 | (throw 'unresolved) | |
502 | (letrec* ((x y) (y 1)) y)))) | |
503 | ||
504 | (with-test-prefix "bad bindings" | |
505 | ||
e75184d5 | 506 | (pass-if-syntax-error "(letrec*)" |
5f8c55ce AW |
507 | exception:bad-letrec* |
508 | (eval '(letrec*) | |
509 | (interaction-environment))) | |
510 | ||
e75184d5 | 511 | (pass-if-syntax-error "(letrec* 1)" |
5f8c55ce AW |
512 | exception:bad-letrec* |
513 | (eval '(letrec* 1) | |
514 | (interaction-environment))) | |
515 | ||
e75184d5 | 516 | (pass-if-syntax-error "(letrec* (x))" |
5f8c55ce AW |
517 | exception:bad-letrec* |
518 | (eval '(letrec* (x)) | |
519 | (interaction-environment))) | |
520 | ||
e75184d5 | 521 | (pass-if-syntax-error "(letrec* (x) 1)" |
5f8c55ce AW |
522 | exception:bad-letrec* |
523 | (eval '(letrec* (x) 1) | |
524 | (interaction-environment))) | |
525 | ||
e75184d5 | 526 | (pass-if-syntax-error "(letrec* ((x)) 3)" |
5f8c55ce AW |
527 | exception:bad-letrec* |
528 | (eval '(letrec* ((x)) 3) | |
529 | (interaction-environment))) | |
530 | ||
e75184d5 | 531 | (pass-if-syntax-error "(letrec* ((x 1) y) x)" |
5f8c55ce AW |
532 | exception:bad-letrec* |
533 | (eval '(letrec* ((x 1) y) x) | |
534 | (interaction-environment))) | |
535 | ||
e75184d5 | 536 | (pass-if-syntax-error "(letrec* x ())" |
5f8c55ce AW |
537 | exception:bad-letrec* |
538 | (eval '(letrec* x ()) | |
539 | (interaction-environment))) | |
540 | ||
e75184d5 | 541 | (pass-if-syntax-error "(letrec* x (y))" |
5f8c55ce AW |
542 | exception:bad-letrec* |
543 | (eval '(letrec* x (y)) | |
544 | (interaction-environment))) | |
545 | ||
e75184d5 | 546 | (pass-if-syntax-error "(letrec* ((1 2)) 3)" |
5f8c55ce AW |
547 | exception:bad-letrec* |
548 | (eval '(letrec* ((1 2)) 3) | |
549 | (interaction-environment)))) | |
550 | ||
551 | (with-test-prefix "duplicate bindings" | |
552 | ||
e75184d5 | 553 | (pass-if-syntax-error "(letrec* ((x 1) (x 2)) x)" |
5f8c55ce AW |
554 | exception:duplicate-binding |
555 | (eval '(letrec* ((x 1) (x 2)) x) | |
556 | (interaction-environment)))) | |
557 | ||
558 | (with-test-prefix "bad body" | |
559 | ||
e75184d5 | 560 | (pass-if-syntax-error "(letrec* ())" |
5f8c55ce AW |
561 | exception:bad-letrec* |
562 | (eval '(letrec* ()) | |
563 | (interaction-environment))) | |
564 | ||
e75184d5 | 565 | (pass-if-syntax-error "(letrec* ((x 1)))" |
5f8c55ce AW |
566 | exception:bad-letrec* |
567 | (eval '(letrec* ((x 1))) | |
568 | (interaction-environment)))) | |
569 | ||
570 | (with-test-prefix "referencing previous values" | |
571 | (pass-if (equal? (letrec ((a (cons 'foo 'bar)) | |
572 | (b a)) | |
573 | b) | |
574 | '(foo . bar))) | |
575 | (pass-if (equal? (let () | |
576 | (define a (cons 'foo 'bar)) | |
577 | (define b a) | |
578 | b) | |
579 | '(foo . bar))))) | |
580 | ||
08c608e1 DH |
581 | (with-test-prefix "if" |
582 | ||
583 | (with-test-prefix "missing or extra expressions" | |
584 | ||
e75184d5 | 585 | (pass-if-syntax-error "(if)" |
dc1eed52 | 586 | exception:generic-syncase-error |
4dce3c96 DH |
587 | (eval '(if) |
588 | (interaction-environment))) | |
08c608e1 | 589 | |
e75184d5 | 590 | (pass-if-syntax-error "(if 1 2 3 4)" |
dc1eed52 | 591 | exception:generic-syncase-error |
4dce3c96 DH |
592 | (eval '(if 1 2 3 4) |
593 | (interaction-environment))))) | |
08c608e1 DH |
594 | |
595 | (with-test-prefix "cond" | |
596 | ||
aa498d0c DH |
597 | (with-test-prefix "cond is hygienic" |
598 | ||
599 | (pass-if "bound 'else is handled correctly" | |
600 | (eq? (let ((else 'ok)) (cond (else))) 'ok)) | |
601 | ||
602 | (with-test-prefix "bound '=> is handled correctly" | |
603 | ||
604 | (pass-if "#t => 'ok" | |
605 | (let ((=> 'foo)) | |
606 | (eq? (cond (#t => 'ok)) 'ok))) | |
607 | ||
608 | (pass-if "else =>" | |
609 | (let ((=> 'foo)) | |
610 | (eq? (cond (else =>)) 'foo))) | |
611 | ||
612 | (pass-if "else => identity" | |
613 | (let ((=> 'foo)) | |
614 | (eq? (cond (else => identity)) identity))))) | |
615 | ||
9ee0f678 LC |
616 | (with-test-prefix "SRFI-61" |
617 | ||
618 | (pass-if "always available" | |
619 | (cond-expand (srfi-61 #t) (else #f))) | |
620 | ||
621 | (pass-if "single value consequent" | |
622 | (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f)))) | |
623 | ||
624 | (pass-if "single value alternate" | |
625 | (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok)))) | |
626 | ||
627 | (pass-if-exception "doesn't affect standard =>" | |
628 | exception:wrong-num-args | |
629 | (cond ((values 1 2) => (lambda (x y) #t)))) | |
630 | ||
631 | (pass-if "multiple values consequent" | |
632 | (equal? '(2 1) (cond ((values 1 2) | |
633 | (lambda (one two) | |
634 | (and (= 1 one) (= 2 two))) => | |
635 | (lambda (one two) (list two one))) | |
636 | (else #f)))) | |
637 | ||
638 | (pass-if "multiple values alternate" | |
639 | (eq? 'ok (cond ((values 2 3 4) | |
640 | (lambda args (equal? '(1 2 3) args)) => | |
641 | (lambda (x y z) #f)) | |
642 | (else 'ok)))) | |
643 | ||
644 | (pass-if "zero values" | |
645 | (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok)) | |
646 | (else #f)))) | |
647 | ||
648 | (pass-if "bound => is handled correctly" | |
649 | (let ((=> 'ok)) | |
650 | (eq? 'ok (cond (#t identity =>) (else #f))))) | |
651 | ||
e75184d5 AW |
652 | (pass-if-syntax-error "missing recipient" |
653 | '(cond . "wrong number of receiver expressions") | |
e7cf0457 MW |
654 | (eval '(cond (#t identity =>)) |
655 | (interaction-environment))) | |
9ee0f678 | 656 | |
e75184d5 AW |
657 | (pass-if-syntax-error "extra recipient" |
658 | '(cond . "wrong number of receiver expressions") | |
e7cf0457 MW |
659 | (eval '(cond (#t identity => identity identity)) |
660 | (interaction-environment)))) | |
9ee0f678 | 661 | |
08c608e1 DH |
662 | (with-test-prefix "bad or missing clauses" |
663 | ||
e75184d5 | 664 | (pass-if-syntax-error "(cond)" |
dc1eed52 | 665 | exception:generic-syncase-error |
d6e04e7c DH |
666 | (eval '(cond) |
667 | (interaction-environment))) | |
08c608e1 | 668 | |
e75184d5 | 669 | (pass-if-syntax-error "(cond #t)" |
e7cf0457 | 670 | '(cond . "invalid clause") |
d6e04e7c DH |
671 | (eval '(cond #t) |
672 | (interaction-environment))) | |
08c608e1 | 673 | |
e75184d5 | 674 | (pass-if-syntax-error "(cond 1)" |
e7cf0457 | 675 | '(cond . "invalid clause") |
d6e04e7c DH |
676 | (eval '(cond 1) |
677 | (interaction-environment))) | |
08c608e1 | 678 | |
e75184d5 | 679 | (pass-if-syntax-error "(cond 1 2)" |
e7cf0457 | 680 | '(cond . "invalid clause") |
d6e04e7c DH |
681 | (eval '(cond 1 2) |
682 | (interaction-environment))) | |
08c608e1 | 683 | |
e75184d5 | 684 | (pass-if-syntax-error "(cond 1 2 3)" |
e7cf0457 | 685 | '(cond . "invalid clause") |
d6e04e7c DH |
686 | (eval '(cond 1 2 3) |
687 | (interaction-environment))) | |
08c608e1 | 688 | |
e75184d5 | 689 | (pass-if-syntax-error "(cond 1 2 3 4)" |
e7cf0457 | 690 | '(cond . "invalid clause") |
d6e04e7c DH |
691 | (eval '(cond 1 2 3 4) |
692 | (interaction-environment))) | |
08c608e1 | 693 | |
e75184d5 | 694 | (pass-if-syntax-error "(cond ())" |
e7cf0457 | 695 | '(cond . "invalid clause") |
d6e04e7c DH |
696 | (eval '(cond ()) |
697 | (interaction-environment))) | |
08c608e1 | 698 | |
e75184d5 | 699 | (pass-if-syntax-error "(cond () 1)" |
e7cf0457 | 700 | '(cond . "invalid clause") |
d6e04e7c DH |
701 | (eval '(cond () 1) |
702 | (interaction-environment))) | |
08c608e1 | 703 | |
e75184d5 | 704 | (pass-if-syntax-error "(cond (1) 1)" |
e7cf0457 | 705 | '(cond . "invalid clause") |
d6e04e7c | 706 | (eval '(cond (1) 1) |
e7cf0457 MW |
707 | (interaction-environment))) |
708 | ||
709 | (pass-if-syntax-error "(cond (else #f) (#t #t))" | |
710 | '(cond . "else must be the last clause") | |
711 | (eval '(cond (else #f) (#t #t)) | |
aa498d0c | 712 | (interaction-environment)))) |
b461abe7 | 713 | |
d6e04e7c | 714 | (with-test-prefix "wrong number of arguments" |
08c608e1 | 715 | |
d6e04e7c DH |
716 | (pass-if-exception "=> (lambda (x y) #t)" |
717 | exception:wrong-num-args | |
718 | (cond (1 => (lambda (x y) #t)))))) | |
08c608e1 | 719 | |
27a22666 DH |
720 | (with-test-prefix "case" |
721 | ||
58a2510b DH |
722 | (pass-if "clause with empty labels list" |
723 | (case 1 (() #f) (else #t))) | |
724 | ||
e7cf0457 MW |
725 | (with-test-prefix "case handles '=> correctly" |
726 | ||
727 | (pass-if "(1 2 3) => list" | |
728 | (equal? (case 1 ((1 2 3) => list)) | |
729 | '(1))) | |
730 | ||
731 | (pass-if "else => list" | |
732 | (equal? (case 6 | |
733 | ((1 2 3) 'wrong) | |
734 | (else => list)) | |
735 | '(6))) | |
736 | ||
737 | (with-test-prefix "bound '=> is handled correctly" | |
738 | ||
739 | (pass-if "(1) => 'ok" | |
740 | (let ((=> 'foo)) | |
741 | (eq? (case 1 ((1) => 'ok)) 'ok))) | |
742 | ||
743 | (pass-if "else =>" | |
744 | (let ((=> 'foo)) | |
745 | (eq? (case 1 (else =>)) 'foo))) | |
746 | ||
747 | (pass-if "else => list" | |
748 | (let ((=> 'foo)) | |
749 | (eq? (case 1 (else => identity)) identity)))) | |
750 | ||
751 | (pass-if-syntax-error "missing recipient" | |
752 | '(case . "wrong number of receiver expressions") | |
753 | (eval '(case 1 ((1) =>)) | |
754 | (interaction-environment))) | |
755 | ||
756 | (pass-if-syntax-error "extra recipient" | |
757 | '(case . "wrong number of receiver expressions") | |
758 | (eval '(case 1 ((1) => identity identity)) | |
759 | (interaction-environment)))) | |
760 | ||
2a6f7afe DH |
761 | (with-test-prefix "case is hygienic" |
762 | ||
e75184d5 | 763 | (pass-if-syntax-error "bound 'else is handled correctly" |
e7cf0457 | 764 | '(case . "invalid clause") |
2a6f7afe DH |
765 | (eval '(let ((else #f)) (case 1 (else #f))) |
766 | (interaction-environment)))) | |
767 | ||
27a22666 DH |
768 | (with-test-prefix "bad or missing clauses" |
769 | ||
e75184d5 | 770 | (pass-if-syntax-error "(case)" |
dc1eed52 | 771 | exception:generic-syncase-error |
d6e04e7c DH |
772 | (eval '(case) |
773 | (interaction-environment))) | |
27a22666 | 774 | |
e75184d5 | 775 | (pass-if-syntax-error "(case . \"foo\")" |
dc1eed52 | 776 | exception:generic-syncase-error |
d6e04e7c DH |
777 | (eval '(case . "foo") |
778 | (interaction-environment))) | |
27a22666 | 779 | |
e75184d5 | 780 | (pass-if-syntax-error "(case 1)" |
dc1eed52 | 781 | exception:generic-syncase-error |
d6e04e7c DH |
782 | (eval '(case 1) |
783 | (interaction-environment))) | |
27a22666 | 784 | |
e75184d5 | 785 | (pass-if-syntax-error "(case 1 . \"foo\")" |
dc1eed52 | 786 | exception:generic-syncase-error |
d6e04e7c DH |
787 | (eval '(case 1 . "foo") |
788 | (interaction-environment))) | |
27a22666 | 789 | |
e75184d5 | 790 | (pass-if-syntax-error "(case 1 \"foo\")" |
e7cf0457 | 791 | '(case . "invalid clause") |
d6e04e7c DH |
792 | (eval '(case 1 "foo") |
793 | (interaction-environment))) | |
27a22666 | 794 | |
e75184d5 | 795 | (pass-if-syntax-error "(case 1 ())" |
e7cf0457 | 796 | '(case . "invalid clause") |
d6e04e7c DH |
797 | (eval '(case 1 ()) |
798 | (interaction-environment))) | |
27a22666 | 799 | |
e75184d5 | 800 | (pass-if-syntax-error "(case 1 (\"foo\"))" |
e7cf0457 | 801 | '(case . "invalid clause") |
d6e04e7c DH |
802 | (eval '(case 1 ("foo")) |
803 | (interaction-environment))) | |
27a22666 | 804 | |
e75184d5 | 805 | (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))" |
e7cf0457 | 806 | '(case . "invalid clause") |
d6e04e7c DH |
807 | (eval '(case 1 ("foo" "bar")) |
808 | (interaction-environment))) | |
27a22666 | 809 | |
e75184d5 | 810 | (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")" |
dc1eed52 | 811 | exception:generic-syncase-error |
d6e04e7c DH |
812 | (eval '(case 1 ((2) "bar") . "foo") |
813 | (interaction-environment))) | |
27a22666 | 814 | |
e75184d5 | 815 | (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))" |
e7cf0457 | 816 | '(case . "invalid clause") |
d6e04e7c DH |
817 | (eval '(case 1 ((2) "bar") (else)) |
818 | (interaction-environment))) | |
27a22666 | 819 | |
e75184d5 | 820 | (pass-if-syntax-error "(case 1 (else #f) . \"foo\")" |
dc1eed52 | 821 | exception:generic-syncase-error |
d6e04e7c DH |
822 | (eval '(case 1 (else #f) . "foo") |
823 | (interaction-environment))) | |
27a22666 | 824 | |
e75184d5 | 825 | (pass-if-syntax-error "(case 1 (else #f) ((1) #t))" |
e7cf0457 | 826 | '(case . "else must be the last clause") |
d6e04e7c DH |
827 | (eval '(case 1 (else #f) ((1) #t)) |
828 | (interaction-environment))))) | |
27a22666 | 829 | |
ced8edb0 | 830 | (with-test-prefix "top-level define" |
08c608e1 | 831 | |
3dcf3373 LC |
832 | (pass-if "redefinition" |
833 | (let ((m (make-module))) | |
834 | (beautify-user-module! m) | |
835 | ||
836 | ;; The previous value of `round' must still be visible at the time the | |
837 | ;; new `round' is defined. According to R5RS (Section 5.2.1), `define' | |
838 | ;; should behave like `set!' in this case (except that in the case of | |
839 | ;; Guile, we respect module boundaries). | |
840 | (eval '(define round round) m) | |
841 | (eq? (module-ref m 'round) round))) | |
36245b66 | 842 | |
08c608e1 DH |
843 | (with-test-prefix "missing or extra expressions" |
844 | ||
e75184d5 | 845 | (pass-if-syntax-error "(define)" |
9ecac781 | 846 | exception:generic-syncase-error |
d6e04e7c | 847 | (eval '(define) |
1ce64556 AW |
848 | (interaction-environment)))) |
849 | ||
850 | (pass-if "module scoping" | |
851 | (equal? | |
852 | (eval | |
853 | '(begin | |
854 | (define-module (top-level-define/module-scoping-1) | |
855 | #:export (define-10)) | |
856 | (define-syntax-rule (define-10 name) | |
857 | (begin | |
858 | (define t 10) | |
859 | (define (name) t))) | |
860 | (define-module (top-level-define/module-scoping-2) | |
861 | #:use-module (top-level-define/module-scoping-1)) | |
862 | (define-10 foo) | |
863 | (foo)) | |
864 | (current-module)) | |
ab2d0f8f AW |
865 | 10)) |
866 | ||
867 | (pass-if "module scoping, same symbolic name" | |
868 | (equal? | |
869 | (eval | |
870 | '(begin | |
871 | (define-module (top-level-define/module-scoping-3)) | |
872 | (define a 10) | |
873 | (define-module (top-level-define/module-scoping-4) | |
874 | #:use-module (top-level-define/module-scoping-3)) | |
875 | (define a (@@ (top-level-define/module-scoping-3) a)) | |
876 | a) | |
877 | (current-module)) | |
adf91e1c AW |
878 | 10)) |
879 | ||
880 | (pass-if "module scoping, introduced names" | |
881 | (equal? | |
882 | (eval | |
883 | '(begin | |
884 | (define-module (top-level-define/module-scoping-5) | |
885 | #:export (define-constant)) | |
886 | (define-syntax-rule (define-constant name val) | |
887 | (begin | |
888 | (define t val) | |
889 | (define (name) t))) | |
890 | (define-module (top-level-define/module-scoping-6) | |
891 | #:use-module (top-level-define/module-scoping-5)) | |
892 | (define-constant foo 10) | |
893 | (define-constant bar 20) | |
894 | (foo)) | |
895 | (current-module)) | |
896 | 10)) | |
897 | ||
898 | (pass-if "module scoping, duplicate introduced name" | |
899 | (equal? | |
900 | (eval | |
901 | '(begin | |
902 | (define-module (top-level-define/module-scoping-7) | |
903 | #:export (define-constant)) | |
904 | (define-syntax-rule (define-constant name val) | |
905 | (begin | |
906 | (define t val) | |
907 | (define (name) t))) | |
908 | (define-module (top-level-define/module-scoping-8) | |
909 | #:use-module (top-level-define/module-scoping-7)) | |
910 | (define-constant foo 10) | |
911 | (define-constant foo 20) | |
912 | (foo)) | |
913 | (current-module)) | |
914 | 20))) | |
08c608e1 | 915 | |
ced8edb0 DH |
916 | (with-test-prefix "internal define" |
917 | ||
918 | (pass-if "internal defines become letrec" | |
919 | (eval '(let ((a identity) (b identity) (c identity)) | |
920 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
921 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
922 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
923 | (and (eq? 'a (a 0) (a 3)) | |
924 | (eq? 'b (a 1) (a 4)) | |
925 | (eq? 'c (a 2) (a 5)))) | |
926 | (interaction-environment))) | |
927 | ||
3dcf3373 LC |
928 | (pass-if "binding is created before expression is evaluated" |
929 | ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2). | |
930 | (= (eval '(let () | |
931 | (define foo | |
932 | (begin | |
933 | (set! foo 1) | |
934 | (+ foo 1))) | |
935 | foo) | |
936 | (interaction-environment)) | |
937 | 2)) | |
938 | ||
c86c440b | 939 | (pass-if "internal defines with begin" |
ced8edb0 DH |
940 | (false-if-exception |
941 | (eval '(let ((a identity) (b identity) (c identity)) | |
942 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
943 | (begin | |
944 | (define (b x) (if (= x 0) 'b (c (- x 1))))) | |
945 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
946 | (and (eq? 'a (a 0) (a 3)) | |
947 | (eq? 'b (a 1) (a 4)) | |
948 | (eq? 'c (a 2) (a 5)))) | |
949 | (interaction-environment)))) | |
950 | ||
c86c440b | 951 | (pass-if "internal defines with empty begin" |
ced8edb0 DH |
952 | (false-if-exception |
953 | (eval '(let ((a identity) (b identity) (c identity)) | |
954 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
955 | (begin) | |
956 | (define (b x) (if (= x 0) 'b (c (- x 1)))) | |
957 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
958 | (and (eq? 'a (a 0) (a 3)) | |
959 | (eq? 'b (a 1) (a 4)) | |
960 | (eq? 'c (a 2) (a 5)))) | |
961 | (interaction-environment)))) | |
962 | ||
c3d94801 | 963 | (pass-if "internal defines with macro application" |
560434b3 DH |
964 | (false-if-exception |
965 | (eval '(begin | |
c3d94801 | 966 | (defmacro my-define forms |
560434b3 | 967 | (cons 'define forms)) |
c3d94801 DH |
968 | (let ((a identity) (b identity) (c identity)) |
969 | (define (a x) (if (= x 0) 'a (b (- x 1)))) | |
970 | (my-define (b x) (if (= x 0) 'b (c (- x 1)))) | |
971 | (define (c x) (if (= x 0) 'c (a (- x 1)))) | |
972 | (and (eq? 'a (a 0) (a 3)) | |
973 | (eq? 'b (a 1) (a 4)) | |
974 | (eq? 'c (a 2) (a 5))))) | |
560434b3 DH |
975 | (interaction-environment)))) |
976 | ||
e75184d5 | 977 | (pass-if-syntax-error "missing body expression" |
ced8edb0 DH |
978 | exception:missing-body-expr |
979 | (eval '(let () (define x #t)) | |
b7742c6b | 980 | (interaction-environment)))) |
aa498d0c | 981 | |
48eb9021 MW |
982 | (with-test-prefix "top-level define-values" |
983 | ||
984 | (pass-if "zero values" | |
985 | (eval '(begin (define-values () (values)) | |
986 | #t) | |
987 | (interaction-environment))) | |
988 | ||
989 | (pass-if-equal "one value" | |
990 | 1 | |
991 | (eval '(begin (define-values (x) 1) | |
992 | x) | |
993 | (interaction-environment))) | |
994 | ||
995 | (pass-if-equal "two values" | |
996 | '(2 3) | |
997 | (eval '(begin (define-values (x y) (values 2 3)) | |
998 | (list x y)) | |
999 | (interaction-environment))) | |
1000 | ||
1001 | (pass-if-equal "three values" | |
1002 | '(4 5 6) | |
1003 | (eval '(begin (define-values (x y z) (values 4 5 6)) | |
1004 | (list x y z)) | |
1005 | (interaction-environment))) | |
1006 | ||
1007 | (pass-if-equal "one value with tail" | |
1008 | '(a (b c d)) | |
1009 | (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd)) | |
1010 | (list x y)) | |
1011 | (interaction-environment))) | |
1012 | ||
1013 | (pass-if-equal "two values with tail" | |
1014 | '(x y (z w)) | |
1015 | (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w)) | |
1016 | (list x y z)) | |
1017 | (interaction-environment))) | |
1018 | ||
1019 | (pass-if-equal "just tail" | |
1020 | '(1 2 3) | |
1021 | (eval '(begin (define-values x (values 1 2 3)) | |
1022 | x) | |
1023 | (interaction-environment))) | |
1024 | ||
1025 | (pass-if-exception "expected 0 values, got 1" | |
b00c9b22 | 1026 | exception:wrong-number-of-values |
48eb9021 MW |
1027 | (eval '(define-values () 1) |
1028 | (interaction-environment))) | |
1029 | ||
1030 | (pass-if-exception "expected 1 value, got 0" | |
b00c9b22 | 1031 | exception:wrong-number-of-values |
48eb9021 MW |
1032 | (eval '(define-values (x) (values)) |
1033 | (interaction-environment))) | |
1034 | ||
1035 | (pass-if-exception "expected 1 value, got 2" | |
b00c9b22 | 1036 | exception:wrong-number-of-values |
48eb9021 MW |
1037 | (eval '(define-values (x) (values 1 2)) |
1038 | (interaction-environment))) | |
1039 | ||
1040 | (pass-if-exception "expected 1 value with tail, got 0" | |
b00c9b22 | 1041 | exception:wrong-number-of-values |
48eb9021 MW |
1042 | (eval '(define-values (x . y) (values)) |
1043 | (interaction-environment))) | |
1044 | ||
1045 | (pass-if-exception "expected 2 value with tail, got 1" | |
b00c9b22 | 1046 | exception:wrong-number-of-values |
48eb9021 MW |
1047 | (eval '(define-values (x y . z) 1) |
1048 | (interaction-environment))) | |
1049 | ||
1050 | (pass-if "redefinition" | |
1051 | (let ((m (make-module))) | |
1052 | (beautify-user-module! m) | |
1053 | ||
1054 | ;; The previous values of `floor' and `round' must still be | |
1055 | ;; visible at the time the new `floor' and `round' are defined. | |
1056 | (eval '(define-values (floor round) (values floor round)) m) | |
1057 | (and (eq? (module-ref m 'floor) floor) | |
1058 | (eq? (module-ref m 'round) round)))) | |
1059 | ||
1060 | (with-test-prefix "missing expression" | |
1061 | ||
1062 | (pass-if-syntax-error "(define-values)" | |
1063 | exception:generic-syncase-error | |
1064 | (eval '(define-values) | |
1065 | (interaction-environment))))) | |
1066 | ||
1067 | (with-test-prefix "internal define-values" | |
1068 | ||
1069 | (pass-if "zero values" | |
1070 | (let () | |
1071 | (define-values () (values)) | |
1072 | #t)) | |
1073 | ||
1074 | (pass-if-equal "one value" | |
1075 | 1 | |
1076 | (let () | |
1077 | (define-values (x) 1) | |
1078 | x)) | |
1079 | ||
1080 | (pass-if-equal "two values" | |
1081 | '(2 3) | |
1082 | (let () | |
1083 | (define-values (x y) (values 2 3)) | |
1084 | (list x y))) | |
1085 | ||
1086 | (pass-if-equal "three values" | |
1087 | '(4 5 6) | |
1088 | (let () | |
1089 | (define-values (x y z) (values 4 5 6)) | |
1090 | (list x y z))) | |
1091 | ||
1092 | (pass-if-equal "one value with tail" | |
1093 | '(a (b c d)) | |
1094 | (let () | |
1095 | (define-values (x . y) (values 'a 'b 'c 'd)) | |
1096 | (list x y))) | |
1097 | ||
1098 | (pass-if-equal "two values with tail" | |
1099 | '(x y (z w)) | |
1100 | (let () | |
1101 | (define-values (x y . z) (values 'x 'y 'z 'w)) | |
1102 | (list x y z))) | |
1103 | ||
1104 | (pass-if-equal "just tail" | |
1105 | '(1 2 3) | |
1106 | (let () | |
1107 | (define-values x (values 1 2 3)) | |
1108 | x)) | |
1109 | ||
1110 | (pass-if-exception "expected 0 values, got 1" | |
b00c9b22 | 1111 | exception:wrong-number-of-values |
48eb9021 MW |
1112 | (eval '(let () |
1113 | (define-values () 1) | |
1114 | #f) | |
1115 | (interaction-environment))) | |
1116 | ||
1117 | (pass-if-exception "expected 1 value, got 0" | |
b00c9b22 | 1118 | exception:wrong-number-of-values |
48eb9021 MW |
1119 | (eval '(let () |
1120 | (define-values (x) (values)) | |
1121 | #f) | |
1122 | (interaction-environment))) | |
1123 | ||
1124 | (pass-if-exception "expected 1 value, got 2" | |
b00c9b22 | 1125 | exception:wrong-number-of-values |
48eb9021 MW |
1126 | (eval '(let () |
1127 | (define-values (x) (values 1 2)) | |
1128 | #f) | |
1129 | (interaction-environment))) | |
1130 | ||
1131 | (pass-if-exception "expected 1 value with tail, got 0" | |
b00c9b22 | 1132 | exception:wrong-number-of-values |
48eb9021 MW |
1133 | (eval '(let () |
1134 | (define-values (x . y) (values)) | |
1135 | #f) | |
1136 | (interaction-environment))) | |
1137 | ||
1138 | (pass-if-exception "expected 2 value with tail, got 1" | |
b00c9b22 | 1139 | exception:wrong-number-of-values |
48eb9021 MW |
1140 | (eval '(let () |
1141 | (define-values (x y . z) 1) | |
1142 | #f) | |
1143 | (interaction-environment))) | |
1144 | ||
1145 | (with-test-prefix "missing expression" | |
1146 | ||
1147 | (pass-if-syntax-error "(define-values)" | |
1148 | exception:generic-syncase-error | |
1149 | (eval '(let () | |
1150 | (define-values) | |
1151 | #f) | |
1152 | (interaction-environment))))) | |
1153 | ||
08c608e1 DH |
1154 | (with-test-prefix "set!" |
1155 | ||
1156 | (with-test-prefix "missing or extra expressions" | |
1157 | ||
e75184d5 | 1158 | (pass-if-syntax-error "(set!)" |
9ecac781 | 1159 | exception:bad-set! |
4dce3c96 DH |
1160 | (eval '(set!) |
1161 | (interaction-environment))) | |
08c608e1 | 1162 | |
e75184d5 | 1163 | (pass-if-syntax-error "(set! 1)" |
9ecac781 | 1164 | exception:bad-set! |
4dce3c96 DH |
1165 | (eval '(set! 1) |
1166 | (interaction-environment))) | |
08c608e1 | 1167 | |
e75184d5 | 1168 | (pass-if-syntax-error "(set! 1 2 3)" |
9ecac781 | 1169 | exception:bad-set! |
4dce3c96 DH |
1170 | (eval '(set! 1 2 3) |
1171 | (interaction-environment)))) | |
08c608e1 DH |
1172 | |
1173 | (with-test-prefix "bad variable" | |
1174 | ||
e75184d5 | 1175 | (pass-if-syntax-error "(set! \"\" #t)" |
9ecac781 | 1176 | exception:bad-set! |
4dce3c96 DH |
1177 | (eval '(set! "" #t) |
1178 | (interaction-environment))) | |
08c608e1 | 1179 | |
e75184d5 | 1180 | (pass-if-syntax-error "(set! 1 #t)" |
9ecac781 | 1181 | exception:bad-set! |
4dce3c96 DH |
1182 | (eval '(set! 1 #t) |
1183 | (interaction-environment))) | |
08c608e1 | 1184 | |
e75184d5 | 1185 | (pass-if-syntax-error "(set! #t #f)" |
9ecac781 | 1186 | exception:bad-set! |
4dce3c96 DH |
1187 | (eval '(set! #t #f) |
1188 | (interaction-environment))) | |
08c608e1 | 1189 | |
e75184d5 | 1190 | (pass-if-syntax-error "(set! #f #t)" |
9ecac781 | 1191 | exception:bad-set! |
4dce3c96 DH |
1192 | (eval '(set! #f #t) |
1193 | (interaction-environment))) | |
08c608e1 | 1194 | |
e75184d5 | 1195 | (pass-if-syntax-error "(set! #\\space #f)" |
9ecac781 | 1196 | exception:bad-set! |
4dce3c96 DH |
1197 | (eval '(set! #\space #f) |
1198 | (interaction-environment))))) | |
08c608e1 | 1199 | |
08c608e1 DH |
1200 | (with-test-prefix "quote" |
1201 | ||
1202 | (with-test-prefix "missing or extra expression" | |
1203 | ||
e75184d5 | 1204 | (pass-if-syntax-error "(quote)" |
9ecac781 | 1205 | exception:bad-quote |
4dce3c96 DH |
1206 | (eval '(quote) |
1207 | (interaction-environment))) | |
08c608e1 | 1208 | |
e75184d5 | 1209 | (pass-if-syntax-error "(quote a b)" |
9ecac781 | 1210 | exception:bad-quote |
4dce3c96 DH |
1211 | (eval '(quote a b) |
1212 | (interaction-environment))))) | |
2798ba71 KR |
1213 | |
1214 | (with-test-prefix "while" | |
1215 | ||
1216 | (define (unreachable) | |
1217 | (error "unreachable code has been reached!")) | |
1218 | ||
2798ba71 KR |
1219 | ;; Return a new procedure COND which when called (COND) will return #t the |
1220 | ;; first N times, then #f, then any further call is an error. N=0 is | |
1221 | ;; allowed, in which case #f is returned by the first call. | |
1222 | (define (make-iterations-cond n) | |
1223 | (lambda () | |
1224 | (cond ((not n) | |
1225 | (error "oops, condition re-tested after giving false")) | |
1226 | ((= 0 n) | |
1227 | (set! n #f) | |
1228 | #f) | |
1229 | (else | |
1230 | (set! n (1- n)) | |
1231 | #t)))) | |
1232 | ||
1233 | ||
e75184d5 | 1234 | (pass-if-syntax-error "too few args" exception:generic-syncase-error |
d6e04e7c | 1235 | (eval '(while) (interaction-environment))) |
2798ba71 KR |
1236 | |
1237 | (with-test-prefix "empty body" | |
1238 | (do ((n 0 (1+ n))) | |
1239 | ((> n 5)) | |
1240 | (pass-if n | |
ce09ee19 AW |
1241 | (eval `(letrec ((make-iterations-cond |
1242 | (lambda (n) | |
1243 | (lambda () | |
1244 | (cond ((not n) | |
1245 | (error "oops, condition re-tested after giving false")) | |
1246 | ((= 0 n) | |
1247 | (set! n #f) | |
1248 | #f) | |
1249 | (else | |
1250 | (set! n (1- n)) | |
1251 | #t)))))) | |
1252 | (let ((cond (make-iterations-cond ,n))) | |
1253 | (while (cond)) | |
1254 | #t)) | |
1255 | (interaction-environment))))) | |
2798ba71 KR |
1256 | |
1257 | (pass-if "initially false" | |
1258 | (while #f | |
1259 | (unreachable)) | |
1260 | #t) | |
1261 | ||
2798ba71 KR |
1262 | (with-test-prefix "iterations" |
1263 | (do ((n 0 (1+ n))) | |
1264 | ((> n 5)) | |
1265 | (pass-if n | |
1266 | (let ((cond (make-iterations-cond n)) | |
1267 | (i 0)) | |
1268 | (while (cond) | |
1269 | (set! i (1+ i))) | |
1270 | (= i n))))) | |
1271 | ||
1272 | (with-test-prefix "break" | |
1273 | ||
91956a94 AW |
1274 | (pass-if "normal return" |
1275 | (not (while #f (error "not reached")))) | |
1276 | ||
1277 | (pass-if "no args" | |
1278 | (while #t (break))) | |
1279 | ||
1280 | (pass-if "multiple values" | |
1281 | (equal? '(1 2 3) | |
1282 | (call-with-values | |
1283 | (lambda () (while #t (break 1 2 3))) | |
1284 | list))) | |
1285 | ||
2798ba71 KR |
1286 | (with-test-prefix "from cond" |
1287 | (pass-if "first" | |
1288 | (while (begin | |
1289 | (break) | |
1290 | (unreachable)) | |
1291 | (unreachable)) | |
1292 | #t) | |
1293 | ||
1294 | (do ((n 0 (1+ n))) | |
1295 | ((> n 5)) | |
1296 | (pass-if n | |
1297 | (let ((cond (make-iterations-cond n)) | |
1298 | (i 0)) | |
1299 | (while (if (cond) | |
1300 | #t | |
1301 | (begin | |
1302 | (break) | |
1303 | (unreachable))) | |
1304 | (set! i (1+ i))) | |
1305 | (= i n))))) | |
1306 | ||
1307 | (with-test-prefix "from body" | |
1308 | (pass-if "first" | |
1309 | (while #t | |
1310 | (break) | |
1311 | (unreachable)) | |
1312 | #t) | |
1313 | ||
1314 | (do ((n 0 (1+ n))) | |
1315 | ((> n 5)) | |
1316 | (pass-if n | |
1317 | (let ((cond (make-iterations-cond n)) | |
1318 | (i 0)) | |
1319 | (while #t | |
1320 | (if (not (cond)) | |
1321 | (begin | |
1322 | (break) | |
1323 | (unreachable))) | |
1324 | (set! i (1+ i))) | |
1325 | (= i n))))) | |
1326 | ||
1327 | (pass-if "from nested" | |
1328 | (while #t | |
1329 | (let ((outer-break break)) | |
1330 | (while #t | |
1331 | (outer-break) | |
1332 | (unreachable))) | |
1333 | (unreachable)) | |
cc08aafd KR |
1334 | #t) |
1335 | ||
1336 | (pass-if "from recursive" | |
1337 | (let ((outer-break #f)) | |
1338 | (define (r n) | |
1339 | (while #t | |
1340 | (if (eq? n 'outer) | |
1341 | (begin | |
1342 | (set! outer-break break) | |
1343 | (r 'inner)) | |
1344 | (begin | |
1345 | (outer-break) | |
1346 | (unreachable)))) | |
1347 | (if (eq? n 'inner) | |
1348 | (error "broke only from inner loop"))) | |
1349 | (r 'outer)) | |
2798ba71 KR |
1350 | #t)) |
1351 | ||
1352 | (with-test-prefix "continue" | |
1353 | ||
e75184d5 | 1354 | (pass-if-syntax-error "too many args" exception:too-many-args |
9ecac781 AW |
1355 | (eval '(while #t |
1356 | (continue 1)) | |
1357 | (interaction-environment))) | |
2798ba71 KR |
1358 | |
1359 | (with-test-prefix "from cond" | |
1360 | (do ((n 0 (1+ n))) | |
1361 | ((> n 5)) | |
1362 | (pass-if n | |
1363 | (let ((cond (make-iterations-cond n)) | |
1364 | (i 0)) | |
1365 | (while (if (cond) | |
1366 | (begin | |
1367 | (set! i (1+ i)) | |
1368 | (continue) | |
1369 | (unreachable)) | |
1370 | #f) | |
1371 | (unreachable)) | |
1372 | (= i n))))) | |
1373 | ||
1374 | (with-test-prefix "from body" | |
1375 | (do ((n 0 (1+ n))) | |
1376 | ((> n 5)) | |
1377 | (pass-if n | |
1378 | (let ((cond (make-iterations-cond n)) | |
1379 | (i 0)) | |
1380 | (while (cond) | |
1381 | (set! i (1+ i)) | |
1382 | (continue) | |
1383 | (unreachable)) | |
1384 | (= i n))))) | |
1385 | ||
1386 | (pass-if "from nested" | |
1387 | (let ((cond (make-iterations-cond 3))) | |
1388 | (while (cond) | |
1389 | (let ((outer-continue continue)) | |
1390 | (while #t | |
1391 | (outer-continue) | |
1392 | (unreachable))))) | |
cc08aafd KR |
1393 | #t) |
1394 | ||
1395 | (pass-if "from recursive" | |
1396 | (let ((outer-continue #f)) | |
1397 | (define (r n) | |
1398 | (let ((cond (make-iterations-cond 3)) | |
1399 | (first #t)) | |
1400 | (while (begin | |
1401 | (if (and (not first) | |
1402 | (eq? n 'inner)) | |
1403 | (error "continued only to inner loop")) | |
1404 | (cond)) | |
1405 | (set! first #f) | |
1406 | (if (eq? n 'outer) | |
1407 | (begin | |
1408 | (set! outer-continue continue) | |
1409 | (r 'inner)) | |
1410 | (begin | |
1411 | (outer-continue) | |
1412 | (unreachable)))))) | |
1413 | (r 'outer)) | |
2798ba71 | 1414 | #t))) |
aa8630ef | 1415 | |
1624e149 MW |
1416 | (with-test-prefix "syntax-rules" |
1417 | ||
1418 | (pass-if-equal "custom ellipsis within normal ellipsis" | |
1419 | '((((a x) (a y) (a …)) | |
1420 | ((b x) (b y) (b …)) | |
1421 | ((c x) (c y) (c …))) | |
1422 | (((a x) (b x) (c x)) | |
1423 | ((a y) (b y) (c y)) | |
1424 | ((a …) (b …) (c …)))) | |
1425 | (let () | |
1426 | (define-syntax foo | |
1427 | (syntax-rules () | |
1428 | ((_ y ...) | |
1429 | (syntax-rules … () | |
1430 | ((_ x …) | |
1431 | '((((x y) ...) …) | |
1432 | (((x y) …) ...))))))) | |
1433 | (define-syntax bar (foo x y …)) | |
1434 | (bar a b c))) | |
1435 | ||
1436 | (pass-if-equal "normal ellipsis within custom ellipsis" | |
1437 | '((((a x) (a y) (a z)) | |
1438 | ((b x) (b y) (b z)) | |
1439 | ((c x) (c y) (c z))) | |
1440 | (((a x) (b x) (c x)) | |
1441 | ((a y) (b y) (c y)) | |
1442 | ((a z) (b z) (c z)))) | |
1443 | (let () | |
1444 | (define-syntax foo | |
1445 | (syntax-rules … () | |
1446 | ((_ y …) | |
1447 | (syntax-rules () | |
1448 | ((_ x ...) | |
1449 | '((((x y) …) ...) | |
1450 | (((x y) ...) …))))))) | |
1451 | (define-syntax bar (foo x y z)) | |
2d6a3144 MW |
1452 | (bar a b c))) |
1453 | ||
1454 | ;; This test is given in SRFI-46. | |
1455 | (pass-if-equal "custom ellipsis is handled hygienically" | |
1456 | '((1) 2 (3) (4)) | |
1457 | (let-syntax | |
1458 | ((f (syntax-rules () | |
1459 | ((f ?e) | |
1460 | (let-syntax | |
1461 | ((g (syntax-rules --- () | |
1462 | ((g (??x ?e) (??y ---)) | |
1463 | '((??x) ?e (??y) ---))))) | |
1464 | (g (1 2) (3 4))))))) | |
1465 | (f ---)))) | |
1624e149 | 1466 | |
0e181633 MW |
1467 | (with-test-prefix "syntax-error" |
1468 | ||
1469 | (pass-if-syntax-error "outside of macro without args" | |
1470 | "test error" | |
1471 | (eval '(syntax-error "test error") | |
1472 | (interaction-environment))) | |
1473 | ||
1474 | (pass-if-syntax-error "outside of macro with args" | |
1475 | "test error x \\(y z\\)" | |
1476 | (eval '(syntax-error "test error" x (y z)) | |
1477 | (interaction-environment))) | |
1478 | ||
1479 | (pass-if-equal "within macro" | |
1480 | '(simple-let | |
1481 | "expected an identifier but got (z1 z2)" | |
1482 | (simple-let ((y (* x x)) | |
1483 | ((z1 z2) (values x x))) | |
1484 | (+ y 1))) | |
1485 | (catch 'syntax-error | |
1486 | (lambda () | |
1487 | (eval '(let () | |
1488 | (define-syntax simple-let | |
1489 | (syntax-rules () | |
1490 | ((_ (head ... ((x . y) val) . tail) | |
1491 | body1 body2 ...) | |
1492 | (syntax-error | |
1493 | "expected an identifier but got" | |
1494 | (x . y))) | |
1495 | ((_ ((name val) ...) body1 body2 ...) | |
1496 | ((lambda (name ...) body1 body2 ...) | |
1497 | val ...)))) | |
1498 | (define (foo x) | |
1499 | (simple-let ((y (* x x)) | |
1500 | ((z1 z2) (values x x))) | |
1501 | (+ y 1))) | |
1502 | foo) | |
1503 | (interaction-environment)) | |
1504 | (error "expected syntax-error exception")) | |
1505 | (lambda (k who what where form . maybe-subform) | |
1506 | (list who what form))))) | |
1507 | ||
aa8630ef MW |
1508 | (with-test-prefix "syntax-case" |
1509 | ||
1510 | (pass-if-syntax-error "duplicate pattern variable" | |
1511 | '(syntax-case . "duplicate pattern variable") | |
1512 | (eval '(lambda (e) | |
1513 | (syntax-case e () | |
1514 | ((a b c d e d f) #f))) | |
1515 | (interaction-environment))) | |
1516 | ||
1517 | (with-test-prefix "misplaced ellipses" | |
1518 | ||
1519 | (pass-if-syntax-error "bare ellipsis" | |
1520 | '(syntax-case . "misplaced ellipsis") | |
1521 | (eval '(lambda (e) | |
1522 | (syntax-case e () | |
1523 | (... #f))) | |
1524 | (interaction-environment))) | |
1525 | ||
1526 | (pass-if-syntax-error "ellipsis singleton" | |
1527 | '(syntax-case . "misplaced ellipsis") | |
1528 | (eval '(lambda (e) | |
1529 | (syntax-case e () | |
1530 | ((...) #f))) | |
1531 | (interaction-environment))) | |
1532 | ||
1533 | (pass-if-syntax-error "ellipsis in car" | |
1534 | '(syntax-case . "misplaced ellipsis") | |
1535 | (eval '(lambda (e) | |
1536 | (syntax-case e () | |
1537 | ((... . _) #f))) | |
1538 | (interaction-environment))) | |
1539 | ||
1540 | (pass-if-syntax-error "ellipsis in cdr" | |
1541 | '(syntax-case . "misplaced ellipsis") | |
1542 | (eval '(lambda (e) | |
1543 | (syntax-case e () | |
1544 | ((_ . ...) #f))) | |
1545 | (interaction-environment))) | |
1546 | ||
1547 | (pass-if-syntax-error "two ellipses in the same list" | |
1548 | '(syntax-case . "misplaced ellipsis") | |
1549 | (eval '(lambda (e) | |
1550 | (syntax-case e () | |
1551 | ((x ... y ...) #f))) | |
1552 | (interaction-environment))) | |
1553 | ||
1554 | (pass-if-syntax-error "three ellipses in the same list" | |
1555 | '(syntax-case . "misplaced ellipsis") | |
1556 | (eval '(lambda (e) | |
1557 | (syntax-case e () | |
1558 | ((x ... y ... z ...) #f))) | |
1559 | (interaction-environment))))) | |
1560 | ||
1624e149 MW |
1561 | (with-test-prefix "with-ellipsis" |
1562 | ||
1563 | (pass-if-equal "simple" | |
1564 | '(a 1 2 3) | |
1565 | (let () | |
1566 | (define-syntax define-quotation-macros | |
1567 | (lambda (x) | |
1568 | (syntax-case x () | |
1569 | ((_ (macro-name head-symbol) ...) | |
1570 | #'(begin (define-syntax macro-name | |
1571 | (lambda (x) | |
1572 | (with-ellipsis … | |
1573 | (syntax-case x () | |
1574 | ((_ x …) | |
1575 | #'(quote (head-symbol x …))))))) | |
1576 | ...))))) | |
1577 | (define-quotation-macros (quote-a a) (quote-b b)) | |
1578 | (quote-a 1 2 3))) | |
1579 | ||
1580 | (pass-if-equal "disables normal ellipsis" | |
1581 | '(a ...) | |
1582 | (let () | |
1583 | (define-syntax foo | |
1584 | (lambda (x) | |
1585 | (with-ellipsis … | |
1586 | (syntax-case x () | |
1587 | ((_) | |
1588 | #'(quote (a ...))))))) | |
1589 | (foo))) | |
1590 | ||
1591 | (pass-if-equal "doesn't affect ellipsis for generated code" | |
1592 | '(a b c) | |
1593 | (let () | |
1594 | (define-syntax quotation-macro | |
1595 | (lambda (x) | |
1596 | (with-ellipsis … | |
1597 | (syntax-case x () | |
1598 | ((_) | |
1599 | #'(lambda (x) | |
1600 | (syntax-case x () | |
1601 | ((_ x ...) | |
1602 | #'(quote (x ...)))))))))) | |
1603 | (define-syntax kwote (quotation-macro)) | |
1604 | (kwote a b c))) | |
1605 | ||
1606 | (pass-if-equal "propagates into syntax binders" | |
1607 | '(a b c) | |
1608 | (let () | |
1609 | (with-ellipsis … | |
1610 | (define-syntax kwote | |
1611 | (lambda (x) | |
1612 | (syntax-case x () | |
1613 | ((_ x …) | |
1614 | #'(quote (x …)))))) | |
1615 | (kwote a b c)))) | |
1616 | ||
1617 | (pass-if-equal "works with local-eval" | |
1618 | 5 | |
1619 | (let ((env (with-ellipsis … (the-environment)))) | |
1620 | (local-eval '(syntax-case #'(a b c d e) () | |
1621 | ((x …) | |
1622 | (length #'(x …)))) | |
1623 | env)))) | |
1624 | ||
aa8630ef MW |
1625 | ;;; Local Variables: |
1626 | ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) | |
1624e149 | 1627 | ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) |
aa8630ef | 1628 | ;;; End: |