#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"
error.c \
eval.c \
evalext.c \
+ exceptions.c \
expand.c \
extensions.c \
fdes-finalizers.c \
error.x \
eval.x \
evalext.x \
+ exceptions.x \
expand.x \
extensions.x \
fdes-finalizers.x \
error.doc \
eval.doc \
evalext.doc \
+ exceptions.doc \
expand.doc \
extensions.doc \
fdes-finalizers.doc \
error.h \
eval.h \
evalext.h \
+ exceptions.h \
expand.h \
extensions.h \
fdes-finalizers.h \
--- /dev/null
+/* 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/>. */
+
+
+\f
+#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. */
+
+
+\f
+
+/* 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);
+}
+
+
+\f
+
+/* 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,
+ ®isters);
+ scm_dynstack_push_fluid (dynstack, exception_handler_fluid,
+ scm_cons (prompt_tag, type),
+ dynamic_state);
+
+ if (setjmp (registers))
+ {
+ /* A non-local return. */
+ SCM args;
+
+ t->vm.registers = prev_registers;
+ scm_gc_after_nonlocal_exit ();
+
+ /* FIXME: We know where the args will be on the stack; we could
+ avoid consing them. */
+ args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth);
+
+ /* The first abort arg is the continuation, which is #f. The
+ second and final arg is the exception. */
+ args = scm_cdr (args);
+ SCM exn = scm_car (args);
+ if (!scm_is_null (scm_cdr (args)))
+ abort ();
+ return handler (handler_data, exn);
+ }
+
+ SCM res = thunk (thunk_data);
+
+ scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+ scm_dynstack_pop (dynstack);
+
+ return res;
+}
+
+SCM
+scm_with_exception_handler (SCM type, SCM handler, SCM thunk)
+{
+ return scm_call_6 (scm_variable_ref (with_exception_handler_var),
+ handler, thunk, kw_unwind_p, SCM_BOOL_T,
+ kw_unwind_for_type, type);
+}
+
+SCM
+scm_with_pre_unwind_exception_handler (SCM handler, SCM thunk)
+{
+ return scm_call_2 (scm_variable_ref (with_exception_handler_var),
+ handler, thunk);
+}
+
+
+\f
+
+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));
+}
+
+
+\f
+
+void
+scm_dynwind_throw_handler (void)
+{
+ scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
+}
+
+
+\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);
+}
+
+
+\f
+
+/* 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 ();
+}
+
+
+\f
+
+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;
+}
+
+
+\f
+
+/* 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"
+}
--- /dev/null
+#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/>. */
+
+\f
+
+#include "libguile/scm.h"
+
+\f
+
+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 */
#include "error.h"
#include "eval.h"
#include "evalext.h"
+#include "exceptions.h"
#include "expand.h"
#include "extensions.h"
#include "fdes-finalizers.h"
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 ();
{
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);
}
# 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"
#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. */
-
-
\f
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,
- ®isters);
- 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 ();
-}
\f
-/* 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.
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,
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 ();
+}
+
+\f
+
+/* 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));
}
\f
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)
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"
}
#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.
\f
#include "libguile/scm.h"
+#include "libguile/exceptions.h"
\f
-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,
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);
(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))
\f
+;;; {Exceptions}
+;;;
+
(let-syntax ((define-values* (syntax-rules ()
((_ (id ...) body ...)
(define-values (id ...)
(error "not a exception" exception))))
(define (make-exception . exceptions)
+ "Return an exception object composed of @var{exceptions}."
(define (flatten exceptions)
(if (null? exceptions)
'()
(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)
(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)
'())))
(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)))
-
-\f
-
-;; 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
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))
\f
exception?
exception-type?
exception-predicate
- exception-accessor)
+ exception-accessor
+
+ &error
+ &programming-error
+ &non-continuable
+
+ raise-exception
+ with-exception-handler)
#:export (define-exception-type
&message
make-warning
warning?
- &error
make-error
error?
make-external-error
external-error?
- &programming-error
- make-programming-error
+ make-programming-error
programming-error?
&assertion-failure
exception-with-origin?
exception-origin
- &non-continuable
make-non-continuable-error
non-continuable-error?
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
(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?)
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?)
(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)
(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))))
(_ #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)))
;; 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)
(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)
;;; 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>)
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.
;;;; 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
(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)))
(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
(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"
projects / platform / upstream / guile.git / commitdiff