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