1 ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
2 ;;;; Copyright (C) 2001, 2003, 2004, 2006 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 2.1 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-macro (throw-test title result . exprs)
26 (set! stack (cons val stack)))))
30 ;;(write (reverse stack))
34 (with-test-prefix "throw/catch"
36 (with-test-prefix "wrong type argument"
38 (pass-if-exception "(throw 1)"
39 exception:wrong-type-arg
42 (with-test-prefix "wrong number of arguments"
44 (pass-if-exception "(throw)"
45 exception:wrong-num-args
48 (pass-if-exception "throw 1 / catch 0"
49 exception:wrong-num-args
51 (lambda () (throw 'a))
54 (pass-if-exception "throw 2 / catch 1"
55 exception:wrong-num-args
57 (lambda () (throw 'a 2))
60 (pass-if-exception "throw 1 / catch 2"
61 exception:wrong-num-args
63 (lambda () (throw 'a))
66 (pass-if-exception "throw 3 / catch 2"
67 exception:wrong-num-args
69 (lambda () (throw 'a 2 3))
72 (pass-if-exception "throw 1 / catch 2+"
73 exception:wrong-num-args
75 (lambda () (throw 'a))
76 (lambda (x y . rest) #f))))
78 (with-test-prefix "with lazy handler"
80 (pass-if "lazy fluid state"
81 (equal? '(inner outer arg)
82 (let ((fluid-parm (make-fluid))
84 (fluid-set! fluid-parm 'outer)
87 (with-fluids ((fluid-parm 'inner))
88 (throw 'misc-exc 'arg)))
91 (fluid-ref fluid-parm)
94 (set! inner-val (fluid-ref fluid-parm))))))))
96 (throw-test "normal catch"
105 (throw-test "catch and lazy catch"
119 (throw-test "catch with rethrowing lazy catch handler"
130 (apply throw key args))))
134 (throw-test "catch with pre-unwind handler"
145 (throw-test "catch with rethrowing pre-unwind handler"
155 (apply throw key args))))
157 (throw-test "catch with throw handler"
162 (with-throw-handler 'a
171 (throw-test "catch with rethrowing throw handler"
176 (with-throw-handler 'a
182 (apply throw key args))))
186 (throw-test "effect of lazy-catch unwinding on throw to another key"
207 (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
212 (with-throw-handler 'b
228 (throw-test "lazy-catch chaining"
249 (throw-test "with-throw-handler chaining"
254 (with-throw-handler 'a
257 (with-throw-handler 'a
270 (throw-test "with-throw-handler inside lazy-catch"
278 (with-throw-handler 'a
291 (throw-test "lazy-catch inside with-throw-handler"
296 (with-throw-handler 'a
312 (throw-test "throw handlers throwing to each other recursively"
317 (with-throw-handler 'a
320 (with-throw-handler 'b
323 (with-throw-handler 'c
343 (throw-test "repeat of previous test but with lazy-catch"
374 (throw-test "throw handler throwing to lexically inside catch"
376 (with-throw-handler 'a
395 (throw-test "reuse of same throw handler after lexically inside catch"
396 '(0 1 2 7 5 4 6 7 10)
400 (with-throw-handler 'a
422 (throw-test "again but with two chained throw handlers"
423 '(0 1 11 2 13 7 5 4 12 13 7 10)
427 (with-throw-handler 'a
430 (with-throw-handler 'a
456 (with-test-prefix "false-if-exception"
458 (pass-if (false-if-exception #t))
459 (pass-if (not (false-if-exception #f)))
460 (pass-if (not (false-if-exception (error "xxx"))))
464 ;; (with-test-prefix "in empty environment"
465 ;; ;; an environment with no bindings at all
466 ;; (define empty-environment
470 ;; (eval `(,false-if-exception #t)
471 ;; empty-environment))
473 ;; (not (eval `(,false-if-exception #f)
474 ;; empty-environment)))
475 ;; (pass-if "exception"
476 ;; (not (eval `(,false-if-exception (,error "xxx"))
477 ;; empty-environment))))