1 ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
2 ;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 Free Software Foundation, Inc.
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.
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.
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
19 (use-modules (test-suite lib))
21 (define-syntax-parameter push
23 (syntax-violation 'push "push used outside of throw-test" stx)))
25 (define-syntax-rule (throw-test title result expr ...)
29 (syntax-parameterize ((push (syntax-rules ()
31 (set! stack (cons val stack))))))
33 ;;(format #t "~a: ~s~%" title (reverse stack))
36 (with-test-prefix "throw/catch"
38 (with-test-prefix "wrong type argument"
40 (pass-if-exception "(throw 1)"
41 exception:wrong-type-arg
44 (with-test-prefix "wrong number of arguments"
46 (pass-if-exception "(throw)"
47 exception:wrong-num-args
50 (pass-if-exception "throw 1 / catch 0"
51 exception:wrong-num-args
53 (lambda () (throw 'a))
56 (pass-if-exception "throw 2 / catch 1"
57 exception:wrong-num-args
59 (lambda () (throw 'a 2))
62 (pass-if-exception "throw 1 / catch 2"
63 exception:wrong-num-args
65 (lambda () (throw 'a))
68 (pass-if-exception "throw 3 / catch 2"
69 exception:wrong-num-args
71 (lambda () (throw 'a 2 3))
74 (pass-if-exception "throw 1 / catch 2+"
75 exception:wrong-num-args
77 (lambda () (throw 'a))
78 (lambda (x y . rest) #f))))
80 (with-test-prefix "with pre-unwind handler"
82 (pass-if "pre-unwind fluid state"
83 (equal? '(inner outer arg)
84 (let ((fluid-parm (make-fluid))
86 (fluid-set! fluid-parm 'outer)
89 (with-fluids ((fluid-parm 'inner))
90 (throw 'misc-exc 'arg)))
93 (fluid-ref fluid-parm)
96 (set! inner-val (fluid-ref fluid-parm))))))))
98 (throw-test "normal catch"
107 (throw-test "catch and with-throw-handler"
122 (throw-test "catch with rethrowing throw-handler"
134 (apply throw key args))))
138 (throw-test "catch with pre-unwind handler"
149 (throw-test "catch with rethrowing pre-unwind handler"
159 (apply throw key args))))
161 (throw-test "catch with throw handler"
166 (with-throw-handler 'a
175 (throw-test "catch with rethrowing throw handler"
180 (with-throw-handler 'a
186 (apply throw key args))))
190 (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
195 (with-throw-handler 'b
211 (throw-test "with-throw-handler chaining"
216 (with-throw-handler 'a
219 (with-throw-handler 'a
232 (throw-test "throw handlers throwing to each other recursively"
237 (with-throw-handler 'a
240 (with-throw-handler 'b
243 (with-throw-handler 'c
263 (throw-test "throw handler throwing to lexically inside catch"
265 (with-throw-handler 'a
284 (throw-test "reuse of same throw handler after lexically inside catch"
285 '(0 1 2 7 5 4 6 7 10)
289 (with-throw-handler 'a
311 (throw-test "again but with two chained throw handlers"
312 '(0 1 11 2 13 7 5 4 12 13 7 10)
316 (with-throw-handler 'a
319 (with-throw-handler 'a
345 (with-test-prefix "false-if-exception"
347 (pass-if (false-if-exception #t))
348 (pass-if (not (false-if-exception #f)))
349 (pass-if (not (false-if-exception (error "xxx"))))
353 ;; (with-test-prefix "in empty environment"
354 ;; ;; an environment with no bindings at all
355 ;; (define empty-environment
359 ;; (eval `(,false-if-exception #t)
360 ;; empty-environment))
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))))