diff options
author | Andy Wingo <wingo@pobox.com> | 2019-11-08 15:31:00 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-13 22:24:19 +0100 |
commit | f4ca107f7fe0b6f1ca2c03b558f16077fc89db04 (patch) | |
tree | 2e444d63f7ecca2cb4ff5b52890e22aaea0810fe /test-suite/tests | |
parent | f2c8ff5a52eb7073b50151d5d14d2e6ab351fa4f (diff) | |
download | guile-f4ca107f7fe0b6f1ca2c03b558f16077fc89db04.tar.gz |
Rebase throw/catch on top of raise-exception/with-exception-handler
* 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.
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/eval.test | 16 | ||||
-rw-r--r-- | test-suite/tests/exceptions.test | 17 |
2 files changed, 16 insertions, 17 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 8a52e11f2..71b06f756 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,6 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2000-2001,2003-2015,2017,2019 +;;;; 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 @@ -387,12 +388,11 @@ (pass-if "inner trim with prompt tag" (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag))) (frames (stack->frames stack))) - ;; the top frame on the stack is the lambda inside the 'catch, and the - ;; next frame is the (catch 'result ...) - (and (eq? (car (frame-call-representation (cadr frames))) - 'catch) - (eq? (car (frame-arguments (cadr frames))) - 'result)))) + ;; the top frame on the stack is the body of the catch, and the + ;; next frame is the with-exception-handler corresponding to the + ;; (catch 'result ...) + (eq? (car (frame-call-representation (cadr frames))) + 'with-exception-handler))) (pass-if "outer trim with prompt tag" (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag))) @@ -402,7 +402,7 @@ (and (eq? (car (frame-call-representation (car frames))) 'make-stack) (eq? (car (frame-call-representation (car (last-pair frames)))) - 'with-throw-handler))))) + 'with-exception-handler))))) ;;; ;;; letrec init evaluation diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 391a19dca..291e10e26 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -24,15 +24,14 @@ (syntax-violation 'push "push used outside of throw-test" stx))) (define-syntax-rule (throw-test title result expr ...) - (pass-if title - (equal? 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)))))) + (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" |