Commit | Line | Data |
---|---|---|
141443d7 | 1 | ;;;; eval.test --- tests guile's evaluator -*- scheme -*- |
113e7c25 | 2 | ;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 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)) |
d6e04e7c | 21 | :use-module (ice-9 documentation)) |
141443d7 DH |
22 | |
23 | ||
62360b89 DH |
24 | (define exception:bad-expression |
25 | (cons 'syntax-error "Bad expression")) | |
26 | ||
8bb0b3cc AW |
27 | (define exception:failed-match |
28 | (cons 'syntax-error "failed to match any pattern")) | |
29 | ||
62360b89 | 30 | |
141443d7 DH |
31 | ;;; |
32 | ;;; miscellaneous | |
33 | ;;; | |
34 | ||
141443d7 | 35 | (define (documented? object) |
5c96bc39 | 36 | (not (not (object-documentation object)))) |
141443d7 DH |
37 | |
38 | ||
39 | ;;; | |
62360b89 | 40 | ;;; memoization |
141443d7 DH |
41 | ;;; |
42 | ||
62360b89 DH |
43 | (with-test-prefix "memoization" |
44 | ||
45 | (with-test-prefix "copy-tree" | |
46 | ||
47 | (pass-if "(#t . #(#t))" | |
48 | (let* ((foo (cons #t (vector #t))) | |
49 | (bar (copy-tree foo))) | |
50 | (vector-set! (cdr foo) 0 #f) | |
51 | (equal? bar '(#t . #(#t))))) | |
52 | ||
53 | (pass-if-exception "circular lists in forms" | |
54 | exception:bad-expression | |
55 | (let ((foo (list #f))) | |
56 | (set-cdr! foo foo) | |
57 | (copy-tree foo)))) | |
141443d7 | 58 | |
62360b89 DH |
59 | (pass-if "transparency" |
60 | (let ((x '(begin 1))) | |
61 | (eval x (current-module)) | |
62 | (equal? '(begin 1) x)))) | |
414959ca | 63 | |
62360b89 DH |
64 | |
65 | ;;; | |
66 | ;;; eval | |
67 | ;;; | |
68 | ||
69 | (with-test-prefix "evaluator" | |
414959ca | 70 | |
08c608e1 DH |
71 | (with-test-prefix "symbol lookup" |
72 | ||
73 | (with-test-prefix "top level" | |
74 | ||
75 | (with-test-prefix "unbound" | |
76 | ||
77 | (pass-if-exception "variable reference" | |
78 | exception:unbound-var | |
79 | x) | |
80 | ||
81 | (pass-if-exception "procedure" | |
82 | exception:unbound-var | |
83 | (x))))) | |
84 | ||
141443d7 DH |
85 | (with-test-prefix "parameter error" |
86 | ||
87 | ;; This is currently a bug in guile: | |
88 | ;; Macros are accepted as function parameters. | |
89 | ;; Functions that 'apply' macros are rewritten!!! | |
90 | ||
8bb0b3cc AW |
91 | (pass-if-exception "macro as argument" |
92 | exception:failed-match | |
93 | (primitive-eval | |
94 | '(let ((f (lambda (p a b) (p a b)))) | |
95 | (f and #t #t)))) | |
96 | ||
97 | (pass-if-exception "passing macro as parameter" | |
98 | exception:failed-match | |
99 | (primitive-eval | |
100 | '(let* ((f (lambda (p a b) (p a b))) | |
101 | (foo (procedure-source f))) | |
102 | (f and #t #t) | |
103 | (equal? (procedure-source f) foo)))) | |
141443d7 DH |
104 | |
105 | )) | |
106 | ||
08c608e1 | 107 | ;;; |
8ab3d8a0 | 108 | ;;; call |
08c608e1 DH |
109 | ;;; |
110 | ||
8ab3d8a0 | 111 | (with-test-prefix "call" |
08c608e1 DH |
112 | |
113 | (with-test-prefix "wrong number of arguments" | |
114 | ||
115 | (pass-if-exception "((lambda () #f) 1)" | |
116 | exception:wrong-num-args | |
117 | ((lambda () #f) 1)) | |
118 | ||
119 | (pass-if-exception "((lambda (x) #f))" | |
120 | exception:wrong-num-args | |
121 | ((lambda (x) #f))) | |
122 | ||
123 | (pass-if-exception "((lambda (x) #f) 1 2)" | |
124 | exception:wrong-num-args | |
125 | ((lambda (x) #f) 1 2)) | |
126 | ||
127 | (pass-if-exception "((lambda (x y) #f))" | |
128 | exception:wrong-num-args | |
129 | ((lambda (x y) #f))) | |
130 | ||
131 | (pass-if-exception "((lambda (x y) #f) 1)" | |
132 | exception:wrong-num-args | |
133 | ((lambda (x y) #f) 1)) | |
134 | ||
135 | (pass-if-exception "((lambda (x y) #f) 1 2 3)" | |
136 | exception:wrong-num-args | |
137 | ((lambda (x y) #f) 1 2 3)) | |
138 | ||
139 | (pass-if-exception "((lambda (x . rest) #f))" | |
140 | exception:wrong-num-args | |
141 | ((lambda (x . rest) #f))) | |
142 | ||
143 | (pass-if-exception "((lambda (x y . rest) #f))" | |
144 | exception:wrong-num-args | |
145 | ((lambda (x y . rest) #f))) | |
146 | ||
147 | (pass-if-exception "((lambda (x y . rest) #f) 1)" | |
148 | exception:wrong-num-args | |
149 | ((lambda (x y . rest) #f) 1)))) | |
150 | ||
8ab3d8a0 KR |
151 | ;;; |
152 | ;;; apply | |
153 | ;;; | |
154 | ||
155 | (with-test-prefix "apply" | |
156 | ||
157 | (with-test-prefix "scm_tc7_subr_2o" | |
158 | ||
159 | ;; prior to guile 1.6.9 and 1.8.1 this called the function with | |
160 | ;; SCM_UNDEFIEND, which in the case of make-vector resulted in | |
161 | ;; wrong-type-arg, instead of the intended wrong-num-args | |
162 | (pass-if-exception "0 args" exception:wrong-num-args | |
163 | (apply make-vector '())) | |
164 | ||
165 | (pass-if "1 arg" | |
166 | (vector? (apply make-vector '(1)))) | |
167 | ||
168 | (pass-if "2 args" | |
169 | (vector? (apply make-vector '(1 2)))) | |
170 | ||
171 | ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected | |
172 | (pass-if-exception "3 args" exception:wrong-num-args | |
173 | (apply make-vector '(1 2 3))))) | |
174 | ||
141443d7 DH |
175 | ;;; |
176 | ;;; map | |
177 | ;;; | |
178 | ||
179 | (with-test-prefix "map" | |
180 | ||
181 | ;; Is documentation available? | |
182 | ||
183 | (expect-fail "documented?" | |
6ad9007a | 184 | (documented? map)) |
141443d7 DH |
185 | |
186 | (with-test-prefix "argument error" | |
187 | ||
188 | (with-test-prefix "non list argument" | |
189 | #t) | |
190 | ||
191 | (with-test-prefix "different length lists" | |
192 | ||
6b4113af DH |
193 | (pass-if-exception "first list empty" |
194 | exception:out-of-range | |
195 | (map + '() '(1))) | |
196 | ||
197 | (pass-if-exception "second list empty" | |
198 | exception:out-of-range | |
199 | (map + '(1) '())) | |
200 | ||
201 | (pass-if-exception "first list shorter" | |
202 | exception:out-of-range | |
203 | (map + '(1) '(2 3))) | |
204 | ||
205 | (pass-if-exception "second list shorter" | |
206 | exception:out-of-range | |
207 | (map + '(1 2) '(3))) | |
141443d7 | 208 | ))) |
23d72566 KR |
209 | |
210 | ;;; | |
211 | ;;; define with procedure-name | |
212 | ;;; | |
213 | ||
214 | (define old-procnames-flag (memq 'procnames (debug-options))) | |
215 | (debug-enable 'procnames) | |
216 | ||
217 | ;; names are only set on top-level procedures (currently), so these can't be | |
218 | ;; hidden in a let | |
219 | ;; | |
220 | (define foo-closure (lambda () "hello")) | |
221 | (define bar-closure foo-closure) | |
3fd8807e AW |
222 | ;; make sure that make-procedure-with-setter returns an anonymous |
223 | ;; procedure-with-setter by passing it an anonymous getter. | |
224 | (define foo-pws (make-procedure-with-setter | |
225 | (lambda (x) (car x)) | |
226 | (lambda (x y) (set-car! x y)))) | |
23d72566 KR |
227 | (define bar-pws foo-pws) |
228 | ||
229 | (with-test-prefix "define set procedure-name" | |
230 | ||
231 | (pass-if "closure" | |
232 | (eq? 'foo-closure (procedure-name bar-closure))) | |
233 | ||
234 | (pass-if "procedure-with-setter" | |
3fd8807e | 235 | (eq? 'foo-pws (procedure-name bar-pws)))) |
23d72566 KR |
236 | |
237 | (if old-procnames-flag | |
238 | (debug-enable 'procnames) | |
239 | (debug-disable 'procnames)) | |
414959ca | 240 | |
2b6b5908 DH |
241 | ;;; |
242 | ;;; promises | |
243 | ;;; | |
244 | ||
245 | (with-test-prefix "promises" | |
246 | ||
247 | (with-test-prefix "basic promise behaviour" | |
248 | ||
249 | (pass-if "delay gives a promise" | |
250 | (promise? (delay 1))) | |
251 | ||
252 | (pass-if "force evaluates a promise" | |
253 | (eqv? (force (delay (+ 1 2))) 3)) | |
254 | ||
255 | (pass-if "a forced promise is a promise" | |
256 | (let ((p (delay (+ 1 2)))) | |
257 | (force p) | |
258 | (promise? p))) | |
259 | ||
260 | (pass-if "forcing a forced promise works" | |
261 | (let ((p (delay (+ 1 2)))) | |
262 | (force p) | |
263 | (eqv? (force p) 3))) | |
264 | ||
265 | (pass-if "a promise is evaluated once" | |
266 | (let* ((x 1) | |
267 | (p (delay (+ x 1)))) | |
268 | (force p) | |
269 | (set! x (+ x 1)) | |
270 | (eqv? (force p) 2))) | |
271 | ||
272 | (pass-if "a promise may call itself" | |
273 | (define p | |
274 | (let ((x 0)) | |
275 | (delay | |
276 | (begin | |
277 | (set! x (+ x 1)) | |
278 | (if (> x 1) x (force p)))))) | |
279 | (eqv? (force p) 2)) | |
280 | ||
281 | (pass-if "a promise carries its environment" | |
282 | (let* ((x 1) (p #f)) | |
283 | (let* ((x 2)) | |
284 | (set! p (delay (+ x 1)))) | |
285 | (eqv? (force p) 3))) | |
286 | ||
287 | (pass-if "a forced promise does not reference its environment" | |
288 | (let* ((g (make-guardian)) | |
289 | (p #f)) | |
290 | (let* ((x (cons #f #f))) | |
291 | (g x) | |
292 | (set! p (delay (car x)))) | |
293 | (force p) | |
294 | (gc) | |
295 | (if (not (equal? (g) (cons #f #f))) | |
296 | (throw 'unresolved) | |
297 | #t)))) | |
298 | ||
299 | (with-test-prefix "extended promise behaviour" | |
300 | ||
301 | (pass-if-exception "forcing a non-promise object is not supported" | |
302 | exception:wrong-type-arg | |
303 | (force 1)) | |
304 | ||
305 | (pass-if-exception "implicit forcing is not supported" | |
306 | exception:wrong-type-arg | |
2d04022c NJ |
307 | (+ (delay (* 3 7)) 13)) |
308 | ||
309 | ;; Tests that require the debugging evaluator... | |
310 | (with-debugging-evaluator | |
311 | ||
312 | (pass-if "unmemoizing a promise" | |
313 | (display-backtrace | |
314 | (let ((stack #f)) | |
315 | (false-if-exception (lazy-catch #t | |
316 | (lambda () | |
317 | (let ((f (lambda (g) (delay (g))))) | |
318 | (force (f error)))) | |
319 | (lambda _ | |
320 | (set! stack (make-stack #t))))) | |
321 | stack) | |
322 | (%make-void-port "w")) | |
323 | #t)))) | |
2b6b5908 | 324 | |
113e7c25 LC |
325 | |
326 | ;;; | |
327 | ;;; stacks | |
328 | ;;; | |
329 | ||
330 | (define (stack->frames stack) | |
331 | ;; Return the list of frames comprising STACK. | |
332 | (unfold (lambda (i) | |
333 | (>= i (stack-length stack))) | |
334 | (lambda (i) | |
335 | (stack-ref stack i)) | |
336 | 1+ | |
337 | 0)) | |
338 | ||
339 | (with-test-prefix "stacks" | |
340 | (with-debugging-evaluator | |
341 | ||
342 | (pass-if "stack involving a subr" | |
343 | ;; The subr involving the error must appear exactly once on the stack. | |
344 | (catch 'result | |
345 | (lambda () | |
346 | (start-stack 'foo | |
347 | (lazy-catch 'wrong-type-arg | |
348 | (lambda () | |
349 | ;; Trigger a `wrong-type-arg' exception. | |
350 | (fluid-ref 'not-a-fluid)) | |
351 | (lambda _ | |
352 | (let* ((stack (make-stack #t)) | |
353 | (frames (stack->frames stack))) | |
354 | (throw 'result | |
355 | (count (lambda (frame) | |
356 | (and (frame-procedure? frame) | |
357 | (eq? (frame-procedure frame) | |
358 | fluid-ref))) | |
359 | frames))))))) | |
360 | (lambda (key result) | |
361 | (= 1 result)))) | |
362 | ||
363 | (pass-if "stack involving a gsubr" | |
364 | ;; The gsubr involving the error must appear exactly once on the stack. | |
365 | ;; This is less obvious since gsubr application may require an | |
366 | ;; additional `SCM_APPLY ()' call, which should not be visible to the | |
367 | ;; application. | |
368 | (catch 'result | |
369 | (lambda () | |
370 | (start-stack 'foo | |
371 | (lazy-catch 'wrong-type-arg | |
372 | (lambda () | |
373 | ;; Trigger a `wrong-type-arg' exception. | |
374 | (hashq-ref 'wrong 'type 'arg)) | |
375 | (lambda _ | |
376 | (let* ((stack (make-stack #t)) | |
377 | (frames (stack->frames stack))) | |
378 | (throw 'result | |
379 | (count (lambda (frame) | |
380 | (and (frame-procedure? frame) | |
381 | (eq? (frame-procedure frame) | |
382 | hashq-ref))) | |
383 | frames))))))) | |
384 | (lambda (key result) | |
385 | (= 1 result)))))) | |
386 | ||
d2797644 NJ |
387 | ;;; |
388 | ;;; letrec init evaluation | |
389 | ;;; | |
390 | ||
391 | (with-test-prefix "letrec init evaluation" | |
392 | ||
393 | (pass-if "lots of inits calculated in correct order" | |
394 | (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd) | |
395 | (e 'e) (f 'f) (g 'g) (h 'h) | |
396 | (i 'i) (j 'j) (k 'k) (l 'l) | |
397 | (m 'm) (n 'n) (o 'o) (p 'p) | |
398 | (q 'q) (r 'r) (s 's) (t 't) | |
399 | (u 'u) (v 'v) (w 'w) (x 'x) | |
400 | (y 'y) (z 'z)) | |
401 | (list a b c d e f g h i j k l m | |
402 | n o p q r s t u v w x y z)) | |
403 | '(a b c d e f g h i j k l m | |
404 | n o p q r s t u v w x y z)))) | |
405 | ||
42ddb3cb LC |
406 | ;;; |
407 | ;;; values | |
408 | ;;; | |
409 | ||
410 | (with-test-prefix "values" | |
411 | ||
412 | (pass-if "single value" | |
413 | (equal? 1 (values 1))) | |
414 | ||
415 | (pass-if "call-with-values" | |
416 | (equal? (call-with-values (lambda () (values 1 2 3 4)) list) | |
417 | '(1 2 3 4))) | |
418 | ||
419 | (pass-if "equal?" | |
420 | (equal? (values 1 2 3 4) (values 1 2 3 4)))) | |
4f2ec3be | 421 | |
414959ca | 422 | ;;; eval.test ends here |