mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

Rebase throw/catch on top of raise-exception/with-exception-handler

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-11-08 15:31:00 +01:00
parent f2c8ff5a52
commit f4ca107f7f
13 changed files with 1104 additions and 633 deletions
Download patch file Download diff file Expand all files Collapse all files

52
module/srfi/srfi-34.scm
View file

@ -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.