1 ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
3 ;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
10 ;;;; This program 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
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18 ;;;; Boston, MA 02110-1301 USA
20 (define-module (test-suite test-srfi-34)
21 :duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
22 :use-module (test-suite lib)
23 :use-module (srfi srfi-13)
24 :use-module (srfi srfi-34))
26 (define (expr-prints-and-evals-to? expr printout result)
27 (let ((actual-result *unspecified*))
28 (let ((actual-printout
30 (with-output-to-string
33 (eval expr (current-module))))))))
34 ;;(write (list actual-printout printout actual-result result))
36 (and (equal? actual-printout printout)
37 (equal? actual-result result)))))
39 (with-test-prefix "SRFI 34"
41 (pass-if "cond-expand"
42 (cond-expand (srfi-34 #t)
46 (expr-prints-and-evals-to?
47 '(call-with-current-continuation
49 (with-exception-handler (lambda (x)
50 (display "condition: ")
55 (+ 1 (raise 'an-error))))))
59 ;; SRFI 34 specifies that the behaviour of the call/cc expression
60 ;; after printing "something went wrong" is unspecified, which is
61 ;; tricky to test for in a positive way ... Guile behaviour at time
62 ;; of writing is to signal a "lazy-catch handler did return" error,
63 ;; which feels about right to me.
65 (expr-prints-and-evals-to?
67 (call-with-current-continuation
69 (with-exception-handler (lambda (x)
70 (display "something went wrong")
74 (+ 1 (raise 'an-error)))))))
75 "something went wrong"
79 (expr-prints-and-evals-to?
82 (display "condition: ")
86 (+ 1 (raise 'an-error)))
91 (expr-prints-and-evals-to?
94 (display "something went wrong")
97 (+ 1 (raise 'an-error)))
98 "something went wrong"
102 (expr-prints-and-evals-to?
103 '(call-with-current-continuation
105 (with-exception-handler (lambda (x)
106 (display "reraised ") (write x) (newline)
110 ((positive? condition) 'positive)
111 ((negative? condition) 'negative))
117 (expr-prints-and-evals-to?
118 '(call-with-current-continuation
120 (with-exception-handler (lambda (x)
121 (display "reraised ") (write x) (newline)
125 ((positive? condition) 'positive)
126 ((negative? condition) 'negative))
132 (expr-prints-and-evals-to?
133 '(call-with-current-continuation
135 (with-exception-handler (lambda (x)
136 (display "reraised ") (write x) (newline)
140 ((positive? condition) 'positive)
141 ((negative? condition) 'negative))
147 (expr-prints-and-evals-to?
149 ((assq 'a condition) => cdr)
150 ((assq 'b condition)))
151 (raise (list (cons 'a 42))))
156 (expr-prints-and-evals-to?
158 ((assq 'a condition) => cdr)
159 ((assq 'b condition)))
160 (raise (list (cons 'b 23))))
164 (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
165 ;; In Guile 1.8.5 and earlier, unwinders would be called before
166 ;; the exception handler, which reads "The handler is called in
167 ;; the dynamic environment of the call to `raise'".
171 (with-exception-handler
173 ;; This handler must be called before the unwinder below.
180 (raise 'some-exception))
182 ;; This unwinder should not be executed before the
183 ;; handler is called.
184 (set! inside? #f))))))))))