Commit | Line | Data |
---|---|---|
141443d7 | 1 | ;;;; eval.test --- tests guile's evaluator -*- scheme -*- |
6e7d5622 | 2 | ;;;; Copyright (C) 2000, 2001, 2006 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) | |
20 | :use-module (ice-9 documentation)) | |
141443d7 DH |
21 | |
22 | ||
62360b89 DH |
23 | (define exception:bad-expression |
24 | (cons 'syntax-error "Bad expression")) | |
25 | ||
26 | ||
141443d7 DH |
27 | ;;; |
28 | ;;; miscellaneous | |
29 | ;;; | |
30 | ||
141443d7 | 31 | (define (documented? object) |
5c96bc39 | 32 | (not (not (object-documentation object)))) |
141443d7 DH |
33 | |
34 | ||
35 | ;;; | |
62360b89 | 36 | ;;; memoization |
141443d7 DH |
37 | ;;; |
38 | ||
62360b89 DH |
39 | (with-test-prefix "memoization" |
40 | ||
41 | (with-test-prefix "copy-tree" | |
42 | ||
43 | (pass-if "(#t . #(#t))" | |
44 | (let* ((foo (cons #t (vector #t))) | |
45 | (bar (copy-tree foo))) | |
46 | (vector-set! (cdr foo) 0 #f) | |
47 | (equal? bar '(#t . #(#t))))) | |
48 | ||
49 | (pass-if-exception "circular lists in forms" | |
50 | exception:bad-expression | |
51 | (let ((foo (list #f))) | |
52 | (set-cdr! foo foo) | |
53 | (copy-tree foo)))) | |
141443d7 | 54 | |
62360b89 DH |
55 | (pass-if "transparency" |
56 | (let ((x '(begin 1))) | |
57 | (eval x (current-module)) | |
58 | (equal? '(begin 1) x)))) | |
414959ca | 59 | |
62360b89 DH |
60 | |
61 | ;;; | |
62 | ;;; eval | |
63 | ;;; | |
64 | ||
65 | (with-test-prefix "evaluator" | |
414959ca | 66 | |
08c608e1 DH |
67 | (with-test-prefix "symbol lookup" |
68 | ||
69 | (with-test-prefix "top level" | |
70 | ||
71 | (with-test-prefix "unbound" | |
72 | ||
73 | (pass-if-exception "variable reference" | |
74 | exception:unbound-var | |
75 | x) | |
76 | ||
77 | (pass-if-exception "procedure" | |
78 | exception:unbound-var | |
79 | (x))))) | |
80 | ||
141443d7 DH |
81 | (with-test-prefix "parameter error" |
82 | ||
83 | ;; This is currently a bug in guile: | |
84 | ;; Macros are accepted as function parameters. | |
85 | ;; Functions that 'apply' macros are rewritten!!! | |
86 | ||
6b4113af DH |
87 | (expect-fail-exception "macro as argument" |
88 | exception:wrong-type-arg | |
141443d7 | 89 | (let ((f (lambda (p a b) (p a b)))) |
6b4113af DH |
90 | (f and #t #t))) |
91 | ||
92 | (expect-fail-exception "passing macro as parameter" | |
93 | exception:wrong-type-arg | |
94 | (let* ((f (lambda (p a b) (p a b))) | |
95 | (foo (procedure-source f))) | |
96 | (f and #t #t) | |
97 | (equal? (procedure-source f) foo))) | |
141443d7 DH |
98 | |
99 | )) | |
100 | ||
08c608e1 | 101 | ;;; |
8ab3d8a0 | 102 | ;;; call |
08c608e1 DH |
103 | ;;; |
104 | ||
8ab3d8a0 | 105 | (with-test-prefix "call" |
08c608e1 DH |
106 | |
107 | (with-test-prefix "wrong number of arguments" | |
108 | ||
109 | (pass-if-exception "((lambda () #f) 1)" | |
110 | exception:wrong-num-args | |
111 | ((lambda () #f) 1)) | |
112 | ||
113 | (pass-if-exception "((lambda (x) #f))" | |
114 | exception:wrong-num-args | |
115 | ((lambda (x) #f))) | |
116 | ||
117 | (pass-if-exception "((lambda (x) #f) 1 2)" | |
118 | exception:wrong-num-args | |
119 | ((lambda (x) #f) 1 2)) | |
120 | ||
121 | (pass-if-exception "((lambda (x y) #f))" | |
122 | exception:wrong-num-args | |
123 | ((lambda (x y) #f))) | |
124 | ||
125 | (pass-if-exception "((lambda (x y) #f) 1)" | |
126 | exception:wrong-num-args | |
127 | ((lambda (x y) #f) 1)) | |
128 | ||
129 | (pass-if-exception "((lambda (x y) #f) 1 2 3)" | |
130 | exception:wrong-num-args | |
131 | ((lambda (x y) #f) 1 2 3)) | |
132 | ||
133 | (pass-if-exception "((lambda (x . rest) #f))" | |
134 | exception:wrong-num-args | |
135 | ((lambda (x . rest) #f))) | |
136 | ||
137 | (pass-if-exception "((lambda (x y . rest) #f))" | |
138 | exception:wrong-num-args | |
139 | ((lambda (x y . rest) #f))) | |
140 | ||
141 | (pass-if-exception "((lambda (x y . rest) #f) 1)" | |
142 | exception:wrong-num-args | |
143 | ((lambda (x y . rest) #f) 1)))) | |
144 | ||
8ab3d8a0 KR |
145 | ;;; |
146 | ;;; apply | |
147 | ;;; | |
148 | ||
149 | (with-test-prefix "apply" | |
150 | ||
151 | (with-test-prefix "scm_tc7_subr_2o" | |
152 | ||
153 | ;; prior to guile 1.6.9 and 1.8.1 this called the function with | |
154 | ;; SCM_UNDEFIEND, which in the case of make-vector resulted in | |
155 | ;; wrong-type-arg, instead of the intended wrong-num-args | |
156 | (pass-if-exception "0 args" exception:wrong-num-args | |
157 | (apply make-vector '())) | |
158 | ||
159 | (pass-if "1 arg" | |
160 | (vector? (apply make-vector '(1)))) | |
161 | ||
162 | (pass-if "2 args" | |
163 | (vector? (apply make-vector '(1 2)))) | |
164 | ||
165 | ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected | |
166 | (pass-if-exception "3 args" exception:wrong-num-args | |
167 | (apply make-vector '(1 2 3))))) | |
168 | ||
141443d7 DH |
169 | ;;; |
170 | ;;; map | |
171 | ;;; | |
172 | ||
173 | (with-test-prefix "map" | |
174 | ||
175 | ;; Is documentation available? | |
176 | ||
177 | (expect-fail "documented?" | |
6ad9007a | 178 | (documented? map)) |
141443d7 DH |
179 | |
180 | (with-test-prefix "argument error" | |
181 | ||
182 | (with-test-prefix "non list argument" | |
183 | #t) | |
184 | ||
185 | (with-test-prefix "different length lists" | |
186 | ||
6b4113af DH |
187 | (pass-if-exception "first list empty" |
188 | exception:out-of-range | |
189 | (map + '() '(1))) | |
190 | ||
191 | (pass-if-exception "second list empty" | |
192 | exception:out-of-range | |
193 | (map + '(1) '())) | |
194 | ||
195 | (pass-if-exception "first list shorter" | |
196 | exception:out-of-range | |
197 | (map + '(1) '(2 3))) | |
198 | ||
199 | (pass-if-exception "second list shorter" | |
200 | exception:out-of-range | |
201 | (map + '(1 2) '(3))) | |
141443d7 | 202 | ))) |
23d72566 KR |
203 | |
204 | ;;; | |
205 | ;;; define with procedure-name | |
206 | ;;; | |
207 | ||
208 | (define old-procnames-flag (memq 'procnames (debug-options))) | |
209 | (debug-enable 'procnames) | |
210 | ||
211 | ;; names are only set on top-level procedures (currently), so these can't be | |
212 | ;; hidden in a let | |
213 | ;; | |
214 | (define foo-closure (lambda () "hello")) | |
215 | (define bar-closure foo-closure) | |
216 | (define foo-pws (make-procedure-with-setter car set-car!)) | |
217 | (define bar-pws foo-pws) | |
218 | ||
219 | (with-test-prefix "define set procedure-name" | |
220 | ||
221 | (pass-if "closure" | |
222 | (eq? 'foo-closure (procedure-name bar-closure))) | |
223 | ||
224 | (pass-if "procedure-with-setter" | |
225 | (eq? 'foo-pws (pk (procedure-name bar-pws))))) | |
226 | ||
227 | (if old-procnames-flag | |
228 | (debug-enable 'procnames) | |
229 | (debug-disable 'procnames)) | |
414959ca | 230 | |
2b6b5908 DH |
231 | ;;; |
232 | ;;; promises | |
233 | ;;; | |
234 | ||
235 | (with-test-prefix "promises" | |
236 | ||
237 | (with-test-prefix "basic promise behaviour" | |
238 | ||
239 | (pass-if "delay gives a promise" | |
240 | (promise? (delay 1))) | |
241 | ||
242 | (pass-if "force evaluates a promise" | |
243 | (eqv? (force (delay (+ 1 2))) 3)) | |
244 | ||
245 | (pass-if "a forced promise is a promise" | |
246 | (let ((p (delay (+ 1 2)))) | |
247 | (force p) | |
248 | (promise? p))) | |
249 | ||
250 | (pass-if "forcing a forced promise works" | |
251 | (let ((p (delay (+ 1 2)))) | |
252 | (force p) | |
253 | (eqv? (force p) 3))) | |
254 | ||
255 | (pass-if "a promise is evaluated once" | |
256 | (let* ((x 1) | |
257 | (p (delay (+ x 1)))) | |
258 | (force p) | |
259 | (set! x (+ x 1)) | |
260 | (eqv? (force p) 2))) | |
261 | ||
262 | (pass-if "a promise may call itself" | |
263 | (define p | |
264 | (let ((x 0)) | |
265 | (delay | |
266 | (begin | |
267 | (set! x (+ x 1)) | |
268 | (if (> x 1) x (force p)))))) | |
269 | (eqv? (force p) 2)) | |
270 | ||
271 | (pass-if "a promise carries its environment" | |
272 | (let* ((x 1) (p #f)) | |
273 | (let* ((x 2)) | |
274 | (set! p (delay (+ x 1)))) | |
275 | (eqv? (force p) 3))) | |
276 | ||
277 | (pass-if "a forced promise does not reference its environment" | |
278 | (let* ((g (make-guardian)) | |
279 | (p #f)) | |
280 | (let* ((x (cons #f #f))) | |
281 | (g x) | |
282 | (set! p (delay (car x)))) | |
283 | (force p) | |
284 | (gc) | |
285 | (if (not (equal? (g) (cons #f #f))) | |
286 | (throw 'unresolved) | |
287 | #t)))) | |
288 | ||
289 | (with-test-prefix "extended promise behaviour" | |
290 | ||
291 | (pass-if-exception "forcing a non-promise object is not supported" | |
292 | exception:wrong-type-arg | |
293 | (force 1)) | |
294 | ||
295 | (pass-if-exception "implicit forcing is not supported" | |
296 | exception:wrong-type-arg | |
297 | (+ (delay (* 3 7)) 13)))) | |
298 | ||
d2797644 NJ |
299 | ;;; |
300 | ;;; letrec init evaluation | |
301 | ;;; | |
302 | ||
303 | (with-test-prefix "letrec init evaluation" | |
304 | ||
305 | (pass-if "lots of inits calculated in correct order" | |
306 | (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd) | |
307 | (e 'e) (f 'f) (g 'g) (h 'h) | |
308 | (i 'i) (j 'j) (k 'k) (l 'l) | |
309 | (m 'm) (n 'n) (o 'o) (p 'p) | |
310 | (q 'q) (r 'r) (s 's) (t 't) | |
311 | (u 'u) (v 'v) (w 'w) (x 'x) | |
312 | (y 'y) (z 'z)) | |
313 | (list a b c d e f g h i j k l m | |
314 | n o p q r s t u v w x y z)) | |
315 | '(a b c d e f g h i j k l m | |
316 | n o p q r s t u v w x y z)))) | |
317 | ||
4f2ec3be | 318 | |
414959ca | 319 | ;;; eval.test ends here |