Commit | Line | Data |
---|---|---|
141443d7 | 1 | ;;;; eval.test --- tests guile's evaluator -*- scheme -*- |
1a95246a | 2 | ;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
141443d7 | 3 | ;;;; |
73be1d9e MV |
4 | ;;;; This library is free software; you can redistribute it and/or |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
8 | ;;;; |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
141443d7 | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
141443d7 | 17 | |
d6e04e7c DH |
18 | (define-module (test-suite test-eval) |
19 | :use-module (test-suite lib) | |
113e7c25 | 20 | :use-module ((srfi srfi-1) :select (unfold count)) |
f57d4316 | 21 | :use-module ((system vm vm) :select (call-with-stack-overflow-handler)) |
c271065e | 22 | :use-module ((system vm frame) :select (frame-call-representation)) |
d062a8c1 AW |
23 | :use-module (ice-9 documentation) |
24 | :use-module (ice-9 local-eval)) | |
141443d7 DH |
25 | |
26 | ||
62360b89 DH |
27 | (define exception:bad-expression |
28 | (cons 'syntax-error "Bad expression")) | |
29 | ||
8bb0b3cc AW |
30 | (define exception:failed-match |
31 | (cons 'syntax-error "failed to match any pattern")) | |
32 | ||
a2230b65 AW |
33 | (define exception:not-a-list |
34 | (cons 'wrong-type-arg "Not a list")) | |
35 | ||
36 | (define exception:wrong-length | |
37 | (cons 'wrong-type-arg "wrong length")) | |
62360b89 | 38 | |
141443d7 DH |
39 | ;;; |
40 | ;;; miscellaneous | |
41 | ;;; | |
42 | ||
141443d7 | 43 | (define (documented? object) |
5c96bc39 | 44 | (not (not (object-documentation object)))) |
141443d7 DH |
45 | |
46 | ||
47 | ;;; | |
62360b89 | 48 | ;;; memoization |
141443d7 DH |
49 | ;;; |
50 | ||
62360b89 DH |
51 | (with-test-prefix "memoization" |
52 | ||
53 | (with-test-prefix "copy-tree" | |
54 | ||
55 | (pass-if "(#t . #(#t))" | |
56 | (let* ((foo (cons #t (vector #t))) | |
57 | (bar (copy-tree foo))) | |
58 | (vector-set! (cdr foo) 0 #f) | |
59 | (equal? bar '(#t . #(#t))))) | |
60 | ||
61 | (pass-if-exception "circular lists in forms" | |
0f458a37 | 62 | exception:wrong-type-arg |
62360b89 DH |
63 | (let ((foo (list #f))) |
64 | (set-cdr! foo foo) | |
65 | (copy-tree foo)))) | |
141443d7 | 66 | |
62360b89 DH |
67 | (pass-if "transparency" |
68 | (let ((x '(begin 1))) | |
69 | (eval x (current-module)) | |
70 | (equal? '(begin 1) x)))) | |
414959ca | 71 | |
62360b89 DH |
72 | |
73 | ;;; | |
74 | ;;; eval | |
75 | ;;; | |
76 | ||
77 | (with-test-prefix "evaluator" | |
414959ca | 78 | |
adb8054c MW |
79 | (pass-if "definitions return #<unspecified>" |
80 | (eq? (primitive-eval '(define test-var 'foo)) | |
81 | (if #f #f))) | |
82 | ||
08c608e1 DH |
83 | (with-test-prefix "symbol lookup" |
84 | ||
85 | (with-test-prefix "top level" | |
86 | ||
87 | (with-test-prefix "unbound" | |
88 | ||
89 | (pass-if-exception "variable reference" | |
90 | exception:unbound-var | |
91 | x) | |
92 | ||
93 | (pass-if-exception "procedure" | |
94 | exception:unbound-var | |
95 | (x))))) | |
96 | ||
141443d7 DH |
97 | (with-test-prefix "parameter error" |
98 | ||
99 | ;; This is currently a bug in guile: | |
100 | ;; Macros are accepted as function parameters. | |
101 | ;; Functions that 'apply' macros are rewritten!!! | |
102 | ||
8bb0b3cc AW |
103 | (pass-if-exception "macro as argument" |
104 | exception:failed-match | |
105 | (primitive-eval | |
106 | '(let ((f (lambda (p a b) (p a b)))) | |
107 | (f and #t #t)))) | |
108 | ||
109 | (pass-if-exception "passing macro as parameter" | |
110 | exception:failed-match | |
111 | (primitive-eval | |
112 | '(let* ((f (lambda (p a b) (p a b))) | |
113 | (foo (procedure-source f))) | |
114 | (f and #t #t) | |
115 | (equal? (procedure-source f) foo)))) | |
141443d7 DH |
116 | |
117 | )) | |
118 | ||
08c608e1 | 119 | ;;; |
8ab3d8a0 | 120 | ;;; call |
08c608e1 DH |
121 | ;;; |
122 | ||
8ab3d8a0 | 123 | (with-test-prefix "call" |
08c608e1 DH |
124 | |
125 | (with-test-prefix "wrong number of arguments" | |
126 | ||
127 | (pass-if-exception "((lambda () #f) 1)" | |
128 | exception:wrong-num-args | |
129 | ((lambda () #f) 1)) | |
130 | ||
131 | (pass-if-exception "((lambda (x) #f))" | |
132 | exception:wrong-num-args | |
133 | ((lambda (x) #f))) | |
134 | ||
135 | (pass-if-exception "((lambda (x) #f) 1 2)" | |
136 | exception:wrong-num-args | |
137 | ((lambda (x) #f) 1 2)) | |
138 | ||
139 | (pass-if-exception "((lambda (x y) #f))" | |
140 | exception:wrong-num-args | |
141 | ((lambda (x y) #f))) | |
142 | ||
143 | (pass-if-exception "((lambda (x y) #f) 1)" | |
144 | exception:wrong-num-args | |
145 | ((lambda (x y) #f) 1)) | |
146 | ||
147 | (pass-if-exception "((lambda (x y) #f) 1 2 3)" | |
148 | exception:wrong-num-args | |
149 | ((lambda (x y) #f) 1 2 3)) | |
150 | ||
151 | (pass-if-exception "((lambda (x . rest) #f))" | |
152 | exception:wrong-num-args | |
153 | ((lambda (x . rest) #f))) | |
154 | ||
155 | (pass-if-exception "((lambda (x y . rest) #f))" | |
156 | exception:wrong-num-args | |
157 | ((lambda (x y . rest) #f))) | |
158 | ||
159 | (pass-if-exception "((lambda (x y . rest) #f) 1)" | |
160 | exception:wrong-num-args | |
161 | ((lambda (x y . rest) #f) 1)))) | |
162 | ||
8ab3d8a0 KR |
163 | ;;; |
164 | ;;; apply | |
165 | ;;; | |
166 | ||
167 | (with-test-prefix "apply" | |
168 | ||
169 | (with-test-prefix "scm_tc7_subr_2o" | |
170 | ||
171 | ;; prior to guile 1.6.9 and 1.8.1 this called the function with | |
0f458a37 | 172 | ;; SCM_UNDEFINED, which in the case of make-vector resulted in |
8ab3d8a0 KR |
173 | ;; wrong-type-arg, instead of the intended wrong-num-args |
174 | (pass-if-exception "0 args" exception:wrong-num-args | |
175 | (apply make-vector '())) | |
176 | ||
177 | (pass-if "1 arg" | |
178 | (vector? (apply make-vector '(1)))) | |
179 | ||
180 | (pass-if "2 args" | |
181 | (vector? (apply make-vector '(1 2)))) | |
182 | ||
183 | ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected | |
184 | (pass-if-exception "3 args" exception:wrong-num-args | |
185 | (apply make-vector '(1 2 3))))) | |
186 | ||
141443d7 DH |
187 | ;;; |
188 | ;;; map | |
189 | ;;; | |
190 | ||
191 | (with-test-prefix "map" | |
192 | ||
193 | ;; Is documentation available? | |
194 | ||
195 | (expect-fail "documented?" | |
6ad9007a | 196 | (documented? map)) |
141443d7 DH |
197 | |
198 | (with-test-prefix "argument error" | |
199 | ||
200 | (with-test-prefix "non list argument" | |
201 | #t) | |
202 | ||
203 | (with-test-prefix "different length lists" | |
204 | ||
6b4113af | 205 | (pass-if-exception "first list empty" |
a2230b65 | 206 | exception:wrong-length |
6b4113af DH |
207 | (map + '() '(1))) |
208 | ||
209 | (pass-if-exception "second list empty" | |
a2230b65 | 210 | exception:wrong-length |
6b4113af DH |
211 | (map + '(1) '())) |
212 | ||
213 | (pass-if-exception "first list shorter" | |
a2230b65 | 214 | exception:wrong-length |
6b4113af DH |
215 | (map + '(1) '(2 3))) |
216 | ||
217 | (pass-if-exception "second list shorter" | |
a2230b65 | 218 | exception:wrong-length |
6b4113af | 219 | (map + '(1 2) '(3))) |
141443d7 | 220 | ))) |
23d72566 | 221 | |
1a95246a AW |
222 | (with-test-prefix "for-each" |
223 | ||
224 | (pass-if-exception "1 arg, non-list, even number of elements" | |
225 | exception:not-a-list | |
226 | (for-each values '(1 2 3 4 . 5))) | |
227 | ||
228 | (pass-if-exception "1 arg, non-list, odd number of elements" | |
229 | exception:not-a-list | |
230 | (for-each values '(1 2 3 . 4)))) | |
231 | ||
23d72566 KR |
232 | ;;; |
233 | ;;; define with procedure-name | |
234 | ;;; | |
235 | ||
23d72566 KR |
236 | ;; names are only set on top-level procedures (currently), so these can't be |
237 | ;; hidden in a let | |
238 | ;; | |
239 | (define foo-closure (lambda () "hello")) | |
240 | (define bar-closure foo-closure) | |
3fd8807e AW |
241 | ;; make sure that make-procedure-with-setter returns an anonymous |
242 | ;; procedure-with-setter by passing it an anonymous getter. | |
243 | (define foo-pws (make-procedure-with-setter | |
244 | (lambda (x) (car x)) | |
245 | (lambda (x y) (set-car! x y)))) | |
23d72566 KR |
246 | (define bar-pws foo-pws) |
247 | ||
248 | (with-test-prefix "define set procedure-name" | |
249 | ||
936d0bf3 | 250 | (pass-if "closure" |
23d72566 KR |
251 | (eq? 'foo-closure (procedure-name bar-closure))) |
252 | ||
936d0bf3 | 253 | (expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported |
3fd8807e | 254 | (eq? 'foo-pws (procedure-name bar-pws)))) |
23d72566 | 255 | |
2b6b5908 DH |
256 | ;;; |
257 | ;;; promises | |
258 | ;;; | |
259 | ||
260 | (with-test-prefix "promises" | |
261 | ||
262 | (with-test-prefix "basic promise behaviour" | |
263 | ||
264 | (pass-if "delay gives a promise" | |
265 | (promise? (delay 1))) | |
266 | ||
267 | (pass-if "force evaluates a promise" | |
268 | (eqv? (force (delay (+ 1 2))) 3)) | |
269 | ||
270 | (pass-if "a forced promise is a promise" | |
271 | (let ((p (delay (+ 1 2)))) | |
272 | (force p) | |
273 | (promise? p))) | |
274 | ||
275 | (pass-if "forcing a forced promise works" | |
276 | (let ((p (delay (+ 1 2)))) | |
277 | (force p) | |
278 | (eqv? (force p) 3))) | |
279 | ||
280 | (pass-if "a promise is evaluated once" | |
281 | (let* ((x 1) | |
282 | (p (delay (+ x 1)))) | |
283 | (force p) | |
284 | (set! x (+ x 1)) | |
285 | (eqv? (force p) 2))) | |
286 | ||
287 | (pass-if "a promise may call itself" | |
288 | (define p | |
289 | (let ((x 0)) | |
290 | (delay | |
291 | (begin | |
292 | (set! x (+ x 1)) | |
293 | (if (> x 1) x (force p)))))) | |
294 | (eqv? (force p) 2)) | |
295 | ||
296 | (pass-if "a promise carries its environment" | |
297 | (let* ((x 1) (p #f)) | |
298 | (let* ((x 2)) | |
299 | (set! p (delay (+ x 1)))) | |
300 | (eqv? (force p) 3))) | |
301 | ||
302 | (pass-if "a forced promise does not reference its environment" | |
303 | (let* ((g (make-guardian)) | |
304 | (p #f)) | |
305 | (let* ((x (cons #f #f))) | |
306 | (g x) | |
307 | (set! p (delay (car x)))) | |
308 | (force p) | |
309 | (gc) | |
310 | (if (not (equal? (g) (cons #f #f))) | |
311 | (throw 'unresolved) | |
312 | #t)))) | |
313 | ||
314 | (with-test-prefix "extended promise behaviour" | |
315 | ||
316 | (pass-if-exception "forcing a non-promise object is not supported" | |
317 | exception:wrong-type-arg | |
318 | (force 1)) | |
319 | ||
e10cf6b9 AW |
320 | (pass-if "unmemoizing a promise" |
321 | (display-backtrace | |
322 | (let ((stack #f)) | |
323 | (false-if-exception | |
324 | (with-throw-handler #t | |
325 | (lambda () | |
326 | (let ((f (lambda (g) (delay (g))))) | |
327 | (force (f error)))) | |
328 | (lambda _ | |
329 | (set! stack (make-stack #t))))) | |
330 | stack) | |
331 | (%make-void-port "w")) | |
332 | #t))) | |
2b6b5908 | 333 | |
113e7c25 LC |
334 | |
335 | ;;; | |
336 | ;;; stacks | |
337 | ;;; | |
338 | ||
339 | (define (stack->frames stack) | |
340 | ;; Return the list of frames comprising STACK. | |
341 | (unfold (lambda (i) | |
342 | (>= i (stack-length stack))) | |
343 | (lambda (i) | |
344 | (stack-ref stack i)) | |
345 | 1+ | |
346 | 0)) | |
347 | ||
99d7688b NL |
348 | (define (make-tagged-trimmed-stack tag spec) |
349 | (catch 'result | |
350 | (lambda () | |
351 | (call-with-prompt | |
352 | tag | |
353 | (lambda () | |
354 | (with-throw-handler 'wrong-type-arg | |
355 | (lambda () (substring 'wrong 'type 'arg)) | |
356 | (lambda _ (throw 'result (apply make-stack spec))))) | |
357 | (lambda () (throw 'make-stack-failed)))) | |
358 | (lambda (key result) result))) | |
359 | ||
360 | (define tag (make-prompt-tag "foo")) | |
361 | ||
649d3ea7 | 362 | (with-test-prefix "stacks" |
1ab116f3 | 363 | (pass-if "stack involving a primitive" |
649d3ea7 NL |
364 | ;; The primitive involving the error must appear exactly once on the |
365 | ;; stack. | |
366 | (let* ((stack (make-tagged-trimmed-stack tag '(#t))) | |
367 | (frames (stack->frames stack)) | |
368 | (num (count (lambda (frame) (eq? (frame-procedure frame) | |
369 | substring)) | |
370 | frames))) | |
371 | (= num 1))) | |
372 | ||
373 | (pass-if "arguments of a primitive stack frame" | |
374 | ;; Create a stack with two primitive frames and make sure the | |
375 | ;; arguments are correct. | |
376 | (let* ((stack (make-tagged-trimmed-stack tag '(#t))) | |
c271065e AW |
377 | (call-list (map frame-call-representation (stack->frames stack)))) |
378 | (and (equal? (car call-list) '(make-stack #t)) | |
379 | (pair? (member '(substring wrong type arg) | |
649d3ea7 NL |
380 | (cdr call-list)))))) |
381 | ||
99d7688b NL |
382 | (pass-if "inner trim with prompt tag" |
383 | (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag))) | |
384 | (frames (stack->frames stack))) | |
385 | ;; the top frame on the stack is the lambda inside the 'catch, and the | |
386 | ;; next frame is the (catch 'result ...) | |
387 | (and (eq? (frame-procedure (cadr frames)) | |
388 | catch) | |
389 | (eq? (car (frame-arguments (cadr frames))) | |
390 | 'result)))) | |
391 | ||
392 | (pass-if "outer trim with prompt tag" | |
393 | (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag))) | |
394 | (frames (stack->frames stack))) | |
395 | ;; the top frame on the stack is the make-stack call, and the last | |
396 | ;; frame is the (with-throw-handler 'wrong-type-arg ...) | |
397 | (and (eq? (frame-procedure (car frames)) | |
398 | make-stack) | |
399 | (eq? (frame-procedure (car (last-pair frames))) | |
400 | with-throw-handler) | |
401 | (eq? (car (frame-arguments (car (last-pair frames)))) | |
402 | 'wrong-type-arg))))) | |
403 | ||
d2797644 NJ |
404 | ;;; |
405 | ;;; letrec init evaluation | |
406 | ;;; | |
407 | ||
408 | (with-test-prefix "letrec init evaluation" | |
409 | ||
410 | (pass-if "lots of inits calculated in correct order" | |
411 | (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd) | |
412 | (e 'e) (f 'f) (g 'g) (h 'h) | |
413 | (i 'i) (j 'j) (k 'k) (l 'l) | |
414 | (m 'm) (n 'n) (o 'o) (p 'p) | |
415 | (q 'q) (r 'r) (s 's) (t 't) | |
416 | (u 'u) (v 'v) (w 'w) (x 'x) | |
417 | (y 'y) (z 'z)) | |
418 | (list a b c d e f g h i j k l m | |
419 | n o p q r s t u v w x y z)) | |
420 | '(a b c d e f g h i j k l m | |
421 | n o p q r s t u v w x y z)))) | |
422 | ||
42ddb3cb LC |
423 | ;;; |
424 | ;;; values | |
425 | ;;; | |
426 | ||
427 | (with-test-prefix "values" | |
428 | ||
429 | (pass-if "single value" | |
430 | (equal? 1 (values 1))) | |
431 | ||
432 | (pass-if "call-with-values" | |
433 | (equal? (call-with-values (lambda () (values 1 2 3 4)) list) | |
434 | '(1 2 3 4))) | |
435 | ||
436 | (pass-if "equal?" | |
437 | (equal? (values 1 2 3 4) (values 1 2 3 4)))) | |
4f2ec3be | 438 | |
f1046e6b LC |
439 | ;;; |
440 | ;;; stack overflow handling | |
441 | ;;; | |
442 | ||
f57d4316 AW |
443 | (with-test-prefix "stack overflow handlers" |
444 | (define (trigger-overflow) | |
445 | (trigger-overflow) | |
446 | (error "not reached")) | |
447 | ||
448 | (define (dynwind-test n) | |
449 | (catch 'foo | |
450 | (lambda () | |
451 | (call-with-stack-overflow-handler n | |
452 | (lambda () | |
453 | (dynamic-wind (lambda () #t) | |
454 | trigger-overflow | |
455 | trigger-overflow)) | |
456 | (lambda () | |
457 | (throw 'foo)))) | |
458 | (lambda _ #t))) | |
459 | ||
460 | (pass-if-exception "limit should be number" | |
461 | exception:wrong-type-arg | |
462 | (call-with-stack-overflow-handler #t | |
463 | trigger-overflow trigger-overflow)) | |
f1046e6b | 464 | |
f57d4316 AW |
465 | (pass-if-exception "limit should be exact integer" |
466 | exception:wrong-type-arg | |
467 | (call-with-stack-overflow-handler 2.0 | |
468 | trigger-overflow trigger-overflow)) | |
469 | ||
470 | (pass-if-exception "limit should be nonnegative" | |
471 | exception:out-of-range | |
472 | (call-with-stack-overflow-handler -1 | |
473 | trigger-overflow trigger-overflow)) | |
474 | ||
475 | (pass-if-exception "limit should be positive" | |
476 | exception:out-of-range | |
477 | (call-with-stack-overflow-handler 0 | |
478 | trigger-overflow trigger-overflow)) | |
479 | ||
480 | (pass-if-exception "limit should be within address space" | |
481 | exception:out-of-range | |
482 | (call-with-stack-overflow-handler (ash 1 64) | |
483 | trigger-overflow trigger-overflow)) | |
484 | ||
485 | (pass-if "exception on overflow" | |
486 | (catch 'foo | |
487 | (lambda () | |
488 | (call-with-stack-overflow-handler 10000 | |
489 | trigger-overflow | |
490 | (lambda () | |
491 | (throw 'foo)))) | |
492 | (lambda _ #t))) | |
493 | ||
494 | (pass-if "exception on overflow with dynwind" | |
495 | ;; Try all limits between 1 and 200 words. | |
496 | (let lp ((n 1)) | |
497 | (or (= n 200) | |
498 | (and (dynwind-test n) | |
499 | (lp (1+ n)))))) | |
500 | ||
501 | (pass-if-exception "overflow handler should return number" | |
502 | exception:wrong-type-arg | |
503 | (call-with-stack-overflow-handler 1000 | |
504 | trigger-overflow | |
505 | (lambda () #t))) | |
506 | (pass-if-exception "overflow handler should return exact integer" | |
507 | exception:wrong-type-arg | |
508 | (call-with-stack-overflow-handler 1000 | |
509 | trigger-overflow | |
510 | (lambda () 2.0))) | |
511 | (pass-if-exception "overflow handler should be nonnegative" | |
512 | exception:out-of-range | |
513 | (call-with-stack-overflow-handler 1000 | |
514 | trigger-overflow | |
515 | (lambda () -1))) | |
516 | (pass-if-exception "overflow handler should be positive" | |
517 | exception:out-of-range | |
518 | (call-with-stack-overflow-handler 1000 | |
519 | trigger-overflow | |
520 | (lambda () 0))) | |
521 | ||
522 | (letrec ((fac (lambda (n) | |
523 | (if (zero? n) 1 (* n (fac (1- n))))))) | |
524 | (pass-if-equal "overflow handler can allow recursion to continue" | |
525 | (fac 10) | |
526 | (call-with-stack-overflow-handler 1 | |
527 | (lambda () (fac 10)) | |
528 | (lambda () 1))))) | |
f1046e6b | 529 | |
c438cd71 LC |
530 | ;;; |
531 | ;;; docstrings | |
532 | ;;; | |
533 | ||
534 | (with-test-prefix "docstrings" | |
535 | ||
536 | (pass-if-equal "fixed closure" | |
537 | '("hello" "world") | |
538 | (map procedure-documentation | |
539 | (list (eval '(lambda (a b) "hello" (+ a b)) | |
540 | (current-module)) | |
541 | (eval '(lambda (a b) "world" (- a b)) | |
542 | (current-module))))) | |
543 | ||
544 | (pass-if-equal "fixed closure with many args" | |
545 | "So many args." | |
546 | (procedure-documentation | |
547 | (eval '(lambda (a b c d e f g h i j k) | |
548 | "So many args." | |
549 | (+ a b)) | |
550 | (current-module)))) | |
551 | ||
552 | (pass-if-equal "general closure" | |
553 | "How general." | |
554 | (procedure-documentation | |
555 | (eval '(lambda* (a b #:key k #:rest r) | |
556 | "How general." | |
557 | (+ a b)) | |
558 | (current-module))))) | |
559 | ||
d062a8c1 AW |
560 | ;;; |
561 | ;;; local-eval | |
562 | ;;; | |
563 | ||
564 | (with-test-prefix "local evaluation" | |
565 | ||
566 | (pass-if "local-eval" | |
567 | ||
2f3e4364 MW |
568 | (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3)) |
569 | (define-syntax-rule (foo x) (quote x)) | |
570 | (the-environment)) | |
571 | (current-module))) | |
d062a8c1 AW |
572 | (env2 (local-eval '(let ((x 111) (a 'a)) |
573 | (define-syntax-rule (bar x) (quote x)) | |
574 | (the-environment)) | |
575 | env1))) | |
576 | (local-eval '(set! x 11) env1) | |
577 | (local-eval '(set! y 22) env1) | |
578 | (local-eval '(set! z 33) env2) | |
579 | (and (equal? (local-eval '(list x y z) env1) | |
580 | '(11 22 33)) | |
581 | (equal? (local-eval '(list x y z a) env2) | |
582 | '(111 22 33 a))))) | |
583 | ||
584 | (pass-if "local-compile" | |
585 | ||
2f3e4364 MW |
586 | (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3)) |
587 | (define-syntax-rule (foo x) (quote x)) | |
588 | (the-environment)) | |
589 | (current-module))) | |
d062a8c1 AW |
590 | (env2 (local-compile '(let ((x 111) (a 'a)) |
591 | (define-syntax-rule (bar x) (quote x)) | |
592 | (the-environment)) | |
593 | env1))) | |
594 | (local-compile '(set! x 11) env1) | |
595 | (local-compile '(set! y 22) env1) | |
596 | (local-compile '(set! z 33) env2) | |
597 | (and (equal? (local-compile '(list x y z) env1) | |
598 | '(11 22 33)) | |
599 | (equal? (local-compile '(list x y z a) env2) | |
600 | '(111 22 33 a))))) | |
601 | ||
602 | (pass-if "the-environment within a macro" | |
603 | (let ((module-a-name '(test module the-environment a)) | |
604 | (module-b-name '(test module the-environment b))) | |
605 | (let ((module-a (resolve-module module-a-name)) | |
606 | (module-b (resolve-module module-b-name))) | |
607 | (module-use! module-a (resolve-interface '(guile))) | |
608 | (module-use! module-a (resolve-interface '(ice-9 local-eval))) | |
609 | (eval '(begin | |
610 | (define z 3) | |
611 | (define-syntax-rule (test) | |
612 | (let ((x 1) (y 2)) | |
613 | (the-environment)))) | |
614 | module-a) | |
615 | (module-use! module-b (resolve-interface '(guile))) | |
2f3e4364 MW |
616 | (let ((env (local-eval `(let ((x 111) (y 222)) |
617 | ((@@ ,module-a-name test))) | |
618 | module-b))) | |
d062a8c1 AW |
619 | (equal? (local-eval '(list x y z) env) |
620 | '(1 2 3)))))) | |
621 | ||
622 | (pass-if "capture pattern variables" | |
623 | (let ((env (syntax-case #'(((a 1) (b 2) (c 3)) | |
624 | ((d 4) (e 5) (f 6))) () | |
625 | ((((k v) ...) ...) (the-environment))))) | |
626 | (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env)) | |
627 | '((a b c 1 2 3) (d e f 4 5 6))))) | |
628 | ||
629 | (pass-if "mixed primitive-eval, local-eval and local-compile" | |
630 | ||
631 | (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3)) | |
632 | (define-syntax-rule (foo x) (quote x)) | |
633 | (the-environment)))) | |
634 | (env2 (local-eval '(let ((x 111) (a 'a)) | |
635 | (define-syntax-rule (bar x) (quote x)) | |
636 | (the-environment)) | |
637 | env1)) | |
638 | (env3 (local-compile '(let ((y 222) (b 'b)) | |
639 | (the-environment)) | |
640 | env2))) | |
641 | (local-eval '(set! x 11) env1) | |
642 | (local-compile '(set! y 22) env2) | |
643 | (local-eval '(set! z 33) env2) | |
644 | (local-compile '(set! a (* y 2)) env3) | |
645 | (and (equal? (local-compile '(list x y z) env1) | |
646 | '(11 22 33)) | |
647 | (equal? (local-eval '(list x y z a) env2) | |
648 | '(111 22 33 444)) | |
649 | (equal? (local-eval '(list x y z a b) env3) | |
650 | '(111 222 33 444 b)))))) | |
651 | ||
414959ca | 652 | ;;; eval.test ends here |