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 /module/srfi | |
| 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 'module/srfi')
| -rw-r--r-- | module/srfi/srfi-34.scm | 52 |
1 files changed, 20 insertions, 32 deletions
diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm index 183f0ae23..0e7ad995d 100644 --- a/module/srfi/srfi-34.scm +++ b/module/srfi/srfi-34.scm @@ -27,32 +27,12 @@ ;;; Code: (define-module (srfi srfi-34) - #:export (with-exception-handler) - #:replace (raise) + #:re-export (with-exception-handler + (raise-exception . raise)) #:export-syntax (guard)) (cond-expand-provide (current-module) '(srfi-34)) -(define throw-key 'srfi-34) - -(define (with-exception-handler handler thunk) - "Returns the result(s) of invoking THUNK. HANDLER must be a -procedure that accepts one argument. It is installed as the current -exception handler for the dynamic extent (as determined by -dynamic-wind) of the invocation of THUNK." - (with-throw-handler throw-key - thunk - (lambda (key obj) - (handler obj)))) - -(define (raise obj) - "Invokes the current exception handler on OBJ. The handler is -called in the dynamic environment of the call to raise, except that -the current exception handler is that in place for the call to -with-exception-handler that installed the handler being called. The -handler's continuation is otherwise unspecified." - (throw throw-key obj)) - (define-syntax guard (syntax-rules (else) "Syntax: (guard (<var> <clause1> <clause2> ...) <body>) @@ -68,17 +48,25 @@ clause, then raise is re-invoked on the raised object within the dynamic environment of the original call to raise except that the current exception handler is that of the guard expression." ((guard (var clause ... (else e e* ...)) body body* ...) - (catch throw-key - (lambda () body body* ...) - (lambda (key var) - (cond clause ... - (else e e* ...))))) + (with-exception-handler + (lambda (var) + (cond clause ... + (else e e* ...))) + (lambda () body body* ...) + #:unwind? #t)) ((guard (var clause clause* ...) body body* ...) - (catch throw-key - (lambda () body body* ...) - (lambda (key var) - (cond clause clause* ... - (else (throw key var)))))))) + (let ((tag (make-prompt-tag))) + (call-with-prompt + tag + (lambda () + (with-exception-handler + (lambda (exn) + (abort-to-prompt tag exn) + (raise-exception exn)) + (lambda () body body* ...))) + (lambda (rewind var) + (cond clause clause* ... + (else (rewind))))))))) ;;; (srfi srfi-34) ends here. |