guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] 01/02: Rebase throw/catch on top of raise-exception/with


From: Andy Wingo
Subject: [Guile-commits] 01/02: Rebase throw/catch on top of raise-exception/with-exception-handler
Date: Wed, 13 Nov 2019 16:33:25 -0500 (EST)

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

commit f4ca107f7fe0b6f1ca2c03b558f16077fc89db04
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/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.
---
 libguile.h                       |   1 +
 libguile/Makefile.am             |   4 +
 libguile/exceptions.c            | 520 ++++++++++++++++++++++++++++++++++++++
 libguile/exceptions.h            |  65 +++++
 libguile/init.c                  |   2 +
 libguile/threads.c               |   4 +-
 libguile/throw.c                 | 530 +++++++++++----------------------------
 libguile/throw.h                 |  18 +-
 module/ice-9/boot-9.scm          | 386 +++++++++++++++++++---------
 module/ice-9/exceptions.scm      | 136 ++++------
 module/srfi/srfi-34.scm          |  52 ++--
 test-suite/tests/eval.test       |  16 +-
 test-suite/tests/exceptions.test |  17 +-
 13 files changed, 1111 insertions(+), 640 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..1fe281b
--- /dev/null
+++ b/libguile/exceptions.c
@@ -0,0 +1,520 @@
+/* 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 active_exception_handlers_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));
+}
+
+
+
+
+void
+scm_dynwind_throw_handler (void)
+{
+  scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
+}
+
+
+
+
+/* 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);
+  active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+  /* These binding are later removed when the Scheme definitions of
+     raise and with-exception-handler are created in boot-9.scm.  */
+  scm_c_define ("%exception-handler", exception_handler_fluid);
+  scm_c_define ("%active-exception-handlers", active_exception_handlers_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..5f3869b
--- /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_kind (SCM exn);
+SCM_INTERNAL SCM scm_exception_args (SCM exn);
+
+SCM_INTERNAL void scm_dynwind_throw_handler (void);
+
+/* 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..9c89c65 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -23,17 +23,16 @@
 # include <config.h>
 #endif
 
-#include <alloca.h>
 #include <stdio.h>
 #include <unistdio.h>
 
 #include "backtrace.h"
 #include "boolean.h"
-#include "control.h"
 #include "debug.h"
-#include "deprecation.h"
+#include "dynwind.h"
 #include "eq.h"
 #include "eval.h"
+#include "exceptions.h"
 #include "fluids.h"
 #include "gsubr.h"
 #include "init.h"
@@ -54,278 +53,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 +99,79 @@ 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;
+  SCM pre_unwind_running;
+};
+
+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))
+      && scm_is_false (scm_fluid_ref (catch_data->pre_unwind_running))) {
+    scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+    scm_dynwind_throw_handler ();
+    scm_dynwind_fluid (catch_data->pre_unwind_running, SCM_BOOL_T);
+    catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data,
+                                    kind, args);
+    scm_dynwind_end ();
+  }
+  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);
+    SCM fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+    catch_data->pre_unwind_running = fluid;
+    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, SCM_BOOL_F };
+
+  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 +183,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, SCM_BOOL_F };
 
   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 +341,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 +448,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..ccfdc93 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1027,7 +1027,7 @@ VALUE."
         (display " " p)
         (display (car fields) p)
         (display ": " p)
-        (display (struct-ref s off) p)
+        (write (struct-ref s off) p)
         (loop (cdr fields) (+ 1 off)))))
     (display ">" p))
 
@@ -1399,6 +1399,9 @@ written into the port is returned."
 
 
 
+;;; {Exceptions}
+;;;
+
 (let-syntax ((define-values* (syntax-rules ()
                                ((_ (id ...) body ...)
                                 (define-values (id ...)
@@ -1436,6 +1439,7 @@ object @var{exception}."
              (error "not a exception" exception))))
 
     (define (make-exception . exceptions)
+      "Return an exception object composed of @var{exceptions}."
       (define (flatten exceptions)
         (if (null? exceptions)
             '()
@@ -1447,7 +1451,7 @@ object @var{exception}."
             (make-compound-exception simple))))
 
     (define (exception? obj)
-      "Return true if @var{obj} is an exception."
+      "Return true if @var{obj} is an exception object."
       (or (compound-exception? obj) (simple-exception? obj)))
 
     (define (exception-type? obj)
@@ -1478,6 +1482,9 @@ exception composed of such an instance."
                 (else (rtd-predicate obj))))))
 
     (define (exception-accessor rtd proc)
+      "Return a procedure that will call @var{proc} on an instance of
+the exception type @var{rtd}, or on the component of a compound
+exception that is an instance of @var{rtd}."
       (let ((rtd-predicate (record-predicate rtd)))
         (lambda (obj)
           (if (rtd-predicate obj)
@@ -1487,92 +1494,259 @@ exception composed of such an instance."
                                        '())))
                 (when (null? exceptions)
                   (error "object is not an exception of the right type"
-                         obj rtd))
-                (if (rtd-predicate (car exceptions))
+                         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))
+
+  (define &error
+    (make-exception-type '&error &exception '()))
+  (define &programming-error
+    (make-exception-type '&programming-error &error '()))
+  (define &non-continuable
+    (make-exception-type '&non-continuable &programming-error '()))
+
+  ;; 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 %active-exception-handlers
+      (steal-binding! '%active-exception-handlers))
+    (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* (raise-exception exn #:key (continuable? #f))
+      "Raise an exception by invoking the current exception handler on
+@var{exn}. The handler is called with a continuation whose dynamic
+environment is that of the call to @code{raise}, except that the current
+exception handler is the one that was in place when the handler being
+called was installed.
+
+If @var{continuable?} is true, the handler is invoked in tail position
+relative to the @code{raise-exception} call.  Otherwise if the handler
+returns, a non-continuable exception of type @code{&non-continuable} is
+raised in the same dynamic environment as the handler."
+      (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 %active-exception-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 ((%active-exception-handlers handlers))
+              (cond
+               (continuable?
+                (handler exn))
+               (else
+                (handler exn)
+                (raise-exception
+                 ((record-constructor &non-continuable)))))))))))
+
+    (define* (with-exception-handler handler thunk #:key (unwind? #f)
+                                     (unwind-for-type #t))
+      "Establish @var{handler}, a procedure of one argument, as the
+current exception handler during the dynamic extent of invoking
+@var{thunk}.
+
+If @code{raise-exception} is called during the dynamic extent of
+invoking @var{thunk}, @var{handler} will be invoked on the argument of
+@code{raise-exception}.
+
+There are two kinds of exception handlers: unwinding and non-unwinding.
+
+By default, exception handlers are non-unwinding.  If @var{unwind?} is
+false, @var{handler} will be invoked within the continuation of the
+error, without unwinding the stack.  Its dynamic environment will be
+that of the @code{raise-exception} call, with the exception that the
+current exception handler won't be @var{handler}, but rather the
+\"outer\" handler (the one that was in place when
+@code{with-exception-handler} was called).
+
+However, it's often the case that one would like to handle an exception
+by unwinding the computation to an earlier state and running the error
+handler there.  After all, unless the @code{raise-exception} call is
+continuable, the exception handler needs to abort the continuation.  To
+support this use case, if @var{unwind?} is true, @code{raise-exception}
+will first unwind the stack by invoking an @dfn{escape
+continuation} (@pxref{Prompt Primitives, @code{call/ec}}), and then
+invoke the handler with the continuation of the
+@code{with-exception-handler} call.
+
+Finally, one more wrinkle: for unwinding exception handlers, it can be
+useful to determine whether an exception handler would indeed handle a
+particular exception or not.  This is especially the case for exceptions
+raised in resource-exhaustion scenarios like @code{stack-overflow} or
+@code{out-of-memory}, where you want to immediately shrink the
+continuation before recovering.  @xref{Stack Overflow}.  For this
+purpose, the @var{unwind-for-type} parameter allows users to specify the
+kind of exception handled by an exception handler; if @code{#t}, all
+exceptions will be handled; if an exception type object, only exceptions
+of that type will be handled; otherwise if a symbol, only that
+exceptions with the given @code{exception-kind} will be handled."
+      (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)))
+      (define running? (make-fluid))
+      (with-exception-handler
+       (lambda (exn)
+         (when (and (or (eq? k #t) (eq? k (exception-kind exn)))
+                    (not (fluid-ref running?)))
+           (with-fluids ((%active-exception-handlers #f)
+                         (running? #t))
+             (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 +1779,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..f9fe2fb 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -30,7 +30,14 @@
                exception?
                exception-type?
                exception-predicate
-               exception-accessor)
+               exception-accessor
+
+               &error
+               &programming-error
+               &non-continuable
+
+               raise-exception
+               with-exception-handler)
   #:export (define-exception-type
 
             &message
@@ -42,7 +49,6 @@
             make-warning
             warning?
 
-            &error
             make-error
             error?
 
@@ -50,8 +56,7 @@
            make-external-error
            external-error?
        
-            &programming-error
-           make-programming-error
+            make-programming-error
            programming-error?
 
            &assertion-failure
@@ -68,7 +73,6 @@
             exception-with-origin?
            exception-origin
 
-            &non-continuable
             make-non-continuable-error
             non-continuable-error?
 
@@ -90,18 +94,13 @@
             make-undefined-variable-error
             undefined-variable-error?
 
-            with-exception-handler
-            raise-exception
             raise-continuable))
 
-(define-syntax define-exception-type
+(define-syntax define-exception-type-procedures
   (syntax-rules ()
     ((_ exception-type supertype constructor predicate
        (field accessor) ...)
      (begin
-       (define exception-type
-         (make-record-type 'exception-type '((immutable field) ...)
-                           #:parent supertype #:extensible? #t))
        (define constructor (record-constructor exception-type))
        (define predicate (exception-predicate exception-type))
        (define accessor
@@ -109,10 +108,22 @@
                              (record-accessor exception-type 'field)))
        ...))))
 
-(define-exception-type &error &exception
+(define-syntax define-exception-type
+  (syntax-rules ()
+    ((_ exception-type supertype constructor predicate
+       (field accessor) ...)
+     (begin
+       (define exception-type
+         (make-record-type 'exception-type '((immutable field) ...)
+                           #:parent supertype #:extensible? #t))
+       (define-exception-type-procedures exception-type supertype
+         constructor predicate (field accessor) ...)))))
+
+(define-exception-type-procedures &error &exception
   make-error error?)
-(define-exception-type &programming-error &error
+(define-exception-type-procedures &programming-error &error
   make-programming-error programming-error?)
+
 (define-exception-type &assertion-failure &programming-error
   make-assertion-failure assertion-failure?)
 
@@ -134,7 +145,7 @@
   make-exception-with-origin exception-with-origin?
   (origin exception-origin))
 
-(define-exception-type &non-continuable &programming-error
+(define-exception-type-procedures &non-continuable &programming-error
   make-non-continuable-error
   non-continuable-error?)
 
@@ -153,21 +164,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
-  (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-exception-with-kind-and-args
+  (record-constructor &exception-with-kind-and-args))
+(define make-quit-exception
+  (record-constructor &quit-exception))
 
 (define (default-guile-exception-converter key args)
   (make-exception (make-error)
@@ -187,69 +187,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-kind-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))))
 
@@ -301,6 +250,17 @@
           (_ #f))
          args))
 
+(define make-quit-exception (record-constructor &quit-exception))
+(define (guile-quit-exception-converter key args)
+  (define code
+    (cond
+     ((not (pair? args)) 0)
+     ((integer? (car args)) (car args))
+     ((not (car args)) 1)
+     (else 0)))
+  (make-exception (make-quit-exception code)
+                  (guile-common-exceptions key args)))
+
 (define (guile-lexical-error-converter key args)
   (make-exception (make-lexical-error)
                   (guile-common-exceptions key args)))
@@ -348,7 +308,8 @@
 
 ;; An alist mapping native Guile exception keys to converters.
 (define guile-exception-converters
-  `((read-error                . ,guile-lexical-error-converter)
+  `((quit                      . ,guile-quit-exception-converter)
+    (read-error                . ,guile-lexical-error-converter)
     (syntax-error              . ,guile-syntax-error-converter)
     (unbound-variable          . ,guile-undefined-variable-error-converter)
     (wrong-number-of-args      . ,guile-assertion-failure-converter)
@@ -372,3 +333,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)
diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm
index 183f0ae..0e7ad99 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.
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 8a52e11..71b06f7 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 391a19d..291e10e 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"
 



reply via email to

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