1;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
2;;;;
3;;;; 	Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19(define-module (test-suite test-srfi-34)
20  :duplicates (last)  ;; avoid warning about srfi-34 replacing `raise'
21  :use-module (test-suite lib)
22  :use-module (srfi srfi-13)
23  :use-module (srfi srfi-34))
24
25(define (expr-prints-and-evals-to? expr printout result)
26  (let ((actual-result *unspecified*))
27    (let ((actual-printout
28	   (string-trim-both
29	    (with-output-to-string
30	      (lambda ()
31		(set! actual-result
32		      (eval expr (current-module))))))))
33      ;;(write (list actual-printout printout actual-result result))
34      ;;(newline)
35      (and (equal? actual-printout printout)
36	   (equal? actual-result result)))))
37
38(with-test-prefix "SRFI 34"
39
40  (pass-if "cond-expand"
41    (cond-expand (srfi-34 #t)
42		 (else    #f)))
43
44  (pass-if "example 1"
45	   (expr-prints-and-evals-to?
46	    '(call-with-current-continuation
47	      (lambda (k)
48		(with-exception-handler (lambda (x)
49					  (display "condition: ")
50					  (write x)
51					  (newline)
52					  (k 'exception))
53					(lambda ()
54					  (+ 1 (raise 'an-error))))))
55	    "condition: an-error"
56	    'exception))
57
58  ;; SRFI 34 specifies that the behaviour of the call/cc expression
59  ;; after printing "something went wrong" is unspecified, which is
60  ;; tricky to test for in a positive way ...  Guile behaviour at time
61  ;; of writing is to signal a "lazy-catch handler did return" error,
62  ;; which feels about right to me.
63  (pass-if "example 2"
64	   (expr-prints-and-evals-to?
65	    '(false-if-exception
66	      (call-with-current-continuation
67	       (lambda (k)
68		 (with-exception-handler (lambda (x)
69					   (display "something went wrong")
70					   (newline)
71					   'dont-care)
72					 (lambda ()
73					   (+ 1 (raise 'an-error)))))))
74	    "something went wrong"
75	    #f))
76
77  (pass-if "example 3"
78	   (expr-prints-and-evals-to?
79	    '(guard (condition
80		     (else
81		      (display "condition: ")
82		      (write condition)
83		      (newline)
84		      'exception))
85		    (+ 1 (raise 'an-error)))
86	    "condition: an-error"
87	    'exception))
88
89  (pass-if "example 4"
90	   (expr-prints-and-evals-to?
91	    '(guard (condition
92		     (else
93		      (display "something went wrong")
94		      (newline)
95		      'dont-care))
96		    (+ 1 (raise 'an-error)))
97	    "something went wrong"
98	    'dont-care))
99
100  (pass-if "example 5"
101	   (expr-prints-and-evals-to?
102	    '(call-with-current-continuation
103	      (lambda (k)
104		(with-exception-handler (lambda (x)
105					  (display "reraised ") (write x) (newline)
106					  (k 'zero))
107					(lambda ()
108					  (guard (condition
109						  ((positive? condition) 'positive)
110						  ((negative? condition) 'negative))
111						 (raise 1))))))
112	    ""
113	    'positive))
114
115  (pass-if "example 6"
116	   (expr-prints-and-evals-to?
117	    '(call-with-current-continuation
118	      (lambda (k)
119		(with-exception-handler (lambda (x)
120					  (display "reraised ") (write x) (newline)
121					  (k 'zero))
122					(lambda ()
123					  (guard (condition
124						  ((positive? condition) 'positive)
125						  ((negative? condition) 'negative))
126						 (raise -1))))))
127	    ""
128	    'negative))
129
130  (pass-if "example 7"
131	   (expr-prints-and-evals-to?
132	    '(call-with-current-continuation
133	      (lambda (k)
134		(with-exception-handler (lambda (x)
135					  (display "reraised ") (write x) (newline)
136					  (k 'zero))
137					(lambda ()
138					  (guard (condition
139						  ((positive? condition) 'positive)
140						  ((negative? condition) 'negative))
141						 (raise 0))))))
142	    "reraised 0"
143	    'zero))
144
145  (pass-if "example 8"
146	   (expr-prints-and-evals-to?
147	    '(guard (condition
148		     ((assq 'a condition) => cdr)
149		     ((assq 'b condition)))
150		    (raise (list (cons 'a 42))))
151	    ""
152	    42))
153
154  (pass-if "example 9"
155	   (expr-prints-and-evals-to?
156	    '(guard (condition
157		     ((assq 'a condition) => cdr)
158		     ((assq 'b condition)))
159		    (raise (list (cons 'b 23))))
160	    ""
161	    '(b . 23)))
162
163  (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
164           ;; In Guile 1.8.5 and earlier, unwinders would be called before
165           ;; the exception handler, which reads "The handler is called in
166           ;; the dynamic environment of the call to `raise'".
167           (call/cc
168            (lambda (return)
169              (let ((inside? #f))
170                (with-exception-handler
171                 (lambda (c)
172                   ;; This handler must be called before the unwinder below.
173                   (return inside?))
174                 (lambda ()
175                   (dynamic-wind
176                     (lambda ()
177                       (set! inside? #t))
178                     (lambda ()
179                       (raise 'some-exception))
180                     (lambda ()
181                       ;; This unwinder should not be executed before the
182                       ;; handler is called.
183                       (set! inside? #f))))))))))
184