1;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
2;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 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 3 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(define-module (test-suite exceptions)
20  #:use-module (test-suite lib))
21
22(define-syntax-parameter push
23  (lambda (stx)
24    (syntax-violation 'push "push used outside of throw-test" stx)))
25
26(define-syntax-rule (throw-test title result expr ...)
27  (pass-if-equal title 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)))))
35
36(with-test-prefix "throw/catch"
37
38  (with-test-prefix "wrong type argument"
39
40    (pass-if-exception "(throw 1)"
41      exception:wrong-type-arg
42      (throw 1)))
43
44  (with-test-prefix "wrong number of arguments"
45
46    (pass-if-exception "(throw)"
47      exception:wrong-num-args
48      (throw))
49
50    (pass-if-exception "throw 1 / catch 0"
51      exception:wrong-num-args
52      (catch 'a
53	(lambda () (throw 'a))
54	(lambda () #f)))
55
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)))
61
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)))
67
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)))
73
74    (pass-if-exception "throw 1 / catch 2+"
75      exception:wrong-num-args
76      (catch 'a
77	(lambda () (throw 'a))
78	(lambda (x y . rest) #f))))
79
80  (with-test-prefix "with pre-unwind handler"
81
82    (pass-if "pre-unwind fluid state"
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
107  (throw-test "catch and with-throw-handler"
108	      '(1 2 3 4)
109	      (catch 'a
110		     (lambda ()
111		       (push 1)
112		       (with-throw-handler
113                        'a
114                        (lambda ()
115                          (push 2)
116                          (throw 'a))
117                        (lambda (key . args)
118                          (push 3))))
119		     (lambda (key . args)
120		       (push 4))))
121
122  (throw-test "catch with rethrowing throw-handler"
123	      '(1 2 3 4)
124	      (catch 'a
125		     (lambda ()
126		       (push 1)
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))))
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
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
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
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
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  )
344
345(with-test-prefix "false-if-exception"
346
347  (pass-if (false-if-exception #t))
348  (pass-if (not (false-if-exception #f)))
349  (pass-if (not (false-if-exception (error "xxx"))))
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  )
368
369(with-test-prefix "delimited exception handlers"
370  (define (catch* key thunk)
371    (let ((tag (make-prompt-tag)))
372      (call-with-prompt tag
373        (lambda ()
374          (catch key
375            (lambda ()
376              (abort-to-prompt tag)
377              (thunk))
378            (lambda args args)))
379        (lambda (k) k))))
380  (pass-if-equal '(foo)
381      (let ((thunk (catch* 'foo (lambda () (throw 'foo)))))
382        (thunk)))
383  (pass-if-equal '(foo)
384      (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
385             (thunk2 (catch* 'bar (lambda () (thunk1)))))
386        (thunk1)))
387  (pass-if-equal '(foo)
388      (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
389             (thunk2 (catch* 'bar (lambda () (thunk1)))))
390        (thunk2)))
391  (pass-if-equal '(bar)
392      (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
393             (thunk2 (catch* 'bar (lambda () (thunk1)))))
394        (thunk2))))
395