mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity
guile/test-suite/tests/exceptions.test
Andy Wingo 02dfb6e776 Fix exn dispatch for exns within pre-unwind handlers 
* libguile/exceptions.c (exception_epoch_fluid): Rename from
active_exception_handlers_fluid.
(scm_dynwind_throw_handler): Increment exception epoch instead of
resetting active exception handlers.
(scm_init_exceptions): Update.
* module/ice-9/boot-9.scm  (with-exception-handler): Rework to associate
an "epoch" fluid with each exception handler.
(with-throw-handler): Establish a new epoch, during the execution of a
throw handler.
(raise-exception): Rework to avoid capturing a list of exception
handlers, and to use epochs as a way to know which handlers have already
been examined and which are on the dispatch stack.
* test-suite/tests/exceptions.test ("throwing within exception
handlers"): New test.
2023-06-08 10:26:16 +02:00

406 lines
10 KiB
Scheme
Raw Permalink Blame History

;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite exceptions)
#:use-module (ice-9 control)
#:use-module (test-suite lib))
(define-syntax-parameter push
(lambda (stx)
(syntax-violation 'push "push used outside of throw-test" stx)))
(define-syntax-rule (throw-test title result expr ...)
(pass-if-equal title result
(let ((stack '()))
(syntax-parameterize ((push (syntax-rules ()
((push val)
(set! stack (cons val stack))))))
expr ...
;;(format #t "~a: ~s~%" title (reverse stack))
(reverse stack)))))
(with-test-prefix "throw/catch"
(with-test-prefix "wrong type argument"
(pass-if-exception "(throw 1)"
exception:wrong-type-arg
(throw 1)))
(with-test-prefix "wrong number of arguments"
(pass-if-exception "(throw)"
exception:wrong-num-args
(throw))
(pass-if-exception "throw 1 / catch 0"
exception:wrong-num-args
(catch 'a
(lambda () (throw 'a))
(lambda () #f)))
(pass-if-exception "throw 2 / catch 1"
exception:wrong-num-args
(catch 'a
(lambda () (throw 'a 2))
(lambda (x) #f)))
(pass-if-exception "throw 1 / catch 2"
exception:wrong-num-args
(catch 'a
(lambda () (throw 'a))
(lambda (x y) #f)))
(pass-if-exception "throw 3 / catch 2"
exception:wrong-num-args
(catch 'a
(lambda () (throw 'a 2 3))
(lambda (y x) #f)))
(pass-if-exception "throw 1 / catch 2+"
exception:wrong-num-args
(catch 'a
(lambda () (throw 'a))
(lambda (x y . rest) #f))))
(with-test-prefix "with pre-unwind handler"
(pass-if "pre-unwind fluid state"
(equal? '(inner outer arg)
(let ((fluid-parm (make-fluid))
(inner-val #f))
(fluid-set! fluid-parm 'outer)
(catch 'misc-exc
(lambda ()
(with-fluids ((fluid-parm 'inner))
(throw 'misc-exc 'arg)))
(lambda (key . args)
(list inner-val
(fluid-ref fluid-parm)
(car args)))
(lambda (key . args)
(set! inner-val (fluid-ref fluid-parm))))))))
(throw-test "normal catch"
'(1 2)
(catch 'a
(lambda ()
(push 1)
(throw 'a))
(lambda (key . args)
(push 2))))
(throw-test "catch and with-throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler
'a
(lambda ()
(push 2)
(throw 'a))
(lambda (key . args)
(push 3))))
(lambda (key . args)
(push 4))))
(throw-test "catch with rethrowing throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler
'a
(lambda ()
(push 2)
(throw 'a))
(lambda (key . args)
(push 3)
(apply throw key args))))
(lambda (key . args)
(push 4))))
(throw-test "catch with pre-unwind handler"
'(1 3 2)
(catch 'a
(lambda ()
(push 1)
(throw 'a))
(lambda (key . args)
(push 2))
(lambda (key . args)
(push 3))))
(throw-test "catch with rethrowing pre-unwind handler"
'(1 3 2)
(catch 'a
(lambda ()
(push 1)
(throw 'a))
(lambda (key . args)
(push 2))
(lambda (key . args)
(push 3)
(apply throw key args))))
(throw-test "catch with throw handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler 'a
(lambda ()
(push 2)
(throw 'a))
(lambda (key . args)
(push 3))))
(lambda (key . args)
(push 4))))
(throw-test "catch with rethrowing throw handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler 'a
(lambda ()
(push 2)
(throw 'a))
(lambda (key . args)
(push 3)
(apply throw key args))))
(lambda (key . args)
(push 4))))
(throw-test "effect of with-throw-handler not-unwinding on throw to another key"
'(1 2 3 5 4 6)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler 'b
(lambda ()
(push 2)
(catch 'a
(lambda ()
(push 3)
(throw 'b))
(lambda (key . args)
(push 4))))
(lambda (key . args)
(push 5)
(throw 'a)))
(push 6))
(lambda (key . args)
(push 7))))
(throw-test "with-throw-handler chaining"
'(1 2 3 4 6 8)
(catch 'a
(lambda ()
(push 1)
(with-throw-handler 'a
(lambda ()
(push 2)
(with-throw-handler 'a
(lambda ()
(push 3)
(throw 'a))
(lambda (key . args)
(push 4)))
(push 5))
(lambda (key . args)
(push 6)))
(push 7))
(lambda (key . args)
(push 8))))
(throw-test "throw handlers throwing to each other recursively"
'(1 2 3 4 8 6 10 12)
(catch #t
(lambda ()
(push 1)
(with-throw-handler 'a
(lambda ()
(push 2)
(with-throw-handler 'b
(lambda ()
(push 3)
(with-throw-handler 'c
(lambda ()
(push 4)
(throw 'b)
(push 5))
(lambda (key . args)
(push 6)
(throw 'a)))
(push 7))
(lambda (key . args)
(push 8)
(throw 'c)))
(push 9))
(lambda (key . args)
(push 10)
(throw 'b)))
(push 11))
(lambda (key . args)
(push 12))))
(throw-test "throw handler throwing to lexically inside catch"
'(1 2 7 5 4 6 9)
(with-throw-handler 'a
(lambda ()
(push 1)
(catch 'b
(lambda ()
(push 2)
(throw 'a)
(push 3))
(lambda (key . args)
(push 4))
(lambda (key . args)
(push 5)))
(push 6))
(lambda (key . args)
(push 7)
(throw 'b)
(push 8)))
(push 9))
(throw-test "reuse of same throw handler after lexically inside catch"
'(0 1 2 7 5 4 6 7 10)
(catch 'b
(lambda ()
(push 0)
(with-throw-handler 'a
(lambda ()
(push 1)
(catch 'b
(lambda ()
(push 2)
(throw 'a)
(push 3))
(lambda (key . args)
(push 4))
(lambda (key . args)
(push 5)))
(push 6)
(throw 'a))
(lambda (key . args)
(push 7)
(throw 'b)
(push 8)))
(push 9))
(lambda (key . args)
(push 10))))
(throw-test "again but with two chained throw handlers"
'(0 1 11 2 13 7 5 4 12 13 7 10)
(catch 'b
(lambda ()
(push 0)
(with-throw-handler 'a
(lambda ()
(push 1)
(with-throw-handler 'a
(lambda ()
(push 11)
(catch 'b
(lambda ()
(push 2)
(throw 'a)
(push 3))
(lambda (key . args)
(push 4))
(lambda (key . args)
(push 5)))
(push 12)
(throw 'a))
(lambda (key . args)
(push 13)))
(push 6))
(lambda (key . args)
(push 7)
(throw 'b)))
(push 9))
(lambda (key . args)
(push 10))))
)
(with-test-prefix "false-if-exception"
(pass-if (false-if-exception #t))
(pass-if (not (false-if-exception #f)))
(pass-if (not (false-if-exception (error "xxx"))))
;; Not yet working.
;;
;; (with-test-prefix "in empty environment"
;; ;; an environment with no bindings at all
;; (define empty-environment
;; (make-module 1))
;;
;; (pass-if "#t"
;; (eval `(,false-if-exception #t)
;; empty-environment))
;; (pass-if "#f"
;; (not (eval `(,false-if-exception #f)
;; empty-environment)))
;; (pass-if "exception"
;; (not (eval `(,false-if-exception (,error "xxx"))
;; empty-environment))))
)
(with-test-prefix "delimited exception handlers"
(define (catch* key thunk)
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(lambda ()
(catch key
(lambda ()
(abort-to-prompt tag)
(thunk))
(lambda args args)))
(lambda (k) k))))
(pass-if-equal '(foo)
(let ((thunk (catch* 'foo (lambda () (throw 'foo)))))
(thunk)))
(pass-if-equal '(foo)
(let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
(thunk2 (catch* 'bar (lambda () (thunk1)))))
(thunk1)))
(pass-if-equal '(foo)
(let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
(thunk2 (catch* 'bar (lambda () (thunk1)))))
(thunk2)))
(pass-if-equal '(bar)
(let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
(thunk2 (catch* 'bar (lambda () (thunk1)))))
(thunk2))))
(with-test-prefix "throwing within exception handlers"
(pass-if "https://github.com/wingo/fibers/issues/76"
(let/ec return
(with-exception-handler
(lambda (e)
(catch #t
(lambda () (error "bar"))
(lambda args #f))
(return #t))
(lambda () (error "foo"))))))
View git blame Copy permalink