[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/04: Add implementation of exceptions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/04: Add implementation of exceptions |
|
Date: |
Sun, 13 Oct 2019 14:50:41 -0400 (EDT) |
wingo pushed a commit to branch wip-exceptions
in repository guile.
commit 82efe6f310be4db42d97eedacd35ab5e16de75d7
Author: Andy Wingo <address@hidden>
Date: Thu Oct 10 16:46:36 2019 +0200
Add implementation of exceptions
This commit adds `raise-exception' and `with-exception-handler'. The
idea is that Guile's `throw' and `catch' will be rebased on top of these
primitives.
* libguile/exceptions.c:
* libguile/exceptions.h: New files.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS):
* libguile.h:
* libguile/init.c (scm_i_init_guile): Add new files.
* module/ice-9/boot-9.scm (make-guile-exception, guile-exception?):
(%guile-exception-key, %guile-exception-args):
(guile-exception-key, guile-exception-args):
(quit-exception?, quit-exception-code, raise-continuable): New
functions.
(with-exception-handler, raise-exception): Add Scheme
implementations.
---
libguile.h | 1 +
libguile/Makefile.am | 4 +
libguile/exceptions.c | 471 ++++++++++++++++++++++++++++++++++++++++++++++++
libguile/exceptions.h | 65 +++++++
libguile/init.c | 2 +
module/ice-9/boot-9.scm | 135 ++++++++++++++
6 files changed, 678 insertions(+)
diff --git a/libguile.h b/libguile.h
index 53479d8..2372635 100644
--- a/libguile.h
+++ b/libguile.h
@@ -49,6 +49,7 @@ extern "C" {
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/evalext.h"
+#include "libguile/exceptions.h"
#include "libguile/extensions.h"
#include "libguile/fdes-finalizers.h"
#include "libguile/feature.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 2050a48..43411c5 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -148,6 +148,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =
\
error.c \
eval.c \
evalext.c \
+ exceptions.c \
expand.c \
extensions.c \
fdes-finalizers.c \
@@ -264,6 +265,7 @@ DOT_X_FILES = \
error.x \
eval.x \
evalext.x \
+ exceptions.x \
expand.x \
extensions.x \
fdes-finalizers.x \
@@ -372,6 +374,7 @@ DOT_DOC_FILES = \
error.doc \
eval.doc \
evalext.doc \
+ exceptions.doc \
expand.doc \
extensions.doc \
fdes-finalizers.doc \
@@ -616,6 +619,7 @@ modinclude_HEADERS = \
error.h \
eval.h \
evalext.h \
+ exceptions.h \
expand.h \
extensions.h \
fdes-finalizers.h \
diff --git a/libguile/exceptions.c b/libguile/exceptions.c
new file mode 100644
index 0000000..66e9de9
--- /dev/null
+++ b/libguile/exceptions.c
@@ -0,0 +1,471 @@
+/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+#include <stdio.h>
+#include <unistdio.h>
+
+#include "boolean.h"
+#include "control.h"
+#include "eq.h"
+#include "eval.h"
+#include "fluids.h"
+#include "gsubr.h"
+#include "init.h"
+#include "keywords.h"
+#include "list.h"
+#include "modules.h"
+#include "numbers.h"
+#include "pairs.h"
+#include "ports.h"
+#include "smob.h"
+#include "stackchk.h"
+#include "stacks.h"
+#include "strings.h"
+#include "symbols.h"
+#include "variable.h"
+
+#include "exceptions.h"
+
+
+/* Pleasantly enough, the guts of exception handling are defined in
+ Scheme, in terms of prompt, abort, and the %exception-handler fluid.
+ Check boot-9 for the definitions.
+
+ Still, it's useful to be able to raise unwind-only exceptions from C,
+ for example so that we can recover from stack overflow. We also need
+ to have implementations of with-exception-handler and raise handy
+ before boot time. For that reason we have a parallel implementation
+ of with-exception-handler that uses the same fluids here. Exceptions
+ raised from C still call out to Scheme though, so that pre-unwind
+ handlers can be run. */
+
+
+
+
+/* First, some support for C bodies and exception handlers. */
+
+static scm_t_bits tc16_thunk;
+static scm_t_bits tc16_exception_handler;
+
+SCM
+scm_c_make_thunk (scm_t_thunk thunk, void *data)
+{
+ SCM_RETURN_NEWSMOB2 (tc16_thunk, thunk, data);
+}
+
+SCM
+scm_c_make_exception_handler (scm_t_exception_handler handler, void *data)
+{
+ SCM_RETURN_NEWSMOB2 (tc16_exception_handler, handler, data);
+}
+
+static SCM
+call_thunk (SCM clo)
+{
+ scm_t_thunk thunk = (void*)SCM_SMOB_DATA (clo);
+ void *data = (void*)SCM_SMOB_DATA_2 (clo);
+
+ return thunk (data);
+}
+
+static SCM
+call_exception_handler (SCM clo, SCM exn)
+{
+ scm_t_exception_handler handler = (void*)SCM_SMOB_DATA (clo);
+ void *data = (void*)SCM_SMOB_DATA_2 (clo);
+
+ return handler (data, exn);
+}
+
+
+
+
+/* Now, the implementation of with-exception-handler used internally to
+ Guile at boot-time. */
+
+SCM_KEYWORD (kw_unwind_p, "unwind?");
+SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type");
+static SCM exception_handler_fluid;
+static SCM with_exception_handler_var;
+
+SCM
+scm_c_with_exception_handler (SCM type, scm_t_exception_handler handler,
+ void *handler_data,
+ scm_t_thunk thunk, void *thunk_data)
+{
+ if (!scm_is_eq (type, SCM_BOOL_T) && !scm_is_symbol (type))
+ scm_wrong_type_arg ("%with-exception-handler", 1, type);
+
+ SCM prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
+ scm_thread *t = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &t->dynstack;
+ scm_t_dynamic_state *dynamic_state = t->dynamic_state;
+ jmp_buf registers;
+ jmp_buf *prev_registers;
+ ptrdiff_t saved_stack_depth;
+ uint8_t *mra = NULL;
+
+ prev_registers = t->vm.registers;
+ saved_stack_depth = t->vm.stack_top - t->vm.sp;
+
+ /* Push the prompt and exception handler onto the dynamic stack. */
+ scm_dynstack_push_prompt (dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
+ prompt_tag,
+ t->vm.stack_top - t->vm.fp,
+ saved_stack_depth,
+ t->vm.ip,
+ mra,
+ ®isters);
+ scm_dynstack_push_fluid (dynstack, exception_handler_fluid,
+ scm_cons (prompt_tag, type),
+ dynamic_state);
+
+ if (setjmp (registers))
+ {
+ /* A non-local return. */
+ SCM args;
+
+ t->vm.registers = prev_registers;
+ scm_gc_after_nonlocal_exit ();
+
+ /* FIXME: We know where the args will be on the stack; we could
+ avoid consing them. */
+ args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth);
+
+ /* The first abort arg is the continuation, which is #f. The
+ second and final arg is the exception. */
+ args = scm_cdr (args);
+ SCM exn = scm_car (args);
+ if (!scm_is_null (scm_cdr (args)))
+ abort ();
+ return handler (handler_data, exn);
+ }
+
+ SCM res = thunk (thunk_data);
+
+ scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+ scm_dynstack_pop (dynstack);
+
+ return res;
+}
+
+SCM
+scm_with_exception_handler (SCM type, SCM handler, SCM thunk)
+{
+ return scm_call_6 (scm_variable_ref (with_exception_handler_var),
+ handler, thunk, kw_unwind_p, SCM_BOOL_T,
+ kw_unwind_for_type, type);
+}
+
+SCM
+scm_with_pre_unwind_exception_handler (SCM handler, SCM thunk)
+{
+ return scm_call_2 (scm_variable_ref (with_exception_handler_var),
+ handler, thunk);
+}
+
+
+
+
+SCM_SYMBOL (sys_exception_sym, "%exception");
+
+/* Predicates, accessors, and constructors for exceptions. */
+
+static int
+is_guile_exception (SCM exn)
+{
+ return scm_is_pair (exn) && scm_is_symbol (scm_car (exn)) &&
+ scm_is_true (scm_list_p (scm_cdr (exn)));
+}
+
+SCM
+scm_exception_type (SCM exn)
+{
+ if (is_guile_exception (exn))
+ return scm_car (exn);
+ return sys_exception_sym;
+}
+
+SCM
+scm_exception_args (SCM exn)
+{
+ if (is_guile_exception (exn))
+ return scm_cdr (exn);
+ return scm_list_1 (exn);
+}
+
+static int
+exception_has_type (SCM exn, SCM type)
+{
+ return scm_is_eq (type, SCM_BOOL_T) ||
+ scm_is_eq (type, scm_exception_type (exn));
+}
+
+#if 0
+static SCM
+make_scm_exception (SCM type, SCM subr, SCM message, SCM args, SCM rest)
+{
+ return scm_list_5 (type, subr, message, args, rest);
+}
+#endif
+
+
+
+
+/* Default exception handlers. */
+
+/* Derive the an exit status from the arguments to (quit ...). */
+#if 0
+int
+scm_exit_status (SCM args)
+{
+ if (scm_is_pair (args))
+ {
+ SCM cqa = SCM_CAR (args);
+
+ if (scm_is_integer (cqa))
+ return scm_to_int (cqa);
+ else if (scm_is_false (cqa))
+ return EXIT_FAILURE;
+ else
+ return EXIT_SUCCESS;
+ }
+ else if (scm_is_null (args))
+ return EXIT_SUCCESS;
+ else
+ /* A type error. Strictly speaking we shouldn't get here. */
+ return EXIT_FAILURE;
+}
+#endif
+
+static int
+is_quit_exception (SCM exn)
+{
+ return exception_has_type (exn, scm_from_latin1_symbol ("quit"));
+}
+
+static int
+quit_exception_code (SCM exn)
+{
+ return scm_exit_status (scm_exception_args (exn));
+}
+
+static void
+scm_display_exception (SCM port, SCM exn)
+{
+ // FIXME: Make a good exception printer.
+ scm_puts ("key: ", port);
+ scm_write (scm_exception_type (exn), port);
+ scm_puts (", args: ", port);
+ scm_write (scm_exception_args (exn), port);
+ scm_newline (port);
+}
+
+static void
+default_exception_handler (SCM exn)
+{
+ static int error_printing_error = 0;
+ static int error_printing_fallback = 0;
+
+ if (error_printing_fallback)
+ fprintf (stderr, "\nFailed to print exception.\n");
+ else if (error_printing_error)
+ {
+ fprintf (stderr, "\nError while printing exception:\n");
+ error_printing_fallback = 1;
+ scm_write (exn, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ }
+ else if (is_quit_exception (exn))
+ exit (quit_exception_code (exn));
+ else
+ {
+ SCM port = scm_current_error_port ();
+ error_printing_error = 1;
+ scm_puts ("Uncaught exception:\n", port);
+ scm_display_exception (port, exn);
+ scm_i_pthread_exit (NULL);
+ }
+
+ /* We fall through here for the error-printing-error cases. */
+ fprintf (stderr, "Aborting.\n");
+ abort ();
+}
+
+static SCM
+default_exception_handler_wrapper (void *data, SCM exn)
+{
+ default_exception_handler (exn);
+ return SCM_UNDEFINED;
+}
+
+SCM
+scm_c_with_default_exception_handler (scm_t_thunk thunk, void *data)
+{
+ return scm_c_with_exception_handler (SCM_BOOL_T,
+ default_exception_handler_wrapper, NULL,
+ thunk, data);
+}
+
+
+
+
+/* An implementation of "raise" for use during boot and in
+ resource-exhaustion situations. */
+
+static SCM raise_var;
+
+static void
+emergency_raise (SCM exn, const char *reason)
+{
+ size_t depth = 0;
+
+ /* This function is not only the boot implementation of "raise", it is
+ also called in response to resource allocation failures such as
+ stack-overflow or out-of-memory. For that reason we need to be
+ careful to avoid allocating memory. */
+ while (1)
+ {
+ SCM eh = scm_fluid_ref_star (exception_handler_fluid,
+ scm_from_size_t (depth++));
+ if (scm_is_false (eh)) {
+ default_exception_handler (exn);
+ abort ();
+ }
+
+ if (!scm_is_pair (eh)) {
+ fprintf (stderr, "Warning: Unwind-only %s exception; "
+ "skipping pre-unwind handler.\n", reason);
+ } else {
+ SCM prompt_tag = scm_car (eh);
+ SCM type = scm_cdr (eh);
+ if (exception_has_type (exn, type)) {
+ SCM tag_and_exn[] = { prompt_tag, exn };
+ scm_i_vm_emergency_abort (tag_and_exn, 2);
+ /* Unreachable. */
+ abort ();
+ }
+ }
+ }
+}
+
+static SCM
+pre_boot_raise (SCM exn)
+{
+ emergency_raise (exn, "pre-boot");
+ return SCM_UNDEFINED;
+}
+
+SCM
+scm_raise_exception (SCM exn)
+{
+ scm_call_1 (scm_variable_ref (raise_var), exn);
+ /* Should not be reached. */
+ abort ();
+}
+
+
+
+
+#if 0
+
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
+SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
+
+static SCM stack_overflow_exn = SCM_BOOL_F;
+static SCM out_of_memory_exn = SCM_BOOL_F;
+
+/* Since these two functions may be called in response to resource
+ exhaustion, we have to avoid allocating memory. */
+
+void
+scm_report_stack_overflow (void)
+{
+ if (scm_is_false (stack_overflow_exn))
+ abort ();
+ emergency_raise (stack_overflow_exn, "stack overflow");
+
+ /* Not reached. */
+ abort ();
+}
+
+void
+scm_report_out_of_memory (void)
+{
+ if (scm_is_false (out_of_memory_exn))
+ abort ();
+ emergency_raise (out_of_memory_exn, "out of memory");
+
+ /* Not reached. */
+ abort ();
+}
+
+#endif
+
+
+
+/* Initialization. */
+
+void
+scm_init_exceptions ()
+{
+ tc16_thunk = scm_make_smob_type ("thunk", 0);
+ scm_set_smob_apply (tc16_thunk, call_thunk, 0, 0, 0);
+
+ tc16_exception_handler = scm_make_smob_type ("exception-handler", 0);
+ scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0);
+
+ exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+ /* This binding is later removed when the Scheme definitions of raise,
+ with-exception-handler, and with-pre-unwind-exception-handler are
+ created in boot-9.scm. */
+ scm_c_define ("%exception-handler2", exception_handler_fluid);
+
+ with_exception_handler_var =
+ scm_c_define ("with-exception-handler", SCM_BOOL_F);
+ raise_var =
+ scm_c_define ("raise-exception",
+ scm_c_make_gsubr ("raise-exception", 1, 0, 0,
+ (scm_t_subr) pre_boot_raise));
+
+#include "exceptions.x"
+
+#if 0
+ /* Arguments as if from:
+
+ scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
+
+ We build the arguments manually to avoid allocating memory in
+ emergency circumstances. */
+ stack_overflow_exn = make_scm_exception
+ (scm_stack_overflow_key, SCM_BOOL_F,
+ scm_from_latin1_string ("Stack overflow"), SCM_BOOL_F, SCM_BOOL_F);
+ out_of_memory_exn = make_scm_exception
+ (scm_out_of_memory_key, SCM_BOOL_F,
+ scm_from_latin1_string ("Out of memory"), SCM_BOOL_F, SCM_BOOL_F);
+#endif
+}
diff --git a/libguile/exceptions.h b/libguile/exceptions.h
new file mode 100644
index 0000000..68afae0
--- /dev/null
+++ b/libguile/exceptions.h
@@ -0,0 +1,65 @@
+#ifndef SCM_EXCEPTIONS_H
+#define SCM_EXCEPTIONS_H
+
+/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2019
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+
+
+#include "libguile/scm.h"
+
+
+
+typedef SCM (*scm_t_thunk) (void *data);
+typedef SCM (*scm_t_exception_handler) (void *data, SCM exn);
+
+SCM_INTERNAL SCM scm_c_make_thunk (scm_t_thunk body,
+ void *body_data);
+SCM_INTERNAL SCM scm_c_make_exception_handler (scm_t_exception_handler h,
+ void *handler_data);
+
+SCM_INTERNAL SCM scm_c_with_exception_handler (SCM type,
+ scm_t_exception_handler handler,
+ void *handler_data,
+ scm_t_thunk thunk,
+ void *thunk_data);
+
+SCM_INTERNAL SCM scm_c_with_default_exception_handler (scm_t_thunk thunk,
+ void *data);
+
+SCM_INTERNAL SCM scm_with_exception_handler (SCM type, SCM handler, SCM thunk);
+SCM_INTERNAL SCM scm_with_pre_unwind_exception_handler (SCM handler, SCM
thunk);
+SCM_INTERNAL SCM scm_raise_exception (SCM exn) SCM_NORETURN;
+
+SCM_INTERNAL SCM scm_exception_type (SCM exn);
+SCM_INTERNAL SCM scm_exception_args (SCM exn);
+
+#if 0
+/* This raises a `stack-overflow' exception, without running pre-unwind
+ handlers. */
+SCM_API void scm_report_stack_overflow (void);
+
+/* This raises an `out-of-memory' exception, without running pre-unwind
+ handlers. */
+SCM_API void scm_report_out_of_memory (void);
+#endif
+
+SCM_INTERNAL void scm_init_exceptions (void);
+
+#endif /* SCM_EXCEPTIONS_H */
diff --git a/libguile/init.c b/libguile/init.c
index e33a603..504c288 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -58,6 +58,7 @@
#include "error.h"
#include "eval.h"
#include "evalext.h"
+#include "exceptions.h"
#include "expand.h"
#include "extensions.h"
#include "fdes-finalizers.h"
@@ -489,6 +490,7 @@ scm_i_init_guile (void *base)
scm_init_strorder ();
scm_init_srfi_13 ();
scm_init_srfi_14 (); /* Requires smob_prehistory */
+ scm_init_exceptions ();
scm_init_throw (); /* Requires smob_prehistory */
scm_init_trees ();
scm_init_version ();
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index cbe8b5e..4b06b47 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -719,6 +719,141 @@ information is unavailable."
(define (abort-to-prompt tag . args)
(abort-to-prompt* tag args))
+(define (make-guile-exception key args)
+ (unless (symbol? key)
+ (throw 'wrong-type-arg "make-guile-exception"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 key) (list key)))
+ (cons key args))
+(define (guile-exception? exn)
+ (and (pair? exn)
+ (symbol? (car exn))
+ (list? (cdr exn))))
+(define (%guile-exception-key exn) (car exn))
+(define (%guile-exception-args exn) (cdr exn))
+
+(define (guile-exception-key exn)
+ (if (guile-exception? exn)
+ (%guile-exception-key exn)
+ '%exception))
+
+(define (guile-exception-args exn)
+ (if (guile-exception? exn)
+ (%guile-exception-args exn)
+ (list exn)))
+
+(define (quit-exception? exn)
+ (and (pair? exn) (eq? (car exn) 'quit)))
+(define (quit-exception-code exn)
+ (let ((args (cdr exn)))
+ (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+
+(define raise-continuable #f)
+(let ((%eh (module-ref (current-module) '%exception-handler2)))
+ (define (exception-type? x) #f)
+ (define (exception? x) (not (guile-exception? x)))
+ (define (exception-type-predicate type) (lambda (x) #f))
+
+ (define (fallback-exception-handler exn)
+ (cond
+ ((quit-exception? exn)
+ (primitive-exit (quit-exception-code exn)))
+ (else
+ (display "guile: uncaught exception:\n" (current-error-port))
+ (print-exception (current-error-port) #f
+ (guile-exception-key exn) (guile-exception-args exn))
+ (primitive-exit 1))))
+
+ (define %dynamic-handlers (make-thread-local-fluid))
+
+ (define (%raise exn continuable?)
+ (define (capture-current-exception-handlers)
+ ;; FIXME: This is quadratic.
+ (let lp ((depth 0))
+ (let ((h (fluid-ref* %eh depth)))
+ (if h
+ (cons h (lp (1+ depth)))
+ (list fallback-exception-handler)))))
+ (define (exception-has-type? exn type)
+ (cond
+ ((eq? type #t)
+ #t)
+ ((symbol? type)
+ (eq? (guile-exception-key exn) type))
+ ((exception-type? type)
+ (and (exception? exn)
+ ((exception-type-predicate type) exn)))
+ (else #f)))
+ (let lp ((handlers (or (fluid-ref %dynamic-handlers)
+ (capture-current-exception-handlers))))
+ (let ((handler (car handlers))
+ (handlers (cdr handlers)))
+ ;; There are two kinds of exception handlers: unwinding handlers
+ ;; and pre-unwind handlers. Although you can implement unwinding
+ ;; handlers with pre-unwind handlers, it's better to separate them
+ ;; because it allows for emergency situations like "stack
+ ;; overflow" or "out of memory" to unwind the stack before calling
+ ;; a handler.
+ (cond
+ ((pair? handler)
+ (let ((prompt-tag (car handler))
+ (type (cdr handler)))
+ (cond
+ ((exception-has-type? exn type)
+ (abort-to-prompt prompt-tag exn)
+ (error "unreachable"))
+ (else
+ (lp handlers)))))
+ (else
+ (with-fluids ((%dynamic-handlers handlers))
+ (cond
+ (continuable?
+ (handler exn))
+ (else
+ (handler exn)
+ (error "this should be a not-continuable error")))))))))
+
+ (define (raise-continuable exn)
+ (%raise exn #t))
+
+ (define (raise-exception exn)
+ (%raise exn #f))
+
+ (define* (with-exception-handler handler thunk #:key (unwind? #f)
+ (unwind-for-type #t))
+ (unless (procedure? handler)
+ (scm-error 'wrong-type-arg "with-exception-handler"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 handler) (list handler)))
+ (cond
+ (unwind?
+ (unless (or (eq? unwind-for-type #t)
+ (symbol? unwind-for-type)
+ (exception-type? unwind-for-type))
+ (scm-error 'wrong-type-arg "with-exception-handler"
+ "Wrong type argument for #:unwind-for-type: ~a"
+ (list unwind-for-type) (list unwind-for-type)))
+ (let ((tag (make-prompt-tag "exception handler")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluids ((%eh (cons tag unwind-for-type)))
+ (thunk)))
+ (lambda (k exn)
+ (handler exn)))))
+ (else
+ (with-fluids ((%eh handler))
+ (thunk)))))
+
+ (hashq-remove! (%get-pre-modules-obarray) '%exception-handler2)
+ (define! 'raise-exception raise-exception)
+ (define! 'raise-continuable raise-continuable)
+ (define! 'with-exception-handler with-exception-handler))
+
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.