mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
f4ca107f7f
* libguile/exceptions.c:
* libguile/exceptions.h: New files.
* libguile.h: Add exceptions.h.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add exceptions.c and
exceptions.h.
* libguile/init.c (scm_i_init_guile): Initialize exceptions.
* libguile/threads.c (scm_spawn_thread): Use new names for
scm_i_make_catch_handler and scm_c_make_thunk.
* libguile/throw.c: Rewrite to be implemented in terms of
with-exception-handler / raise-exception.
* libguile/throw.h: Use data types from exceptions.h. Move
scm_report_stack_overflow and scm_report_out_of_memory to
exceptions.[ch].
* module/ice-9/boot-9.scm (&error, &programming-error)
(&non-continuable, make-exception-from-throw, raise-exception)
(with-exception-handler): New top-level definitions.
(throw, catch, with-throw-handler): Rewrite in terms of
with-exception-handler and raise-exception.
: New top-level definitions.
* module/ice-9/exceptions.scm: Adapt to re-export &error,
&programming-error, &non-continuable, raise-exception, and
with-exception-handler from boot-9.
(make-quit-exception, guile-quit-exception-converter): New exception
converters.
(make-exception-from-throw): Override core binding.
* test-suite/tests/eval.test ("inner trim with prompt tag"): Adapt to
"with-exception-handler" being the procedure on the stack.
("outer trim with prompt tag"): Likewise.
* test-suite/tests/exceptions.test (throw-test): Use pass-if-equal.
* module/srfi/srfi-34.scm: Reimplement in terms of core exceptions, and
make "guard" actually re-raise continuations with the original "raise"
continuation.
394 lines
9.8 KiB
Scheme
394 lines
9.8 KiB
Scheme
;;;; 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 (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))))
|