Commit | Line | Data |
---|---|---|
08c608e1 | 1 | ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- |
e10cf6b9 | 2 | ;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 Free Software Foundation, Inc. |
cf7b149f | 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, | |
cf7b149f | 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 |
cf7b149f | 17 | |
cf7b149f | 18 | |
9bc915bb KR |
19 | (use-modules (test-suite lib)) |
20 | ||
1e42832a CJY |
21 | (define-syntax-parameter push |
22 | (lambda (stx) | |
23 | (syntax-violation 'push "push used outside of throw-test" stx))) | |
24 | ||
25 | (define-syntax-rule (throw-test title result expr ...) | |
26 | (pass-if title | |
27 | (equal? result | |
28 | (let ((stack '())) | |
29 | (syntax-parameterize ((push (syntax-rules () | |
30 | ((push val) | |
31 | (set! stack (cons val stack)))))) | |
32 | expr ... | |
33 | ;;(format #t "~a: ~s~%" title (reverse stack)) | |
34 | (reverse stack)))))) | |
26beee1e | 35 | |
08c608e1 | 36 | (with-test-prefix "throw/catch" |
cf7b149f | 37 | |
08c608e1 | 38 | (with-test-prefix "wrong type argument" |
cf7b149f | 39 | |
08c608e1 DH |
40 | (pass-if-exception "(throw 1)" |
41 | exception:wrong-type-arg | |
42 | (throw 1))) | |
cf7b149f | 43 | |
08c608e1 | 44 | (with-test-prefix "wrong number of arguments" |
cf7b149f | 45 | |
08c608e1 DH |
46 | (pass-if-exception "(throw)" |
47 | exception:wrong-num-args | |
48 | (throw)) | |
cf7b149f | 49 | |
08c608e1 DH |
50 | (pass-if-exception "throw 1 / catch 0" |
51 | exception:wrong-num-args | |
52 | (catch 'a | |
53 | (lambda () (throw 'a)) | |
54 | (lambda () #f))) | |
cf7b149f | 55 | |
08c608e1 DH |
56 | (pass-if-exception "throw 2 / catch 1" |
57 | exception:wrong-num-args | |
58 | (catch 'a | |
59 | (lambda () (throw 'a 2)) | |
60 | (lambda (x) #f))) | |
1b5b19c9 | 61 | |
08c608e1 DH |
62 | (pass-if-exception "throw 1 / catch 2" |
63 | exception:wrong-num-args | |
64 | (catch 'a | |
65 | (lambda () (throw 'a)) | |
66 | (lambda (x y) #f))) | |
cf7b149f | 67 | |
08c608e1 DH |
68 | (pass-if-exception "throw 3 / catch 2" |
69 | exception:wrong-num-args | |
70 | (catch 'a | |
71 | (lambda () (throw 'a 2 3)) | |
72 | (lambda (y x) #f))) | |
cf7b149f | 73 | |
08c608e1 DH |
74 | (pass-if-exception "throw 1 / catch 2+" |
75 | exception:wrong-num-args | |
76 | (catch 'a | |
77 | (lambda () (throw 'a)) | |
26beee1e NJ |
78 | (lambda (x y . rest) #f)))) |
79 | ||
e10cf6b9 | 80 | (with-test-prefix "with pre-unwind handler" |
26beee1e | 81 | |
e10cf6b9 | 82 | (pass-if "pre-unwind fluid state" |
26beee1e NJ |
83 | (equal? '(inner outer arg) |
84 | (let ((fluid-parm (make-fluid)) | |
85 | (inner-val #f)) | |
86 | (fluid-set! fluid-parm 'outer) | |
87 | (catch 'misc-exc | |
88 | (lambda () | |
89 | (with-fluids ((fluid-parm 'inner)) | |
90 | (throw 'misc-exc 'arg))) | |
91 | (lambda (key . args) | |
92 | (list inner-val | |
93 | (fluid-ref fluid-parm) | |
94 | (car args))) | |
95 | (lambda (key . args) | |
96 | (set! inner-val (fluid-ref fluid-parm)))))))) | |
97 | ||
98 | (throw-test "normal catch" | |
99 | '(1 2) | |
100 | (catch 'a | |
101 | (lambda () | |
102 | (push 1) | |
103 | (throw 'a)) | |
104 | (lambda (key . args) | |
105 | (push 2)))) | |
106 | ||
e10cf6b9 | 107 | (throw-test "catch and with-throw-handler" |
26beee1e NJ |
108 | '(1 2 3 4) |
109 | (catch 'a | |
110 | (lambda () | |
111 | (push 1) | |
e10cf6b9 AW |
112 | (with-throw-handler |
113 | 'a | |
114 | (lambda () | |
115 | (push 2) | |
116 | (throw 'a)) | |
117 | (lambda (key . args) | |
118 | (push 3)))) | |
26beee1e NJ |
119 | (lambda (key . args) |
120 | (push 4)))) | |
121 | ||
e10cf6b9 | 122 | (throw-test "catch with rethrowing throw-handler" |
26beee1e NJ |
123 | '(1 2 3 4) |
124 | (catch 'a | |
125 | (lambda () | |
126 | (push 1) | |
e10cf6b9 AW |
127 | (with-throw-handler |
128 | 'a | |
129 | (lambda () | |
130 | (push 2) | |
131 | (throw 'a)) | |
132 | (lambda (key . args) | |
133 | (push 3) | |
134 | (apply throw key args)))) | |
26beee1e NJ |
135 | (lambda (key . args) |
136 | (push 4)))) | |
137 | ||
138 | (throw-test "catch with pre-unwind handler" | |
139 | '(1 3 2) | |
140 | (catch 'a | |
141 | (lambda () | |
142 | (push 1) | |
143 | (throw 'a)) | |
144 | (lambda (key . args) | |
145 | (push 2)) | |
146 | (lambda (key . args) | |
147 | (push 3)))) | |
148 | ||
149 | (throw-test "catch with rethrowing pre-unwind handler" | |
150 | '(1 3 2) | |
151 | (catch 'a | |
152 | (lambda () | |
153 | (push 1) | |
154 | (throw 'a)) | |
155 | (lambda (key . args) | |
156 | (push 2)) | |
157 | (lambda (key . args) | |
158 | (push 3) | |
159 | (apply throw key args)))) | |
160 | ||
161 | (throw-test "catch with throw handler" | |
162 | '(1 2 3 4) | |
163 | (catch 'a | |
164 | (lambda () | |
165 | (push 1) | |
166 | (with-throw-handler 'a | |
167 | (lambda () | |
168 | (push 2) | |
169 | (throw 'a)) | |
170 | (lambda (key . args) | |
171 | (push 3)))) | |
172 | (lambda (key . args) | |
173 | (push 4)))) | |
174 | ||
175 | (throw-test "catch with rethrowing throw handler" | |
176 | '(1 2 3 4) | |
177 | (catch 'a | |
178 | (lambda () | |
179 | (push 1) | |
180 | (with-throw-handler 'a | |
181 | (lambda () | |
182 | (push 2) | |
183 | (throw 'a)) | |
184 | (lambda (key . args) | |
185 | (push 3) | |
186 | (apply throw key args)))) | |
187 | (lambda (key . args) | |
188 | (push 4)))) | |
189 | ||
26beee1e NJ |
190 | (throw-test "effect of with-throw-handler not-unwinding on throw to another key" |
191 | '(1 2 3 5 4 6) | |
192 | (catch 'a | |
193 | (lambda () | |
194 | (push 1) | |
195 | (with-throw-handler 'b | |
196 | (lambda () | |
197 | (push 2) | |
198 | (catch 'a | |
199 | (lambda () | |
200 | (push 3) | |
201 | (throw 'b)) | |
202 | (lambda (key . args) | |
203 | (push 4)))) | |
204 | (lambda (key . args) | |
205 | (push 5) | |
206 | (throw 'a))) | |
207 | (push 6)) | |
208 | (lambda (key . args) | |
209 | (push 7)))) | |
210 | ||
26beee1e NJ |
211 | (throw-test "with-throw-handler chaining" |
212 | '(1 2 3 4 6 8) | |
213 | (catch 'a | |
214 | (lambda () | |
215 | (push 1) | |
216 | (with-throw-handler 'a | |
217 | (lambda () | |
218 | (push 2) | |
219 | (with-throw-handler 'a | |
220 | (lambda () | |
221 | (push 3) | |
222 | (throw 'a)) | |
223 | (lambda (key . args) | |
224 | (push 4))) | |
225 | (push 5)) | |
226 | (lambda (key . args) | |
227 | (push 6))) | |
228 | (push 7)) | |
229 | (lambda (key . args) | |
230 | (push 8)))) | |
231 | ||
26beee1e NJ |
232 | (throw-test "throw handlers throwing to each other recursively" |
233 | '(1 2 3 4 8 6 10 12) | |
234 | (catch #t | |
235 | (lambda () | |
236 | (push 1) | |
237 | (with-throw-handler 'a | |
238 | (lambda () | |
239 | (push 2) | |
240 | (with-throw-handler 'b | |
241 | (lambda () | |
242 | (push 3) | |
243 | (with-throw-handler 'c | |
244 | (lambda () | |
245 | (push 4) | |
246 | (throw 'b) | |
247 | (push 5)) | |
248 | (lambda (key . args) | |
249 | (push 6) | |
250 | (throw 'a))) | |
251 | (push 7)) | |
252 | (lambda (key . args) | |
253 | (push 8) | |
254 | (throw 'c))) | |
255 | (push 9)) | |
256 | (lambda (key . args) | |
257 | (push 10) | |
258 | (throw 'b))) | |
259 | (push 11)) | |
260 | (lambda (key . args) | |
261 | (push 12)))) | |
262 | ||
26beee1e NJ |
263 | (throw-test "throw handler throwing to lexically inside catch" |
264 | '(1 2 7 5 4 6 9) | |
265 | (with-throw-handler 'a | |
266 | (lambda () | |
267 | (push 1) | |
268 | (catch 'b | |
269 | (lambda () | |
270 | (push 2) | |
271 | (throw 'a) | |
272 | (push 3)) | |
273 | (lambda (key . args) | |
274 | (push 4)) | |
275 | (lambda (key . args) | |
276 | (push 5))) | |
277 | (push 6)) | |
278 | (lambda (key . args) | |
279 | (push 7) | |
280 | (throw 'b) | |
281 | (push 8))) | |
282 | (push 9)) | |
283 | ||
284 | (throw-test "reuse of same throw handler after lexically inside catch" | |
285 | '(0 1 2 7 5 4 6 7 10) | |
286 | (catch 'b | |
287 | (lambda () | |
288 | (push 0) | |
289 | (with-throw-handler 'a | |
290 | (lambda () | |
291 | (push 1) | |
292 | (catch 'b | |
293 | (lambda () | |
294 | (push 2) | |
295 | (throw 'a) | |
296 | (push 3)) | |
297 | (lambda (key . args) | |
298 | (push 4)) | |
299 | (lambda (key . args) | |
300 | (push 5))) | |
301 | (push 6) | |
302 | (throw 'a)) | |
303 | (lambda (key . args) | |
304 | (push 7) | |
305 | (throw 'b) | |
306 | (push 8))) | |
307 | (push 9)) | |
308 | (lambda (key . args) | |
309 | (push 10)))) | |
310 | ||
311 | (throw-test "again but with two chained throw handlers" | |
312 | '(0 1 11 2 13 7 5 4 12 13 7 10) | |
313 | (catch 'b | |
314 | (lambda () | |
315 | (push 0) | |
316 | (with-throw-handler 'a | |
317 | (lambda () | |
318 | (push 1) | |
319 | (with-throw-handler 'a | |
320 | (lambda () | |
321 | (push 11) | |
322 | (catch 'b | |
323 | (lambda () | |
324 | (push 2) | |
325 | (throw 'a) | |
326 | (push 3)) | |
327 | (lambda (key . args) | |
328 | (push 4)) | |
329 | (lambda (key . args) | |
330 | (push 5))) | |
331 | (push 12) | |
332 | (throw 'a)) | |
333 | (lambda (key . args) | |
334 | (push 13))) | |
335 | (push 6)) | |
336 | (lambda (key . args) | |
337 | (push 7) | |
338 | (throw 'b))) | |
339 | (push 9)) | |
340 | (lambda (key . args) | |
341 | (push 10)))) | |
342 | ||
343 | ) | |
9bc915bb KR |
344 | |
345 | (with-test-prefix "false-if-exception" | |
8081c3fb | 346 | |
9bc915bb KR |
347 | (pass-if (false-if-exception #t)) |
348 | (pass-if (not (false-if-exception #f))) | |
349 | (pass-if (not (false-if-exception (error "xxx")))) | |
8081c3fb KR |
350 | |
351 | ;; Not yet working. | |
352 | ;; | |
353 | ;; (with-test-prefix "in empty environment" | |
354 | ;; ;; an environment with no bindings at all | |
355 | ;; (define empty-environment | |
356 | ;; (make-module 1)) | |
357 | ;; | |
358 | ;; (pass-if "#t" | |
359 | ;; (eval `(,false-if-exception #t) | |
360 | ;; empty-environment)) | |
361 | ;; (pass-if "#f" | |
362 | ;; (not (eval `(,false-if-exception #f) | |
363 | ;; empty-environment))) | |
364 | ;; (pass-if "exception" | |
365 | ;; (not (eval `(,false-if-exception (,error "xxx")) | |
366 | ;; empty-environment)))) | |
367 | ) |