1;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
2;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
3;;;;
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,
10;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
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
16;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17
18
19(use-modules (test-suite lib))
20
21(define-macro (throw-test title result . exprs)
22  `(pass-if ,title
23     (equal? ,result
24	     (letrec ((stack '())
25		      (push (lambda (val)
26			      (set! stack (cons val stack)))))
27	       (begin ,@exprs)
28	       ;;(display ,title)
29	       ;;(display ": ")
30	       ;;(write (reverse stack))
31	       ;;(newline)
32	       (reverse stack)))))
33
34(with-test-prefix "throw/catch"
35
36  (with-test-prefix "wrong type argument"
37
38    (pass-if-exception "(throw 1)"
39      exception:wrong-type-arg
40      (throw 1)))
41
42  (with-test-prefix "wrong number of arguments"
43
44    (pass-if-exception "(throw)"
45      exception:wrong-num-args
46      (throw))
47
48    (pass-if-exception "throw 1 / catch 0"
49      exception:wrong-num-args
50      (catch 'a
51	(lambda () (throw 'a))
52	(lambda () #f)))
53
54    (pass-if-exception "throw 2 / catch 1"
55      exception:wrong-num-args
56      (catch 'a
57	(lambda () (throw 'a 2))
58	(lambda (x) #f)))
59
60    (pass-if-exception "throw 1 / catch 2"
61      exception:wrong-num-args
62      (catch 'a
63	(lambda () (throw 'a))
64	(lambda (x y) #f)))
65
66    (pass-if-exception "throw 3 / catch 2"
67      exception:wrong-num-args
68      (catch 'a
69	(lambda () (throw 'a 2 3))
70	(lambda (y x) #f)))
71
72    (pass-if-exception "throw 1 / catch 2+"
73      exception:wrong-num-args
74      (catch 'a
75	(lambda () (throw 'a))
76	(lambda (x y . rest) #f))))
77
78  (with-test-prefix "with lazy handler"
79
80    (pass-if "lazy fluid state"
81      (equal? '(inner outer arg)
82       (let ((fluid-parm (make-fluid))
83	     (inner-val #f))
84	 (fluid-set! fluid-parm 'outer)
85	 (catch 'misc-exc
86	   (lambda ()
87	     (with-fluids ((fluid-parm 'inner))
88	       (throw 'misc-exc 'arg)))
89	   (lambda (key . args)
90	     (list inner-val
91		   (fluid-ref fluid-parm)
92		   (car args)))
93	   (lambda (key . args)
94	     (set! inner-val (fluid-ref fluid-parm))))))))
95
96  (throw-test "normal catch"
97	      '(1 2)
98	      (catch 'a
99		     (lambda ()
100		       (push 1)
101		       (throw 'a))
102		     (lambda (key . args)
103		       (push 2))))
104
105  (throw-test "catch and lazy catch"
106	      '(1 2 3 4)
107	      (catch 'a
108		     (lambda ()
109		       (push 1)
110		       (lazy-catch 'a
111				   (lambda ()
112				     (push 2)
113				     (throw 'a))
114				   (lambda (key . args)
115				     (push 3))))
116		     (lambda (key . args)
117		       (push 4))))
118
119  (throw-test "catch with rethrowing lazy catch handler"
120	      '(1 2 3 4)
121	      (catch 'a
122		     (lambda ()
123		       (push 1)
124		       (lazy-catch 'a
125				   (lambda ()
126				     (push 2)
127				     (throw 'a))
128				   (lambda (key . args)
129				     (push 3)
130				     (apply throw key args))))
131		     (lambda (key . args)
132		       (push 4))))
133
134  (throw-test "catch with pre-unwind handler"
135	      '(1 3 2)
136	      (catch 'a
137		     (lambda ()
138		       (push 1)
139		       (throw 'a))
140		     (lambda (key . args)
141		       (push 2))
142		     (lambda (key . args)
143		       (push 3))))
144
145  (throw-test "catch with rethrowing pre-unwind handler"
146	      '(1 3 2)
147	      (catch 'a
148		     (lambda ()
149		       (push 1)
150		       (throw 'a))
151		     (lambda (key . args)
152		       (push 2))
153		     (lambda (key . args)
154		       (push 3)
155		       (apply throw key args))))
156
157  (throw-test "catch with throw handler"
158	      '(1 2 3 4)
159	      (catch 'a
160		     (lambda ()
161		       (push 1)
162		       (with-throw-handler 'a
163					   (lambda ()
164					     (push 2)
165					     (throw 'a))
166					   (lambda (key . args)
167					     (push 3))))
168		     (lambda (key . args)
169		       (push 4))))
170
171  (throw-test "catch with rethrowing throw handler"
172	      '(1 2 3 4)
173	      (catch 'a
174		     (lambda ()
175		       (push 1)
176		       (with-throw-handler 'a
177					   (lambda ()
178					     (push 2)
179					     (throw 'a))
180					   (lambda (key . args)
181					     (push 3)
182					     (apply throw key args))))
183		     (lambda (key . args)
184		       (push 4))))
185
186  (throw-test "effect of lazy-catch unwinding on throw to another key"
187	      '(1 2 3 5 7)
188	      (catch 'a
189		     (lambda ()
190		       (push 1)
191		       (lazy-catch 'b
192				   (lambda ()
193				     (push 2)
194				     (catch 'a
195					    (lambda ()
196					      (push 3)
197					      (throw 'b))
198					    (lambda (key . args)
199					      (push 4))))
200				   (lambda (key . args)
201				     (push 5)
202				     (throw 'a)))
203		       (push 6))
204		     (lambda (key . args)
205		       (push 7))))
206
207  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
208	      '(1 2 3 5 4 6)
209	      (catch 'a
210		     (lambda ()
211		       (push 1)
212		       (with-throw-handler 'b
213				   (lambda ()
214				     (push 2)
215				     (catch 'a
216					    (lambda ()
217					      (push 3)
218					      (throw 'b))
219					    (lambda (key . args)
220					      (push 4))))
221				   (lambda (key . args)
222				     (push 5)
223				     (throw 'a)))
224		       (push 6))
225		     (lambda (key . args)
226		       (push 7))))
227
228  (throw-test "lazy-catch chaining"
229	      '(1 2 3 4 6 8)
230	      (catch 'a
231	        (lambda ()
232		  (push 1)
233		  (lazy-catch 'a
234		    (lambda ()
235		      (push 2)
236		      (lazy-catch 'a
237                        (lambda ()
238			  (push 3)
239			  (throw 'a))
240			(lambda (key . args)
241			  (push 4)))
242		      (push 5))
243		    (lambda (key . args)
244		      (push 6)))
245		  (push 7))
246		(lambda (key . args)
247		  (push 8))))
248
249  (throw-test "with-throw-handler chaining"
250	      '(1 2 3 4 6 8)
251	      (catch 'a
252	        (lambda ()
253		  (push 1)
254		  (with-throw-handler 'a
255		    (lambda ()
256		      (push 2)
257		      (with-throw-handler 'a
258                        (lambda ()
259			  (push 3)
260			  (throw 'a))
261			(lambda (key . args)
262			  (push 4)))
263		      (push 5))
264		    (lambda (key . args)
265		      (push 6)))
266		  (push 7))
267		(lambda (key . args)
268		  (push 8))))
269
270  (throw-test "with-throw-handler inside lazy-catch"
271	      '(1 2 3 4 6 8)
272	      (catch 'a
273	        (lambda ()
274		  (push 1)
275		  (lazy-catch 'a
276		    (lambda ()
277		      (push 2)
278		      (with-throw-handler 'a
279                        (lambda ()
280			  (push 3)
281			  (throw 'a))
282			(lambda (key . args)
283			  (push 4)))
284		      (push 5))
285		    (lambda (key . args)
286		      (push 6)))
287		  (push 7))
288		(lambda (key . args)
289		  (push 8))))
290
291  (throw-test "lazy-catch inside with-throw-handler"
292	      '(1 2 3 4 6 8)
293	      (catch 'a
294	        (lambda ()
295		  (push 1)
296		  (with-throw-handler 'a
297		    (lambda ()
298		      (push 2)
299		      (lazy-catch 'a
300                        (lambda ()
301			  (push 3)
302			  (throw 'a))
303			(lambda (key . args)
304			  (push 4)))
305		      (push 5))
306		    (lambda (key . args)
307		      (push 6)))
308		  (push 7))
309		(lambda (key . args)
310		  (push 8))))
311
312  (throw-test "throw handlers throwing to each other recursively"
313	      '(1 2 3 4 8 6 10 12)
314	      (catch #t
315                (lambda ()
316		  (push 1)
317		  (with-throw-handler 'a
318                    (lambda ()
319		      (push 2)
320		      (with-throw-handler 'b
321		        (lambda ()
322			  (push 3)
323			  (with-throw-handler 'c
324			    (lambda ()
325			      (push 4)
326			      (throw 'b)
327			      (push 5))
328			    (lambda (key . args)
329			      (push 6)
330			      (throw 'a)))
331			  (push 7))
332			(lambda (key . args)
333			  (push 8)
334			  (throw 'c)))
335		      (push 9))
336		    (lambda (key . args)
337		      (push 10)
338		      (throw 'b)))
339		  (push 11))
340		(lambda (key . args)
341		  (push 12))))
342
343  (throw-test "repeat of previous test but with lazy-catch"
344	      '(1 2 3 4 8 12)
345	      (catch #t
346                (lambda ()
347		  (push 1)
348		  (lazy-catch 'a
349                    (lambda ()
350		      (push 2)
351		      (lazy-catch 'b
352		        (lambda ()
353			  (push 3)
354			  (lazy-catch 'c
355			    (lambda ()
356			      (push 4)
357			      (throw 'b)
358			      (push 5))
359			    (lambda (key . args)
360			      (push 6)
361			      (throw 'a)))
362			  (push 7))
363			(lambda (key . args)
364			  (push 8)
365			  (throw 'c)))
366		      (push 9))
367		    (lambda (key . args)
368		      (push 10)
369		      (throw 'b)))
370		  (push 11))
371		(lambda (key . args)
372		  (push 12))))
373
374  (throw-test "throw handler throwing to lexically inside catch"
375	      '(1 2 7 5 4 6 9)
376	      (with-throw-handler 'a
377				  (lambda ()
378				    (push 1)
379				    (catch 'b
380					   (lambda ()
381					     (push 2)
382					     (throw 'a)
383					     (push 3))
384					   (lambda (key . args)
385					     (push 4))
386					   (lambda (key . args)
387					     (push 5)))
388				    (push 6))
389				  (lambda (key . args)
390				    (push 7)
391				    (throw 'b)
392				    (push 8)))
393	      (push 9))
394
395  (throw-test "reuse of same throw handler after lexically inside catch"
396	      '(0 1 2 7 5 4 6 7 10)
397	      (catch 'b
398	        (lambda ()
399		  (push 0)
400		  (with-throw-handler 'a
401		    (lambda ()
402		      (push 1)
403		      (catch 'b
404		        (lambda ()
405			  (push 2)
406			  (throw 'a)
407			  (push 3))
408			(lambda (key . args)
409			  (push 4))
410			(lambda (key . args)
411			  (push 5)))
412		      (push 6)
413		      (throw 'a))
414		    (lambda (key . args)
415		      (push 7)
416		      (throw 'b)
417		      (push 8)))
418		  (push 9))
419		(lambda (key . args)
420		  (push 10))))
421
422  (throw-test "again but with two chained throw handlers"
423	      '(0 1 11 2 13 7 5 4 12 13 7 10)
424	      (catch 'b
425	        (lambda ()
426		  (push 0)
427		  (with-throw-handler 'a
428		    (lambda ()
429		      (push 1)
430		      (with-throw-handler 'a
431		        (lambda ()
432			  (push 11)
433			  (catch 'b
434			    (lambda ()
435			      (push 2)
436			      (throw 'a)
437			      (push 3))
438			    (lambda (key . args)
439			      (push 4))
440			    (lambda (key . args)
441			      (push 5)))
442			  (push 12)
443			  (throw 'a))
444			(lambda (key . args)
445			  (push 13)))
446		      (push 6))
447		    (lambda (key . args)
448		      (push 7)
449		      (throw 'b)))
450		  (push 9))
451		(lambda (key . args)
452		  (push 10))))
453
454  )
455
456(with-test-prefix "false-if-exception"
457
458  (pass-if (false-if-exception #t))
459  (pass-if (not (false-if-exception #f)))
460  (pass-if (not (false-if-exception (error "xxx"))))
461
462  ;; Not yet working.
463  ;;
464  ;; (with-test-prefix "in empty environment"
465  ;;   ;; an environment with no bindings at all
466  ;;   (define empty-environment
467  ;;     (make-module 1))
468  ;;
469  ;;   (pass-if "#t"
470  ;;     (eval `(,false-if-exception #t)
471  ;; 	    empty-environment))
472  ;;   (pass-if "#f"
473  ;;     (not (eval `(,false-if-exception #f)
474  ;; 		 empty-environment)))
475  ;;   (pass-if "exception"
476  ;;     (not (eval `(,false-if-exception (,error "xxx"))
477  ;;                empty-environment))))
478  )
479