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 ...) | |
37d574b3 AW |
387 | (and (eq? (car (frame-call-representation (cadr frames))) |
388 | 'catch) | |
99d7688b NL |
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 ...) | |
37d574b3 AW |
397 | (and (eq? (car (frame-call-representation (car frames))) |
398 | 'make-stack) | |
399 | (eq? (car (frame-call-representation (car (last-pair frames)))) | |
400 | 'with-throw-handler))))) | |
99d7688b | 401 | |
d2797644 NJ |
402 | ;;; |
403 | ;;; letrec init evaluation | |
404 | ;;; | |
405 | ||
406 | (with-test-prefix "letrec init evaluation" | |
407 | ||
408 | (pass-if "lots of inits calculated in correct order" | |
409 | (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd) | |
410 | (e 'e) (f 'f) (g 'g) (h 'h) | |
411 | (i 'i) (j 'j) (k 'k) (l 'l) | |
412 | (m 'm) (n 'n) (o 'o) (p 'p) | |
413 | (q 'q) (r 'r) (s 's) (t 't) | |
414 | (u 'u) (v 'v) (w 'w) (x 'x) | |
415 | (y 'y) (z 'z)) | |
416 | (list a b c d e f g h i j k l m | |
417 | n o p q r s t u v w x y z)) | |
418 | '(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 | ||
42ddb3cb LC |
421 | ;;; |
422 | ;;; values | |
423 | ;;; | |
424 | ||
425 | (with-test-prefix "values" | |
426 | ||
427 | (pass-if "single value" | |
428 | (equal? 1 (values 1))) | |
429 | ||
430 | (pass-if "call-with-values" | |
431 | (equal? (call-with-values (lambda () (values 1 2 3 4)) list) | |
432 | '(1 2 3 4))) | |
433 | ||
434 | (pass-if "equal?" | |
435 | (equal? (values 1 2 3 4) (values 1 2 3 4)))) | |
4f2ec3be | 436 | |
f1046e6b LC |
437 | ;;; |
438 | ;;; stack overflow handling | |
439 | ;;; | |
440 | ||
f57d4316 AW |
441 | (with-test-prefix "stack overflow handlers" |
442 | (define (trigger-overflow) | |
443 | (trigger-overflow) | |
444 | (error "not reached")) | |
445 | ||
446 | (define (dynwind-test n) | |
447 | (catch 'foo | |
448 | (lambda () | |
449 | (call-with-stack-overflow-handler n | |
450 | (lambda () | |
451 | (dynamic-wind (lambda () #t) | |
452 | trigger-overflow | |
453 | trigger-overflow)) | |
454 | (lambda () | |
455 | (throw 'foo)))) | |
456 | (lambda _ #t))) | |
457 | ||
458 | (pass-if-exception "limit should be number" | |
459 | exception:wrong-type-arg | |
460 | (call-with-stack-overflow-handler #t | |
461 | trigger-overflow trigger-overflow)) | |
f1046e6b | 462 | |
f57d4316 AW |
463 | (pass-if-exception "limit should be exact integer" |
464 | exception:wrong-type-arg | |
465 | (call-with-stack-overflow-handler 2.0 | |
466 | trigger-overflow trigger-overflow)) | |
467 | ||
468 | (pass-if-exception "limit should be nonnegative" | |
469 | exception:out-of-range | |
470 | (call-with-stack-overflow-handler -1 | |
471 | trigger-overflow trigger-overflow)) | |
472 | ||
473 | (pass-if-exception "limit should be positive" | |
474 | exception:out-of-range | |
475 | (call-with-stack-overflow-handler 0 | |
476 | trigger-overflow trigger-overflow)) | |
477 | ||
478 | (pass-if-exception "limit should be within address space" | |
479 | exception:out-of-range | |
480 | (call-with-stack-overflow-handler (ash 1 64) | |
481 | trigger-overflow trigger-overflow)) | |
482 | ||
483 | (pass-if "exception on overflow" | |
484 | (catch 'foo | |
485 | (lambda () | |
486 | (call-with-stack-overflow-handler 10000 | |
487 | trigger-overflow | |
488 | (lambda () | |
489 | (throw 'foo)))) | |
490 | (lambda _ #t))) | |
491 | ||
492 | (pass-if "exception on overflow with dynwind" | |
493 | ;; Try all limits between 1 and 200 words. | |
494 | (let lp ((n 1)) | |
495 | (or (= n 200) | |
496 | (and (dynwind-test n) | |
497 | (lp (1+ n)))))) | |
498 | ||
499 | (pass-if-exception "overflow handler should return number" | |
500 | exception:wrong-type-arg | |
501 | (call-with-stack-overflow-handler 1000 | |
502 | trigger-overflow | |
503 | (lambda () #t))) | |
504 | (pass-if-exception "overflow handler should return exact integer" | |
505 | exception:wrong-type-arg | |
506 | (call-with-stack-overflow-handler 1000 | |
507 | trigger-overflow | |
508 | (lambda () 2.0))) | |
509 | (pass-if-exception "overflow handler should be nonnegative" | |
510 | exception:out-of-range | |
511 | (call-with-stack-overflow-handler 1000 | |
512 | trigger-overflow | |
513 | (lambda () -1))) | |
514 | (pass-if-exception "overflow handler should be positive" | |
515 | exception:out-of-range | |
516 | (call-with-stack-overflow-handler 1000 | |
517 | trigger-overflow | |
518 | (lambda () 0))) | |
519 | ||
520 | (letrec ((fac (lambda (n) | |
521 | (if (zero? n) 1 (* n (fac (1- n))))))) | |
522 | (pass-if-equal "overflow handler can allow recursion to continue" | |
523 | (fac 10) | |
524 | (call-with-stack-overflow-handler 1 | |
525 | (lambda () (fac 10)) | |
526 | (lambda () 1))))) | |
f1046e6b | 527 | |
c438cd71 LC |
528 | ;;; |
529 | ;;; docstrings | |
530 | ;;; | |
531 | ||
532 | (with-test-prefix "docstrings" | |
533 | ||
534 | (pass-if-equal "fixed closure" | |
535 | '("hello" "world") | |
536 | (map procedure-documentation | |
537 | (list (eval '(lambda (a b) "hello" (+ a b)) | |
538 | (current-module)) | |
539 | (eval '(lambda (a b) "world" (- a b)) | |
540 | (current-module))))) | |
541 | ||
542 | (pass-if-equal "fixed closure with many args" | |
543 | "So many args." | |
544 | (procedure-documentation | |
545 | (eval '(lambda (a b c d e f g h i j k) | |
546 | "So many args." | |
547 | (+ a b)) | |
548 | (current-module)))) | |
549 | ||
550 | (pass-if-equal "general closure" | |
551 | "How general." | |
552 | (procedure-documentation | |
553 | (eval '(lambda* (a b #:key k #:rest r) | |
554 | "How general." | |
555 | (+ a b)) | |
556 | (current-module))))) | |
557 | ||
d062a8c1 AW |
558 | ;;; |
559 | ;;; local-eval | |
560 | ;;; | |
561 | ||
562 | (with-test-prefix "local evaluation" | |
563 | ||
564 | (pass-if "local-eval" | |
565 | ||
2f3e4364 MW |
566 | (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3)) |
567 | (define-syntax-rule (foo x) (quote x)) | |
568 | (the-environment)) | |
569 | (current-module))) | |
d062a8c1 AW |
570 | (env2 (local-eval '(let ((x 111) (a 'a)) |
571 | (define-syntax-rule (bar x) (quote x)) | |
572 | (the-environment)) | |
573 | env1))) | |
574 | (local-eval '(set! x 11) env1) | |
575 | (local-eval '(set! y 22) env1) | |
576 | (local-eval '(set! z 33) env2) | |
577 | (and (equal? (local-eval '(list x y z) env1) | |
578 | '(11 22 33)) | |
579 | (equal? (local-eval '(list x y z a) env2) | |
580 | '(111 22 33 a))))) | |
581 | ||
582 | (pass-if "local-compile" | |
583 | ||
2f3e4364 MW |
584 | (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3)) |
585 | (define-syntax-rule (foo x) (quote x)) | |
586 | (the-environment)) | |
587 | (current-module))) | |
d062a8c1 AW |
588 | (env2 (local-compile '(let ((x 111) (a 'a)) |
589 | (define-syntax-rule (bar x) (quote x)) | |
590 | (the-environment)) | |
591 | env1))) | |
592 | (local-compile '(set! x 11) env1) | |
593 | (local-compile '(set! y 22) env1) | |
594 | (local-compile '(set! z 33) env2) | |
595 | (and (equal? (local-compile '(list x y z) env1) | |
596 | '(11 22 33)) | |
597 | (equal? (local-compile '(list x y z a) env2) | |
598 | '(111 22 33 a))))) | |
599 | ||
600 | (pass-if "the-environment within a macro" | |
601 | (let ((module-a-name '(test module the-environment a)) | |
602 | (module-b-name '(test module the-environment b))) | |
603 | (let ((module-a (resolve-module module-a-name)) | |
604 | (module-b (resolve-module module-b-name))) | |
605 | (module-use! module-a (resolve-interface '(guile))) | |
606 | (module-use! module-a (resolve-interface '(ice-9 local-eval))) | |
607 | (eval '(begin | |
608 | (define z 3) | |
609 | (define-syntax-rule (test) | |
610 | (let ((x 1) (y 2)) | |
611 | (the-environment)))) | |
612 | module-a) | |
613 | (module-use! module-b (resolve-interface '(guile))) | |
2f3e4364 MW |
614 | (let ((env (local-eval `(let ((x 111) (y 222)) |
615 | ((@@ ,module-a-name test))) | |
616 | module-b))) | |
d062a8c1 AW |
617 | (equal? (local-eval '(list x y z) env) |
618 | '(1 2 3)))))) | |
619 | ||
620 | (pass-if "capture pattern variables" | |
621 | (let ((env (syntax-case #'(((a 1) (b 2) (c 3)) | |
622 | ((d 4) (e 5) (f 6))) () | |
623 | ((((k v) ...) ...) (the-environment))))) | |
624 | (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env)) | |
625 | '((a b c 1 2 3) (d e f 4 5 6))))) | |
626 | ||
627 | (pass-if "mixed primitive-eval, local-eval and local-compile" | |
628 | ||
629 | (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3)) | |
630 | (define-syntax-rule (foo x) (quote x)) | |
631 | (the-environment)))) | |
632 | (env2 (local-eval '(let ((x 111) (a 'a)) | |
633 | (define-syntax-rule (bar x) (quote x)) | |
634 | (the-environment)) | |
635 | env1)) | |
636 | (env3 (local-compile '(let ((y 222) (b 'b)) | |
637 | (the-environment)) | |
638 | env2))) | |
639 | (local-eval '(set! x 11) env1) | |
640 | (local-compile '(set! y 22) env2) | |
641 | (local-eval '(set! z 33) env2) | |
642 | (local-compile '(set! a (* y 2)) env3) | |
643 | (and (equal? (local-compile '(list x y z) env1) | |
644 | '(11 22 33)) | |
645 | (equal? (local-eval '(list x y z a) env2) | |
646 | '(111 22 33 444)) | |
647 | (equal? (local-eval '(list x y z a b) env3) | |
648 | '(111 222 33 444 b)))))) | |
649 | ||
414959ca | 650 | ;;; eval.test ends here |