mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

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

Browse source 
* libguile/exceptions.c:
* libguile/exceptions.h: New files.
* libguile.h: Add exceptions.h.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
  (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add exceptions.c and
  exceptions.h.
* libguile/init.c (scm_i_init_guile): Initialize exceptions.
* libguile/threads.c (scm_spawn_thread): Use new names for
  scm_i_make_catch_handler and scm_c_make_thunk.
* libguile/throw.c: Rewrite to be implemented in terms of
  with-exception-handler / raise-exception.
* libguile/throw.h: Use data types from exceptions.h.  Move
  scm_report_stack_overflow and scm_report_out_of_memory to
  exceptions.[ch].
* module/ice-9/boot-9.scm (&error, &programming-error)
  (&non-continuable, make-exception-from-throw, raise-exception)
  (with-exception-handler): New top-level definitions.
  (throw, catch, with-throw-handler): Rewrite in terms of
  with-exception-handler and raise-exception.
: New top-level definitions.
* module/ice-9/exceptions.scm: Adapt to re-export &error,
  &programming-error, &non-continuable, raise-exception, and
  with-exception-handler from boot-9.
  (make-quit-exception, guile-quit-exception-converter): New exception
  converters.
  (make-exception-from-throw): Override core binding.
* test-suite/tests/eval.test ("inner trim with prompt tag"): Adapt to
  "with-exception-handler" being the procedure on the stack.
  ("outer trim with prompt tag"): Likewise.
* test-suite/tests/exceptions.test (throw-test): Use pass-if-equal.
* module/srfi/srfi-34.scm: Reimplement in terms of core exceptions, and
  make "guard" actually re-raise continuations with the original "raise"
  continuation.
This commit is contained in:
Andy Wingo 2019-11-08 15:31:00 +01:00
parent f2c8ff5a52
commit f4ca107f7f
13 changed files with 1104 additions and 633 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile.h
View file

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

4
libguile/Makefile.am
View file

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

520
libguile/exceptions.c Normal file
View file

@ -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"
}

65
libguile/exceptions.h Normal file
View file

@ -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 */

2
libguile/init.c
View file

@ -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 ();

4
libguile/threads.c
View file

@ -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);
}

526
libguile/throw.c
View file

@ -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.");
/* Non-zero lazy_catch_p arguments have been deprecated since
2010. */
abort ();
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);
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);
tc16_catch_handler = scm_make_smob_type ("catch-handler", 0);
scm_set_smob_apply (tc16_catch_handler, apply_catch_handler, 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);
throw_var = scm_c_define ("throw", SCM_BOOL_F);
#include "throw.x"
}

18
libguile/throw.h
View file

@ -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);

372
module/ice-9/boot-9.scm
View file

@ -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))))))))))
(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)))
;; 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 '()))
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
;; 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 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 (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 %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-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 (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 %exception-handler (steal-binding! '%exception-handler))
(define %active-exception-handlers
(steal-binding! '%active-exception-handlers))
(define %init-exceptions! (steal-binding! '%init-exceptions!))
(define (throw key . args)
"Invoke the catch form matching @var{key}, passing @var{args} to the
(%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))

140
module/ice-9/exceptions.scm
View file

@ -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,10 +94,20 @@
make-undefined-variable-error
undefined-variable-error?
with-exception-handler
raise-exception
raise-continuable))
(define-syntax define-exception-type-procedures
(syntax-rules ()
((_ exception-type supertype constructor predicate
(field accessor) ...)
(begin
(define constructor (record-constructor exception-type))
(define predicate (exception-predicate exception-type))
(define accessor
(exception-accessor exception-type
(record-accessor exception-type 'field)))
...))))
(define-syntax define-exception-type
(syntax-rules ()
((_ exception-type supertype constructor predicate
@ -102,17 +116,14 @@
(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
(exception-accessor exception-type
(record-accessor exception-type 'field)))
...))))
(define-exception-type-procedures exception-type supertype
constructor predicate (field accessor) ...)))))
(define-exception-type &error &exception
(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)

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

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

16
test-suite/tests/eval.test
View file

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

17
test-suite/tests/exceptions.test
View file

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