guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 07/07: rebase throw/catch on top of raise-exception/with


From: Andy Wingo
Subject: [Guile-commits] 07/07: rebase throw/catch on top of raise-exception/with-exception-handler
Date: Fri, 8 Nov 2019 09:31:57 -0500 (EST)

wingo pushed a commit to branch wip-exceptions
in repository guile.

commit b31c94dc78a2c8bf506af07c9ab9e2ac6014c0dd
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 8 15:31:00 2019 +0100

    rebase throw/catch on top of raise-exception/with-exception-handler
---
 libguile.h                  |   1 +
 libguile/Makefile.am        |   4 +
 libguile/exceptions.c       | 509 +++++++++++++++++++++++++++++++++++++++++++
 libguile/exceptions.h       |  63 ++++++
 libguile/init.c             |   2 +
 libguile/threads.c          |   4 +-
 libguile/throw.c            | 519 ++++++++++++--------------------------------
 libguile/throw.h            |  18 +-
 module/ice-9/boot-9.scm     | 313 +++++++++++++++++---------
 module/ice-9/exceptions.scm |  88 ++------
 10 files changed, 949 insertions(+), 572 deletions(-)

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..d12302c
--- /dev/null
+++ b/libguile/exceptions.c
@@ -0,0 +1,509 @@
+/* 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;
+static SCM raise_exception_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,
+                            &registers);
+  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");
+/* Note that these record types are marked as non-extensible, so their
+   type predicate is a simple vtable comparison.  */
+static SCM compound_exception;
+static SCM exception_with_kind_and_args;
+static SCM quit_exception;
+
+static SCM
+extract_exception (SCM obj, SCM non_extensible_vtable)
+{
+  if (!SCM_STRUCTP (obj)) {
+    return SCM_BOOL_F;
+  }
+  if (scm_is_eq (SCM_STRUCT_VTABLE (obj), non_extensible_vtable)) {
+    return obj;
+  }
+  if (scm_is_eq (SCM_STRUCT_VTABLE (obj), compound_exception)) {
+    return SCM_BOOL_F;
+  }
+
+  SCM exns = SCM_STRUCT_SLOT_REF (obj, 0);
+  while (!scm_is_null (exns)) {
+    SCM exn = scm_car (exns);
+    if (scm_is_eq (SCM_STRUCT_VTABLE (exn), non_extensible_vtable)) {
+      return exn;
+    }
+    exns = scm_cdr (exns);
+  }
+  return SCM_BOOL_F;
+}
+
+SCM
+scm_exception_kind (SCM obj)
+{
+  SCM exn = extract_exception (obj, exception_with_kind_and_args);
+  if (scm_is_false (exn)) {
+    return sys_exception_sym;
+  }
+  return SCM_STRUCT_SLOT_REF (exn, 0);
+}
+
+SCM
+scm_exception_args (SCM obj)
+{
+  SCM exn = extract_exception (obj, exception_with_kind_and_args);
+  if (scm_is_false (exn)) {
+    return scm_list_1 (obj);
+  }
+  return SCM_STRUCT_SLOT_REF (exn, 1);
+}
+
+static int
+exception_has_type (SCM exn, SCM type)
+{
+  return scm_is_eq (type, SCM_BOOL_T) ||
+    scm_is_eq (type, scm_exception_kind (exn));
+}
+
+
+
+
+/* Default exception handlers.  */
+
+/* Derive the an exit status from the arguments to (quit ...).  */
+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;
+}
+
+static SCM
+get_quit_exception (SCM obj)
+{
+  return extract_exception (obj, quit_exception);
+}
+
+static int
+quit_exception_code (SCM exn)
+{
+  return scm_to_int (SCM_STRUCT_SLOT_REF (exn, 0));
+}
+
+static void
+scm_display_exception (SCM port, SCM exn)
+{
+  // FIXME: Make a good exception printer.
+  scm_puts ("key: ", port);
+  scm_write (scm_exception_kind (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 (scm_is_true (get_quit_exception (exn)))
+    {
+      exit (quit_exception_code (get_quit_exception (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 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_exception_var), exn);
+  /* Should not be reached.  */
+  abort ();
+}
+
+
+
+
+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 ();
+}
+
+static SCM
+make_scm_exception (SCM type, SCM subr, SCM message, SCM args, SCM rest)
+{
+  return scm_make_struct_simple
+    (exception_with_kind_and_args,
+     scm_list_2 (type,
+                 scm_list_4 (subr, message, args, rest)));
+}
+
+static SCM
+sys_init_exceptions_x (SCM compound_exception_type,
+                       SCM exception_with_kind_and_args_type,
+                       SCM quit_exception_type)
+{
+  compound_exception = compound_exception_type;
+  exception_with_kind_and_args = exception_with_kind_and_args_type;
+  quit_exception = quit_exception_type;
+
+
+  /* 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);
+
+  return SCM_UNDEFINED;
+}
+
+
+
+
+/* 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-handler", exception_handler_fluid);
+
+  with_exception_handler_var =
+    scm_c_define ("with-exception-handler", SCM_BOOL_F);
+  raise_exception_var =
+    scm_c_define ("raise-exception",
+                  scm_c_make_gsubr ("raise-exception", 1, 0, 0,
+                                    (scm_t_subr) pre_boot_raise));
+
+  scm_c_define ("%init-exceptions!",
+                scm_c_make_gsubr ("%init-exceptions!", 3, 0, 0,
+                                  (scm_t_subr) sys_init_exceptions_x));
+
+#include "exceptions.x"
+}
diff --git a/libguile/exceptions.h b/libguile/exceptions.h
new file mode 100644
index 0000000..eaf8964
--- /dev/null
+++ b/libguile/exceptions.h
@@ -0,0 +1,63 @@
+#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_kind (SCM exn);
+SCM_INTERNAL SCM scm_exception_args (SCM exn);
+
+/* 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);
+
+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/libguile/threads.c b/libguile/threads.c
index 86ac5e8..280d306 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -821,9 +821,9 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
 {
   SCM body_closure, handler_closure;
 
-  body_closure = scm_i_make_catch_body_closure (body, body_data);
+  body_closure = scm_c_make_thunk (body, body_data);
   handler_closure = handler == NULL ? SCM_UNDEFINED :
-    scm_i_make_catch_handler_closure (handler, handler_data);
+    scm_i_make_catch_handler (handler, handler_data);
 
   return scm_call_with_new_thread (body_closure, handler_closure);
 }
diff --git a/libguile/throw.c b/libguile/throw.c
index 055ad87..41c7798 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -34,7 +34,7 @@
 #include "deprecation.h"
 #include "eq.h"
 #include "eval.h"
-#include "fluids.h"
+#include "exceptions.h"
 #include "gsubr.h"
 #include "init.h"
 #include "list.h"
@@ -54,278 +54,13 @@
 #include "throw.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 throw unwind-only exceptions from C,
-   for example so that we can recover from stack overflow.  We also need
-   to have an implementation of catch and throw handy before boot time.
-   For that reason we have a parallel implementation of "catch" that
-   uses the same fluids here.  Throws from C still call out to Scheme
-   though, so that pre-unwind handlers can be run.  Getting the dynamic
-   environment right for pre-unwind handlers is tricky, and it's
-   important to have all of the implementation in one place.
-
-   All of these function names and prototypes carry a fair bit of historical
-   baggage. */
-
-
 
 
 static SCM throw_var;
 
-static SCM exception_handler_fluid;
-
-static SCM
-catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
-{
-  SCM eh, prompt_tag;
-  SCM res;
-  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;
-
-  if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
-    scm_wrong_type_arg ("catch", 1, tag);
-
-  if (SCM_UNBNDP (handler))
-    handler = SCM_BOOL_F;
-  else if (!scm_is_true (scm_procedure_p (handler)))
-    scm_wrong_type_arg ("catch", 3, handler);
-
-  if (SCM_UNBNDP (pre_unwind_handler))
-    pre_unwind_handler = SCM_BOOL_F;
-  else if (!scm_is_true (scm_procedure_p (pre_unwind_handler)))
-    scm_wrong_type_arg ("catch", 4, pre_unwind_handler);
-
-  prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
-
-  eh = scm_c_make_vector (3, SCM_BOOL_F);
-  scm_c_vector_set_x (eh, 0, tag);
-  scm_c_vector_set_x (eh, 1, prompt_tag);
-  scm_c_vector_set_x (eh, 2, pre_unwind_handler);
-
-  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,
-                            &registers);
-  scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
-                           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);
-
-      /* Cdr past the continuation. */
-      args = scm_cdr (args);
-
-      return scm_apply_0 (handler, args);
-    }
-
-  res = scm_call_0 (thunk);
-
-  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
-  scm_dynstack_pop (dynstack);
-
-  return res;
-}
-
-static void
-default_exception_handler (SCM k, SCM args)
-{
-  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;
-      fprintf (stderr, "Key: ");
-      scm_write (k, scm_current_error_port ());
-      fprintf (stderr, ", args: ");
-      scm_write (args, scm_current_error_port ());
-      scm_newline (scm_current_error_port ());
-   }
-  else
-    {
-      fprintf (stderr, "Uncaught exception:\n");
-      error_printing_error = 1;
-      scm_handle_by_message (NULL, k, args);
-    }
-
-  /* Normally we don't get here, because scm_handle_by_message will
-     exit.  */
-  fprintf (stderr, "Aborting.\n");
-  abort ();
-}
-
-/* A version of scm_abort_to_prompt_star that avoids the need to cons
-   "tag" to "args", because we might be out of memory.  */
-static void
-abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
-{
-  SCM *tag_and_argv;
-  size_t i;
-  long n;
-
-  n = scm_ilength (args) + 2;
-  tag_and_argv = alloca (sizeof (SCM)*n);
-  tag_and_argv[0] = prompt_tag;
-  tag_and_argv[1] = tag;
-  for (i = 2; i < n; i++, args = scm_cdr (args))
-    tag_and_argv[i] = scm_car (args);
-
-  scm_i_vm_emergency_abort (tag_and_argv, n);
-  /* Unreachable.  */
-  abort ();
-}
-
-static SCM
-throw_without_pre_unwind (SCM tag, SCM args)
-{
-  size_t depth = 0;
-
-  /* This function is not only the boot implementation of "throw", 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, catch_key, prompt_tag;
-
-      eh = scm_fluid_ref_star (exception_handler_fluid,
-                               scm_from_size_t (depth++));
-      if (scm_is_false (eh))
-        break;
-
-      catch_key = scm_c_vector_ref (eh, 0);
-      if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
-        continue;
-
-      if (scm_is_true (scm_c_vector_ref (eh, 2)))
-        {
-          const char *key_chars;
-
-          if (scm_i_is_narrow_symbol (tag))
-            key_chars = scm_i_symbol_chars (tag);
-          else
-            key_chars = "(wide symbol)";
-
-          fprintf (stderr, "Warning: Unwind-only `%s' exception; "
-                   "skipping pre-unwind handler.\n", key_chars);
-        }
-
-      prompt_tag = scm_c_vector_ref (eh, 1);
-      if (scm_is_true (prompt_tag))
-        abort_to_prompt (prompt_tag, tag, args);
-    }
-
-  default_exception_handler (tag, args);
-  return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_catch (SCM key, SCM thunk, SCM handler)
-{
-  return catch (key, thunk, handler, SCM_UNDEFINED);
-}
-
-SCM
-scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
-                                   SCM pre_unwind_handler)
-{
-  return catch (key, thunk, handler, pre_unwind_handler);
-}
-
-SCM
-scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
-{
-  return catch (key, thunk, SCM_UNDEFINED, handler);
-}
-
-SCM
-scm_throw (SCM key, SCM args)
-{
-  scm_apply_1 (scm_variable_ref (throw_var), key, args);
-  /* Should not be reached.  */
-  abort ();
-}
 
 
 
-/* Now some support for C bodies and catch handlers */
-
-static scm_t_bits tc16_catch_closure;
-
-enum {
-  CATCH_CLOSURE_BODY,
-  CATCH_CLOSURE_HANDLER
-};
-
-SCM
-scm_i_make_catch_body_closure (scm_t_catch_body body, void *body_data)
-{
-  SCM ret;
-  SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
-  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
-  return ret;
-}
-
-SCM
-scm_i_make_catch_handler_closure (scm_t_catch_handler handler,
-                                  void *handler_data)
-{
-  SCM ret;
-  SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
-  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
-  return ret;
-}
-
-static SCM
-apply_catch_closure (SCM clo, SCM args)
-{
-  void *data = (void*)SCM_SMOB_DATA_2 (clo);
-
-  switch (SCM_SMOB_FLAGS (clo))
-    {
-    case CATCH_CLOSURE_BODY:
-      {
-        scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
-        return body (data);
-      }
-    case CATCH_CLOSURE_HANDLER:
-      {
-        scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
-        return handler (data, scm_car (args), scm_cdr (args));
-      }
-    default:
-      abort ();
-    }
-}
-
 /* TAG is the catch tag.  Typically, this is a symbol, but this
    function doesn't actually care about that.
 
@@ -365,30 +100,71 @@ apply_catch_closure (SCM clo, SCM args)
    references anyway, this assures that any references in MUMBLE_DATA
    will be found.  */
 
+struct scm_catch_data
+{
+  SCM tag;
+  scm_t_thunk body;
+  void *body_data;
+  scm_t_catch_handler handler;
+  void *handler_data;
+  scm_t_catch_handler pre_unwind_handler;
+  void *pre_unwind_handler_data;
+};
+
+static SCM
+catch_post_unwind_handler (void *data, SCM exn)
+{
+  struct scm_catch_data *catch_data = data;
+  return catch_data->handler (catch_data->handler_data,
+                              scm_exception_kind (exn),
+                              scm_exception_args (exn));
+}
+
+static SCM
+catch_pre_unwind_handler (void *data, SCM exn)
+{
+  struct scm_catch_data *catch_data = data;
+  SCM kind = scm_exception_kind (exn);
+  SCM args = scm_exception_args (exn);
+  if (scm_is_eq (catch_data->tag, SCM_BOOL_T)
+      || scm_is_eq (kind, catch_data->tag)) {
+    catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data,
+                                    kind, args);
+  }
+  return scm_raise_exception (exn);
+}
+
+static SCM
+catch_body (void *data)
+{
+  struct scm_catch_data *catch_data = data;
+
+  if (catch_data->pre_unwind_handler) {
+    SCM thunk = scm_c_make_thunk (catch_data->body, catch_data->body_data);
+    SCM handler = scm_c_make_exception_handler (catch_pre_unwind_handler, 
data);
+    return scm_with_pre_unwind_exception_handler (handler, thunk);
+  }
+
+  return catch_data->body (catch_data->body_data);
+}
+
 SCM
 scm_c_catch (SCM tag,
-            scm_t_catch_body body, void *body_data,
+            scm_t_thunk body, void *body_data,
             scm_t_catch_handler handler, void *handler_data,
             scm_t_catch_handler pre_unwind_handler, void 
*pre_unwind_handler_data)
 {
-  SCM sbody, shandler, spre_unwind_handler;
-  
-  sbody = scm_i_make_catch_body_closure (body, body_data);
-  shandler = scm_i_make_catch_handler_closure (handler, handler_data);
-  if (pre_unwind_handler)
-    spre_unwind_handler =
-      scm_i_make_catch_handler_closure (pre_unwind_handler,
-                                        pre_unwind_handler_data);
-  else
-    spre_unwind_handler = SCM_UNDEFINED;
-  
-  return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
-                                            spre_unwind_handler);
+  struct scm_catch_data data =
+    { tag, body, body_data, handler, handler_data, pre_unwind_handler,
+      pre_unwind_handler_data };
+
+  return scm_c_with_exception_handler (tag, catch_post_unwind_handler, &data,
+                                       catch_body, &data);
 }
 
 SCM
 scm_internal_catch (SCM tag,
-                   scm_t_catch_body body, void *body_data,
+                   scm_t_thunk body, void *body_data,
                    scm_t_catch_handler handler, void *handler_data)
 {
   return scm_c_catch (tag,
@@ -400,28 +176,96 @@ scm_internal_catch (SCM tag,
 
 SCM
 scm_c_with_throw_handler (SCM tag,
-                         scm_t_catch_body body,
+                         scm_t_thunk body,
                          void *body_data,
                          scm_t_catch_handler handler,
                          void *handler_data,
                          int lazy_catch_p)
 {
-  SCM sbody, shandler;
+  struct scm_catch_data data =
+    { tag, body, body_data, NULL, NULL, handler, handler_data };
 
   if (lazy_catch_p)
-    scm_c_issue_deprecation_warning
-      ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no 
longer.\n"
-       "supported. Instead the handler will be invoked from within the 
dynamic\n"
-       "context of the corresponding `throw'.\n"
-       "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
-       "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
-       "and adapt it (if necessary) to expect to be within the dynamic 
context\n"
-       "of the throw.");
-
-  sbody = scm_i_make_catch_body_closure (body, body_data);
-  shandler = scm_i_make_catch_handler_closure (handler, handler_data);
-  
-  return scm_with_throw_handler (tag, sbody, shandler);
+    /* Non-zero lazy_catch_p arguments have been deprecated since
+       2010.  */
+    abort ();
+
+  return catch_body (&data);
+}
+
+static SCM
+call_thunk (void* data)
+{
+  return scm_call_0 (PTR2SCM (data));
+}
+
+static SCM
+call_handler (void* data, SCM a, SCM b)
+{
+  return scm_call_2 (PTR2SCM (data), a, b);
+}
+
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+  return scm_c_catch (key, call_thunk, SCM2PTR (thunk),
+                      call_handler, SCM2PTR (handler), NULL, NULL);
+}
+
+SCM
+scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
+                                   SCM pre_unwind_handler)
+{
+  if (SCM_UNBNDP (pre_unwind_handler))
+    return scm_catch (key, thunk, handler);
+
+  return scm_c_catch (key, call_thunk, SCM2PTR (thunk),
+                      call_handler, SCM2PTR (handler),
+                      call_handler, SCM2PTR (pre_unwind_handler));
+}
+
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+{
+  return scm_c_with_throw_handler (key, call_thunk, SCM2PTR (thunk),
+                                   call_handler, SCM2PTR (handler), 0);
+}
+
+SCM
+scm_throw (SCM key, SCM args)
+{
+  SCM throw = scm_variable_ref (throw_var);
+  if (scm_is_false (throw)) {
+    SCM port = scm_current_error_port ();
+    scm_puts ("Pre-boot error; key: ", port);
+    scm_write (key, port);
+    scm_puts (", args: ", port);
+    scm_write (args, port);
+    abort ();
+  }
+  scm_apply_1 (throw, key, args);
+  /* Should not be reached.  */
+  abort ();
+}
+
+
+
+/* Now some support for C bodies and catch handlers */
+
+static scm_t_bits tc16_catch_handler;
+
+SCM
+scm_i_make_catch_handler (scm_t_catch_handler handler, void *data)
+{
+  SCM_RETURN_NEWSMOB2 (tc16_catch_handler, handler, data);
+}
+
+static SCM
+apply_catch_handler (SCM clo, SCM args)
+{
+  scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
+  void *data = (void*)SCM_SMOB_DATA_2 (clo);
+  return handler (data, scm_car (args), scm_cdr (args));
 }
 
 
@@ -490,28 +334,6 @@ scm_handle_by_proc_catching_all (void *handler_data, SCM 
tag, SCM throw_args)
                             scm_handle_by_message_noexit, NULL);
 }
 
-/* Derive the an exit status from the arguments to (quit ...).  */
-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;
-}
-       
 
 static int
 should_print_backtrace (SCM tag, SCM stack)
@@ -619,66 +441,13 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
   scm_throw (key, args);
 }
 
-SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
-
-static SCM stack_overflow_args = SCM_BOOL_F;
-static SCM out_of_memory_args = 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_args))
-    abort ();
-  throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
-
-  /* Not reached.  */
-  abort ();
-}
-
-void
-scm_report_out_of_memory (void)
-{
-  if (scm_is_false (out_of_memory_args))
-    abort ();
-  throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args);
-
-  /* Not reached.  */
-  abort ();
-}
-
 void
 scm_init_throw ()
 {
-  tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
-  scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
-
-  exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
-  /* This binding is later removed when the Scheme definitions of catch,
-     throw, and with-throw-handler are created in boot-9.scm.  */
-  scm_c_define ("%exception-handler", exception_handler_fluid);
-
-  throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
-                                                       
throw_without_pre_unwind));
-
-  /* Arguments as if from:
-
-       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
-
-     We build the arguments manually because we throw without running
-     pre-unwind handlers.  (Pre-unwind handlers could rewind the
-     stack.)  */
-  stack_overflow_args = scm_list_4 (SCM_BOOL_F,
-                                    scm_from_latin1_string ("Stack overflow"),
-                                    SCM_BOOL_F,
-                                    SCM_BOOL_F);
-  out_of_memory_args = scm_list_4 (SCM_BOOL_F,
-                                   scm_from_latin1_string ("Out of memory"),
-                                   SCM_BOOL_F,
-                                   SCM_BOOL_F);
+  tc16_catch_handler = scm_make_smob_type ("catch-handler", 0);
+  scm_set_smob_apply (tc16_catch_handler, apply_catch_handler, 0, 0, 1);
+
+  throw_var = scm_c_define ("throw", SCM_BOOL_F);
 
 #include "throw.x"
 }
diff --git a/libguile/throw.h b/libguile/throw.h
index ea206f9..de41276 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -1,7 +1,7 @@
 #ifndef SCM_THROW_H
 #define SCM_THROW_H
 
-/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2018
+/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2019
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -23,17 +23,15 @@
 
 
 #include "libguile/scm.h"
+#include "libguile/exceptions.h"
 
 
 
-typedef SCM (*scm_t_catch_body) (void *data);
+typedef scm_t_thunk scm_t_catch_body;
 typedef SCM (*scm_t_catch_handler) (void *data,
                                     SCM tag, SCM throw_args);
 
-SCM_INTERNAL SCM scm_i_make_catch_body_closure (scm_t_catch_body body,
-                                                void *body_data);
-SCM_INTERNAL SCM scm_i_make_catch_handler_closure (scm_t_catch_handler h,
-                                                   void *handler_data);
+SCM_INTERNAL SCM scm_i_make_catch_handler (scm_t_catch_handler h, void *data);
 
 SCM_API SCM scm_c_catch (SCM tag,
                         scm_t_catch_body body,
@@ -85,14 +83,6 @@ SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return) SCM_NORETURN;
 
-/* This throws to the `stack-overflow' key, without running pre-unwind
-   handlers.  */
-SCM_API void scm_report_stack_overflow (void);
-
-/* This throws to the `out-of-memory' key, without running pre-unwind
-   handlers.  */
-SCM_API void scm_report_out_of_memory (void);
-
 SCM_API SCM scm_throw (SCM key, SCM args) SCM_NORETURN;
 SCM_INTERNAL void scm_init_throw (void);
 
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 7f7ad93..057199d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1399,6 +1399,9 @@ written into the port is returned."
 
 
 
+;;; {Exceptions}
+;;;
+
 (let-syntax ((define-values* (syntax-rules ()
                                ((_ (id ...) body ...)
                                 (define-values (id ...)
@@ -1490,89 +1493,195 @@ exception composed of such an instance."
                          obj rtd))
                 (if (rtd-predicate (car exceptions))
                     (proc (car exceptions))
-                    (lp (cdr exceptions))))))))))
-
-(define &exception-with-key-and-args
-  (make-exception-type '&exception-with-key-and-args &exception '(key args)))
-(define &quit-exception
-  (make-exception-type '&quit-exception &exception '(code)))
-
-
-
-;; Define catch and with-throw-handler, using some common helper routines and a
-;; shared fluid. Hide the helpers in a lexical contour.
-
-(define with-throw-handler #f)
-(let ((%eh (module-ref (current-module) '%exception-handler)))
-  (define (make-exception-handler catch-key prompt-tag pre-unwind)
-    (vector catch-key prompt-tag pre-unwind))
-  (define (exception-handler-catch-key handler) (vector-ref handler 0))
-  (define (exception-handler-prompt-tag handler) (vector-ref handler 1))
-  (define (exception-handler-pre-unwind handler) (vector-ref handler 2))
-
-  (define %running-pre-unwind (make-fluid #f))
-  (define (pre-unwind-handler-running? handler)
-    (let lp ((depth 0))
-      (let ((running (fluid-ref* %running-pre-unwind depth)))
-        (and running
-             (or (eq? running handler) (lp (1+ depth)))))))
-
-  (define (dispatch-exception depth key args)
-    (cond
-     ((fluid-ref* %eh depth)
-      => (lambda (handler)
-           (let ((catch-key (exception-handler-catch-key handler)))
-             (if (or (eqv? catch-key #t) (eq? catch-key key))
-                 (let ((prompt-tag (exception-handler-prompt-tag handler))
-                       (pre-unwind (exception-handler-pre-unwind handler)))
-                   (cond
-                    ((and pre-unwind
-                          (not (pre-unwind-handler-running? handler)))
-                     ;; Prevent errors from within the pre-unwind
-                     ;; handler's invocation from being handled by this
-                     ;; handler.
-                     (with-fluid* %running-pre-unwind handler
-                       (lambda ()
-                         ;; FIXME: Currently the "running" flag only
-                         ;; applies to the pre-unwind handler; the
-                         ;; post-unwind handler is still called if the
-                         ;; error is explicitly rethrown.  Instead it
-                         ;; would be better to cause a recursive throw to
-                         ;; skip all parts of this handler.  Unfortunately
-                         ;; that is incompatible with existing semantics.
-                         ;; We'll see if we can change that later on.
-                         (apply pre-unwind key args)
-                         (dispatch-exception depth key args))))
-                    (prompt-tag
-                     (apply abort-to-prompt prompt-tag key args))
-                    (else
-                     (dispatch-exception (1+ depth) key args))))
-                 (dispatch-exception (1+ depth) key args)))))
-     ((eq? key 'quit)
-      (primitive-exit (cond
-                       ((not (pair? args)) 0)
-                       ((integer? (car args)) (car args))
-                       ((not (car args)) 1)
-                       (else 0))))
-     (else
-      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
-              key args)
-      (primitive-exit 1))))
-
-  (define (throw key . args)
-    "Invoke the catch form matching @var{key}, passing @var{args} to the
+                    (lp (cdr exceptions)))))))))
+
+  ;; Exceptionally, these exception types are built with
+  ;; make-record-type, in order to be able to mark them as sealed.  This
+  ;; allows boot definitions of
+  (define &exception-with-kind-and-args
+    (make-record-type '&exception-with-kind-and-args
+                      '((immutable kind) (immutable args))
+                      #:parent &exception #:extensible? #f))
+  (define &quit-exception
+    (make-record-type '&quit-exception
+                      '((immutable code))
+                      #:parent &exception #:extensible? #f))
+
+  ;; Boot definition; overridden later.
+  (define-values* (make-exception-from-throw)
+    (define make-exception-with-kind-and-args
+      (record-constructor &exception-with-kind-and-args))
+    (define make-quit-exception
+      (record-constructor &quit-exception))
+
+    (define (make-exception-from-throw key args)
+      (let ((exn (make-exception-with-kind-and-args key args)))
+        (case key
+          ((quit)
+           (let ((code (cond
+                        ((not (pair? args)) 0)
+                        ((integer? (car args)) (car args))
+                        ((not (car args)) 1)
+                        (else 0))))
+             (make-exception (make-quit-exception code)
+                             exn)))
+          (else
+           exn)))))
+
+  (define-values* (raise-exception
+                   with-exception-handler
+                   catch
+                   with-throw-handler
+                   throw)
+    (define (steal-binding! sym)
+      (let ((val (module-ref (current-module) sym)))
+        (hashq-remove! (%get-pre-modules-obarray) sym)
+        val))
+
+    (define %exception-handler (steal-binding! '%exception-handler))
+    (define %init-exceptions! (steal-binding! '%init-exceptions!))
+
+    (%init-exceptions! &compound-exception
+                       &exception-with-kind-and-args
+                       &quit-exception)
+
+    (define exception-with-kind-and-args?
+      (exception-predicate &exception-with-kind-and-args))
+    (define %exception-kind
+      (exception-accessor &exception-with-kind-and-args
+                          (record-accessor &exception-with-kind-and-args 
'kind)))
+    (define %exception-args
+      (exception-accessor &exception-with-kind-and-args
+                          (record-accessor &exception-with-kind-and-args 
'args)))
+
+    (define (exception-kind obj)
+      (if (exception-with-kind-and-args? obj)
+          (%exception-kind obj)
+          '%exception))
+    (define (exception-args obj)
+      (if (exception-with-kind-and-args? obj)
+          (%exception-args obj)
+          (list obj)))
+
+    (define quit-exception?
+      (exception-predicate &quit-exception))
+    (define quit-exception-code
+      (exception-accessor &quit-exception
+                          (record-accessor &quit-exception 'code)))
+
+    (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
+                         (exception-kind exn) (exception-args exn))
+        (primitive-exit 1))))
+
+    (define %dynamic-handlers (make-thread-local-fluid))
+
+    (define* (raise-exception exn #:key (continuable? #f))
+      (define (capture-current-exception-handlers)
+        ;; FIXME: This is quadratic.
+        (let lp ((depth 0))
+          (let ((h (fluid-ref* %exception-handler 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? (exception-kind exn) type))
+         ((exception-type? type)
+          (and (exception? exn)
+               ((exception-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 types 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* (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 ((%exception-handler (cons tag unwind-for-type)))
+               (thunk)))
+           (lambda (k exn)
+             (handler exn)))))
+       (else
+        (with-fluids ((%exception-handler handler))
+          (thunk)))))
+
+    (define (throw key . args)
+      "Invoke the catch form matching @var{key}, passing @var{args} to the
 @var{handler}.
 
 @var{key} is a symbol. It will match catches of the same symbol or of 
@code{#t}.
 
 If there is no handler at all, Guile prints an error and then exits."
-    (unless (symbol? key)
-      (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
-             (list 1 key) (list key)))
-    (dispatch-exception 0 key args))
+      (unless (symbol? key)
+        (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
+               (list 1 key) (list key)))
+      (raise-exception (make-exception-from-throw key args)))
 
-  (define* (catch k thunk handler #:optional pre-unwind-handler)
-    "Invoke @var{thunk} in the dynamic context of @var{handler} for
+    (define (with-throw-handler k thunk pre-unwind-handler)
+      "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+      (unless (or (symbol? k) (eq? k #t))
+        (scm-error 'wrong-type-arg "with-throw-handler"
+                   "Wrong type argument in position ~a: ~a"
+                   (list 1 k) (list k)))
+      (with-exception-handler
+       (lambda (exn)
+         (when (or (eq? k #t) (eq? k (exception-kind exn)))
+           (apply pre-unwind-handler (exception-kind exn) (exception-args 
exn)))
+         (raise-exception exn))
+       thunk))
+
+    (define* (catch k thunk handler #:optional pre-unwind-handler)
+      "Invoke @var{thunk} in the dynamic context of @var{handler} for
 exceptions matching @var{key}.  If thunk throws to the symbol
 @var{key}, then @var{handler} is invoked this way:
 @lisp
@@ -1605,39 +1714,27 @@ A @var{pre-unwind-handler} can exit either normally or 
non-locally.
 If it exits normally, Guile unwinds the stack and dynamic context
 and then calls the normal (third argument) handler.  If it exits
 non-locally, that exit determines the continuation."
-    (define (wrong-type-arg n val)
-      (scm-error 'wrong-type-arg "catch"
-                 "Wrong type argument in position ~a: ~a"
-                 (list n val) (list val)))
-    (unless (or (symbol? k) (eqv? k #t))
-      (wrong-type-arg 1 k))
-    (unless (procedure? handler)
-      (wrong-type-arg 3 handler))
-    (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
-      (wrong-type-arg 4 pre-unwind-handler))
-    (let ((tag (make-prompt-tag "catch")))
-      (call-with-prompt
-       tag
-       (lambda ()
-         (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
-           thunk))
-       (lambda (cont k . args)
-         (apply handler k args)))))
-
-  (define (with-throw-handler k thunk pre-unwind-handler)
-    "Add @var{handler} to the dynamic context as a throw handler
-for key @var{k}, then invoke @var{thunk}."
-    (if (not (or (symbol? k) (eqv? k #t)))
-        (scm-error 'wrong-type-arg "with-throw-handler"
+      (define (wrong-type-arg n val)
+        (scm-error 'wrong-type-arg "catch"
                    "Wrong type argument in position ~a: ~a"
-                   (list 1 k) (list k)))
-    (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
-      thunk))
+                   (list n val) (list val)))
+      (unless (or (symbol? k) (eq? k #t))
+        (wrong-type-arg 2 k))
+      (unless (procedure? handler)
+        (wrong-type-arg 3 handler))
+      (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
+        (wrong-type-arg 4 pre-unwind-handler))
+
+      (with-exception-handler
+       (lambda (exn)
+         (apply handler (exception-kind exn) (exception-args exn)))
+       (if pre-unwind-handler
+           (lambda ()
+             (with-throw-handler k thunk pre-unwind-handler))
+           thunk)
+       #:unwind? #t
+       #:unwind-for-type k))))
 
-  (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
-  (define! 'catch catch)
-  (define! 'with-throw-handler with-throw-handler)
-  (define! 'throw throw))
 
 
 
diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index d3f63c2..6f2a2b7 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -30,7 +30,10 @@
                exception?
                exception-type?
                exception-predicate
-               exception-accessor)
+               exception-accessor
+
+               raise-exception
+               with-exception-handler)
   #:export (define-exception-type
 
             &message
@@ -90,8 +93,6 @@
             make-undefined-variable-error
             undefined-variable-error?
 
-            with-exception-handler
-            raise-exception
             raise-continuable))
 
 (define-syntax define-exception-type
@@ -153,21 +154,10 @@
 (define-exception-type &undefined-variable &programming-error
   make-undefined-variable-error undefined-variable-error?)
 
-;; When a native guile exception is caught by with-exception-handler, we
-;; convert it to a compound exception that includes not only the
-;; standard exception objects expected by users of R6RS, SRFI-35, and
-;; R7RS, but also a special &exception-with-key-and-args condition that
-;; preserves the original KEY and ARGS passed to the native Guile catch
-;; handler.
-
-(define make-guile-exception
+(define make-exception-with-key-and-args
   (record-constructor &exception-with-key-and-args))
-(define guile-exception?
-  (record-predicate &exception-with-key-and-args))
-(define guile-exception-key
-  (record-accessor &exception-with-key-and-args 'key))
-(define guile-exception-args
-  (record-accessor &exception-with-key-and-args 'args))
+(define make-quit-exception
+  (record-constructor &quit-exception))
 
 (define (default-guile-exception-converter key args)
   (make-exception (make-error)
@@ -187,69 +177,18 @@
   (let ((converter (assv-ref guile-exception-converters key)))
     (make-exception (or (and converter (converter key args))
                         (default-guile-exception-converter key args))
-                    ;; Preserve the original KEY and ARGS in the R6RS
-                    ;; exception object.
-                    (make-guile-exception key args))))
-
-;; If an exception handler chooses not to handle a given exception, it
-;; will re-raise the exception to pass it on to the next handler.  If
-;; the exception was converted from a native Guile exception, we must
-;; re-raise using the native Guile facilities and the original exception
-;; KEY and ARGS.  We arrange for this in 'raise' so that native Guile
-;; exception handlers will continue to work when mixed with
-;; with-exception-handler.
-
-(define &raise-object-wrapper
-  (make-record-type '&raise-object-wrapper
-                    '((immutable obj) (immutable continuation))))
-(define make-raise-object-wrapper
-  (record-constructor &raise-object-wrapper))
-(define raise-object-wrapper?
-  (record-predicate &raise-object-wrapper))
-(define raise-object-wrapper-obj
-  (record-accessor &raise-object-wrapper 'obj))
-(define raise-object-wrapper-continuation
-  (record-accessor &raise-object-wrapper 'continuation))
-
-(define (raise-exception obj)
-  (if (guile-exception? obj)
-      (apply throw (guile-exception-key obj) (guile-exception-args obj))
-      (throw '%exception (make-raise-object-wrapper obj #f))))
+                    (make-exception-with-key-and-args key args))))
 
 (define (raise-continuable obj)
-  (call/cc
-   (lambda (k)
-     (throw '%exception (make-raise-object-wrapper obj k)))))
-
-(define (with-exception-handler handler thunk)
-  (with-throw-handler #t
-    thunk
-    (lambda (key . args)
-      (cond ((not (eq? key '%exception))
-             (let ((obj (convert-guile-exception key args)))
-               (handler obj)
-               (raise-exception (make-non-continuable-error))))
-            ((and (not (null? args))
-                  (raise-object-wrapper? (car args)))
-             (let* ((cargs (car args))
-                    (obj (raise-object-wrapper-obj cargs))
-                    (continuation (raise-object-wrapper-continuation cargs))
-                    (handler-return (handler obj)))
-               (if continuation
-                   (continuation handler-return)
-                   (raise-exception (make-non-continuable-error)))))))))
+  (raise-exception obj #:continuable? #t))
 
 ;;; Exception printing
 
 (define (exception-printer port key args punt)
   (cond ((and (= 1 (length args))
-              (raise-object-wrapper? (car args)))
-         (let ((obj (raise-object-wrapper-obj (car args))))
-           (cond ((exception? obj)
-                  (display "ERROR:\n" port)
-                  (format-exception port obj))
-                 (else
-                  (format port "ERROR: `~s'" obj)))))
+              (exception? (car args)))
+         (display "ERROR:\n" port)
+         (format-exception port (car args)))
         (else
          (punt))))
 
@@ -372,3 +311,6 @@
 (define (set-guile-exception-converter! key proc)
   (set! guile-exception-converters
         (acons key proc guile-exception-converters)))
+
+;; Override core definition.
+(set! make-exception-from-throw convert-guile-exception)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]