1 ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
3 ;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
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.
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.
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
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))
25 (define (expr-prints-and-evals-to? expr printout result)
26 (let ((actual-result *unspecified*))
27 (let ((actual-printout
29 (with-output-to-string
32 (eval expr (current-module))))))))
33 ;;(write (list actual-printout printout actual-result result))
35 (and (equal? actual-printout printout)
36 (equal? actual-result result)))))
38 (with-test-prefix "SRFI 34"
40 (pass-if "cond-expand"
41 (cond-expand (srfi-34 #t)
45 (expr-prints-and-evals-to?
46 '(call-with-current-continuation
48 (with-exception-handler (lambda (x)
49 (display "condition: ")
54 (+ 1 (raise 'an-error))))))
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.
64 (expr-prints-and-evals-to?
66 (call-with-current-continuation
68 (with-exception-handler (lambda (x)
69 (display "something went wrong")
73 (+ 1 (raise 'an-error)))))))
74 "something went wrong"
78 (expr-prints-and-evals-to?
81 (display "condition: ")
85 (+ 1 (raise 'an-error)))
90 (expr-prints-and-evals-to?
93 (display "something went wrong")
96 (+ 1 (raise 'an-error)))
97 "something went wrong"
101 (expr-prints-and-evals-to?
102 '(call-with-current-continuation
104 (with-exception-handler (lambda (x)
105 (display "reraised ") (write x) (newline)
109 ((positive? condition) 'positive)
110 ((negative? condition) 'negative))
116 (expr-prints-and-evals-to?
117 '(call-with-current-continuation
119 (with-exception-handler (lambda (x)
120 (display "reraised ") (write x) (newline)
124 ((positive? condition) 'positive)
125 ((negative? condition) 'negative))
131 (expr-prints-and-evals-to?
132 '(call-with-current-continuation
134 (with-exception-handler (lambda (x)
135 (display "reraised ") (write x) (newline)
139 ((positive? condition) 'positive)
140 ((negative? condition) 'negative))
146 (expr-prints-and-evals-to?
148 ((assq 'a condition) => cdr)
149 ((assq 'b condition)))
150 (raise (list (cons 'a 42))))
155 (expr-prints-and-evals-to?
157 ((assq 'a condition) => cdr)
158 ((assq 'b condition)))
159 (raise (list (cons 'b 23))))
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'".
170 (with-exception-handler
172 ;; This handler must be called before the unwinder below.
179 (raise 'some-exception))
181 ;; This unwinder should not be executed before the
182 ;; handler is called.
183 (set! inside? #f))))))))))