1:
2:
3:
4:
5: (use gauche.test)
6: (test-start "exceptions")
7:
8:
9: (test-section "bare constructors")
10:
11: (test* "make <error>" '(#t #t #t #f)
12: (let ((e (make <error>)))
13: (list (is-a? e <condition>)
14: (is-a? e <serious-condition>)
15: (is-a? e <error>)
16: (ref e 'message))))
17:
18: (test* "make <message-condition>" "huge"
19: (ref (make <message-condition> :message "huge") 'message))
20:
21: (test* "make <error>" "hoge"
22: (ref (make <error> :message "hoge") 'message))
23:
24: (test* "make <system-error>" '("oops" 12)
25: (let ((e (make <system-error> :message "oops" :errno 12)))
26: (map (cut ref e <>) '(message errno))))
27:
28:
29: (test-section "srfi-35 constructors, predicates and accessors")
30:
31: (test* "make-condition <error>" '(#t #t #f "moo")
32: (let ((e (make-condition <error> 'message "moo")))
33: (list
34: (condition-has-type? e <error>)
35: (condition-has-type? e <serious-condition>)
36: (condition-has-type? e <read-error>)
37: (condition-ref e 'message))))
38:
39: (test* "make-condition <port-error>" `(#t #t #t #f "moo" ,(current-input-port))
40: (let ((e (make-condition <port-error>
41: 'port (current-input-port)
42: 'message "moo")))
43: (list
44: (condition-has-type? e <error>)
45: (condition-has-type? e <serious-condition>)
46: (condition-has-type? e <io-error>)
47: (condition-has-type? e <read-error>)
48: (condition-ref e 'message)
49: (condition-ref e 'port))))
50:
51: (test* "make-compound-condition"
52: `(#t #t #t "sys" 12 ,(current-input-port))
53: (let ((e (make-compound-condition
54: (make-condition <system-error>
55: 'message "sys" 'errno 12)
56: (make-condition <io-read-error>
57: 'message "io" 'port (current-input-port)))))
58: (list
59: (condition-has-type? e <error>)
60: (condition-has-type? e <system-error>)
61: (condition-has-type? e <io-read-error>)
62: (condition-ref e 'message)
63: (condition-ref e 'errno)
64: (condition-ref e 'port))))
65:
66: (test* "make-compound-condition"
67: `(#t #t #t "io" 12 ,(current-input-port))
68: (let ((e (make-compound-condition
69: (make-condition <io-read-error>
70: 'message "io" 'port (current-input-port))
71: (make-condition <system-error>
72: 'message "sys" 'errno 12))))
73: (list
74: (condition-has-type? e <error>)
75: (condition-has-type? e <system-error>)
76: (condition-has-type? e <io-read-error>)
77: (condition-ref e 'message)
78: (condition-ref e 'errno)
79: (condition-ref e 'port))))
80:
81: (test* "make-compound-condition"
82: `(#t #t #t "message" 12 ,(current-input-port))
83: (let ((e (make-compound-condition
84: (make-compound-condition
85: (make-condition <message-condition> 'message "message")
86: (make-condition <io-read-error>
87: 'message "io" 'port (current-input-port))
88: (make-condition <system-error>
89: 'message "sys" 'errno 12)))))
90: (list
91: (condition-has-type? e <error>)
92: (condition-has-type? e <system-error>)
93: (condition-has-type? e <io-read-error>)
94: (condition-ref e 'message)
95: (condition-ref e 'errno)
96: (condition-ref e 'port))))
97:
98: (test* "extract-condition"
99: `(("message")
100: ("message" ,(current-input-port))
101: ("message" 12))
102: (let* ((e (make-compound-condition
103: (make-compound-condition
104: (make-condition <message-condition> 'message "message")
105: (make-condition <io-read-error>
106: 'message "io" 'port (current-input-port))
107: (make-condition <system-error>
108: 'message "sys" 'errno 12))))
109: (m (extract-condition e <message-condition>))
110: (i (extract-condition e <io-read-error>))
111: (s (extract-condition e <system-error>)))
112: (list
113: (list (condition-ref m 'message))
114: (list (condition-ref i 'message) (condition-ref i 'port))
115: (list (condition-ref s 'message) (condition-ref s 'errno)))
116: ))
117:
118:
119: (test-section "srfi-35 style condition definitions")
120:
121: (define-condition-type &c &condition
122: c?
123: (x c-x))
124:
125: (define-condition-type &c1 &c
126: c1?
127: (a c1-a))
128:
129: (define-condition-type &c2 &c
130: c2?
131: (b c2-b))
132:
133: (let ((v1 #f) (v2 #f) (v3 #f) (v4 #f) (v5 #f))
134: (set! v1 (make-condition &c1 'x "V1" 'a "a1"))
135:
136: (test* "v1" '(#t #t #f "V1" "a1")
137: (list (c? v1) (c1? v1) (c2? v1) (c-x v1) (c1-a v1)))
138:
139: (set! v2 (condition (&c2
140: (x "V2")
141: (b "b2"))))
142:
143: (test* "v2" '(#t #f #t "V2" "b2")
144: (list (c? v2) (c1? v2) (c2? v2) (c-x v2) (c2-b v2)))
145:
146: (set! v3 (condition (&c1
147: (x "V3/1")
148: (a "a3"))
149: (&c2
150: (b "b3"))))
151: (test* "v3" '(#t #t #t "V3/1" "a3" "b3")
152: (list (c? v3) (c1? v3) (c2? v3) (c-x v3) (c1-a v3) (c2-b v3)))
153:
154: (set! v4 (make-compound-condition v1 v2))
155: (test* "v4" '(#t #t #t "V1" "a1" "b2")
156: (list (c? v4) (c1? v4) (c2? v4) (c-x v4) (c1-a v4) (c2-b v4)))
157:
158: (set! v5 (make-compound-condition v2 v3))
159: (test* "v5" '(#t #t #t "V2" "a3" "b2")
160: (list (c? v5) (c1? v5) (c2? v5) (c-x v5) (c1-a v5) (c2-b v5)))
161:
162: (test* "error (&c1)" "ok"
163: (with-error-handler
164: (lambda (e)
165: (and (is-a? e &c1)
166: (slot-ref e 'a)))
167: (lambda () (error &c1 :a "ok"))))
168: )
169:
170:
171: (test-section "guard")
172:
173: (test* "guard" '(symbol . a)
174: (guard (x
175: ((symbol? x) (cons 'symbol x))
176: ((is-a? x <error>) 'caught-error))
177: (raise 'a)))
178:
179: (test* "guard" 'caught-error
180: (guard (x
181: ((symbol? x) (cons 'symbol x))
182: ((is-a? x <error>) 'caught-error))
183: (car 'a)))
184:
185: (test* "guard" 'caught-error
186: (guard (x
187: ((symbol? x) (cons 'symbol x))
188: ((<error> x) 'caught-error))
189: (car 'a)))
190:
191: (test* "guard (uncaught error)" *test-error*
192: (guard (x
193: ((symbol? x) (cons 'symbol x))
194: ((is-a? x <error>) 'caught-error))
195: (raise 4)))
196:
197: (test* "guard (uncaught error)" '(else . 4)
198: (guard (x
199: ((symbol? x) (cons 'symbol x))
200: ((is-a? x <error>) 'caught-error)
201: (else (cons 'else x)))
202: (raise 4)))
203:
204: (test* "guard (subtype)" 'read-error
205: (guard (x
206: ((<read-error> x) 'read-error)
207: ((<system-error> x) 'system-error)
208: ((<error> x) 'error)
209: (else (cons 'else x)))
210: (read-from-string "(abc")))
211:
212: (test* "guard (nested)" 'exn
213: (with-error-handler
214: values
215: (lambda ()
216: (guard (ball
217: (#f (display "Caught exception.")))
218: (guard (ball
219: (#f (raise ball)))
220: (raise 'exn))))))
221:
222: (test* "guard (compound)" 'read-error
223: (guard (x
224: ((<read-error> x) 'read-error)
225: ((<system-error> x) 'system-error)
226: ((<error> x) 'error)
227: (else (cons 'else x)))
228: (raise (condition
229: (<io-error> (message "z"))
230: (<read-error> (message "foo"))
231: (<system-error> (message "bar"))))))
232:
233: (let ()
234: (define aaa '())
235: (define (foo)
236: (dynamic-wind
237: (lambda () (set! aaa '()))
238: (lambda ()
239: (set! aaa (cons 'a aaa))
240: (error "foo"))
241: (lambda ()
242: (set! aaa (cons 'b aaa)))))
243: (test* "guard w/dynamic-wind" '((b a) (b a))
244: (let1 x (guard (e (else aaa)) (foo))
245: (list x aaa))))
246:
247:
248:
249: (test-section "unwind-protect")
250:
251: (let ()
252: (define aaa '())
253: (define (foo thunk)
254: (dynamic-wind
255: (lambda () (push! aaa 'a))
256: (lambda () (push! aaa 'b) (thunk) (push! aaa 'c))
257: (lambda () (push! aaa 'd))))
258: (test* "unwind-protect (success)" '(e d c z b a)
259: (guard (e (else (push! aaa e) e))
260: (set! aaa '())
261: (unwind-protect
262: (foo (lambda () (push! aaa 'z)))
263: (push! aaa 'e))
264: aaa))
265: (test* "unwind-protect (raise)" '(boo e d b a)
266: (guard (e (else (push! aaa e) aaa))
267: (set! aaa '())
268: (unwind-protect
269: (foo (lambda () (raise 'boo)))
270: (push! aaa 'e))
271: aaa))
272: (test* "unwind-protect (error)" '(boo e d b a)
273: (guard (e (else (push! aaa 'boo) aaa))
274: (set! aaa '())
275: (unwind-protect
276: (foo (lambda () (error "boo")))
277: (push! aaa 'e))
278: aaa))
279:
280: (test* "unwind-protect (restart)" '(e d c a d z b a)
281: (begin
282: (set! aaa '())
283: (let ((k #f))
284: (let/cc k1
285: (unwind-protect
286: (foo (lambda ()
287: (let/cc k2
288: (set! k k2) (push! aaa 'z) (k1 0))))
289: (push! aaa 'e)))
290: (when k (let ((k0 k)) (set! k #f) (k0 0))))
291: aaa))
292: )
293:
294:
295: (test-section "subtype")
296:
297: (define-class <my-error> (<error>)
298: ((info :init-keyword :info)))
299:
300: (define-class <my-exc> (<exception>)
301: ((type :init-keyword :type)))
302:
303: (test* "<my-error>" '(#t "msg" "info")
304: (let ((e (make <my-error> :message "msg" :info "info")))
305: (list (is-a? e <error>)
306: (ref e 'message)
307: (ref e 'info))))
308:
309: (test* "catching <my-error>" '(caught . "ok")
310: (guard (x
311: ((is-a? x <error>) (cons 'caught (ref x 'message))))
312: (raise (make <my-error> :message "ok"))))
313:
314: (test* "<my-exc>" '(#t #f type)
315: (let ((e (make <my-exc> :type 'type)))
316: (list (is-a? e <exception>)
317: (is-a? e <error>)
318: (ref e 'type))))
319:
320: (test* "catching <my-exc>" 'exception
321: (guard (x
322: ((is-a? x <error>) 'error)
323: ((is-a? x <exception>) 'exception))
324: (raise (make <my-exc>))))
325:
326:
327: (test-section "combinations")
328:
329: (test* "guarding read-error" "Warning: read error:(input string port):1"
330: (guard (exc
331: ((condition-has-type? exc <read-error>)
332: (format "Warning: read error:~a:~a"
333: (port-name (ref exc 'port))
334: (ref exc 'line)))
335: ((condition-has-type? exc <io-port-error>)
336: (format "Warning: I/O error occurred on port ~a"
337: (port-name (ref exc 'port))))
338: (else
339: (format "Other error")))
340: (read-from-string "(abc")))
341:
342: (test* "guarding read-error (2)"
343: "Warning: read error:(input string port):1"
344: (guard (exc
345: ((<read-error> exc)
346: (format "Warning: read error:~a:~a"
347: (port-name (ref exc 'port))
348: (ref exc 'line)))
349: ((<io-port-error> exc)
350: (format "Warning: I/O error occurred on port ~a"
351: (port-name (ref exc 'port))))
352: (else
353: (format "Other error")))
354: (read-from-string "(abc")))
355:
356: (test-end)
