diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 4 | ||||
-rw-r--r-- | libguile/exceptions.c | 520 | ||||
-rw-r--r-- | libguile/exceptions.h | 65 | ||||
-rw-r--r-- | libguile/init.c | 2 | ||||
-rw-r--r-- | libguile/threads.c | 4 | ||||
-rw-r--r-- | libguile/throw.c | 530 | ||||
-rw-r--r-- | libguile/throw.h | 18 |
7 files changed, 750 insertions, 393 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2050a482b..43411c5a7 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -148,6 +148,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ error.c \ eval.c \ evalext.c \ + exceptions.c \ expand.c \ extensions.c \ fdes-finalizers.c \ @@ -264,6 +265,7 @@ DOT_X_FILES = \ error.x \ eval.x \ evalext.x \ + exceptions.x \ expand.x \ extensions.x \ fdes-finalizers.x \ @@ -372,6 +374,7 @@ DOT_DOC_FILES = \ error.doc \ eval.doc \ evalext.doc \ + exceptions.doc \ expand.doc \ extensions.doc \ fdes-finalizers.doc \ @@ -616,6 +619,7 @@ modinclude_HEADERS = \ error.h \ eval.h \ evalext.h \ + exceptions.h \ expand.h \ extensions.h \ fdes-finalizers.h \ diff --git a/libguile/exceptions.c b/libguile/exceptions.c new file mode 100644 index 000000000..1fe281bc5 --- /dev/null +++ b/libguile/exceptions.c @@ -0,0 +1,520 @@ +/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <alloca.h> +#include <stdio.h> +#include <unistdio.h> + +#include "boolean.h" +#include "control.h" +#include "eq.h" +#include "eval.h" +#include "fluids.h" +#include "gsubr.h" +#include "init.h" +#include "keywords.h" +#include "list.h" +#include "modules.h" +#include "numbers.h" +#include "pairs.h" +#include "ports.h" +#include "smob.h" +#include "stackchk.h" +#include "stacks.h" +#include "strings.h" +#include "symbols.h" +#include "variable.h" + +#include "exceptions.h" + + +/* Pleasantly enough, the guts of exception handling are defined in + Scheme, in terms of prompt, abort, and the %exception-handler fluid. + Check boot-9 for the definitions. + + Still, it's useful to be able to raise unwind-only exceptions from C, + for example so that we can recover from stack overflow. We also need + to have implementations of with-exception-handler and raise handy + before boot time. For that reason we have a parallel implementation + of with-exception-handler that uses the same fluids here. Exceptions + raised from C still call out to Scheme though, so that pre-unwind + handlers can be run. */ + + + + +/* First, some support for C bodies and exception handlers. */ + +static scm_t_bits tc16_thunk; +static scm_t_bits tc16_exception_handler; + +SCM +scm_c_make_thunk (scm_t_thunk thunk, void *data) +{ + SCM_RETURN_NEWSMOB2 (tc16_thunk, thunk, data); +} + +SCM +scm_c_make_exception_handler (scm_t_exception_handler handler, void *data) +{ + SCM_RETURN_NEWSMOB2 (tc16_exception_handler, handler, data); +} + +static SCM +call_thunk (SCM clo) +{ + scm_t_thunk thunk = (void*)SCM_SMOB_DATA (clo); + void *data = (void*)SCM_SMOB_DATA_2 (clo); + + return thunk (data); +} + +static SCM +call_exception_handler (SCM clo, SCM exn) +{ + scm_t_exception_handler handler = (void*)SCM_SMOB_DATA (clo); + void *data = (void*)SCM_SMOB_DATA_2 (clo); + + return handler (data, exn); +} + + + + +/* Now, the implementation of with-exception-handler used internally to + Guile at boot-time. */ + +SCM_KEYWORD (kw_unwind_p, "unwind?"); +SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type"); +static SCM exception_handler_fluid; +static SCM active_exception_handlers_fluid; +static SCM with_exception_handler_var; +static SCM raise_exception_var; + +SCM +scm_c_with_exception_handler (SCM type, scm_t_exception_handler handler, + void *handler_data, + scm_t_thunk thunk, void *thunk_data) +{ + if (!scm_is_eq (type, SCM_BOOL_T) && !scm_is_symbol (type)) + scm_wrong_type_arg ("%with-exception-handler", 1, type); + + SCM prompt_tag = scm_cons (SCM_INUM0, SCM_EOL); + scm_thread *t = SCM_I_CURRENT_THREAD; + scm_t_dynstack *dynstack = &t->dynstack; + scm_t_dynamic_state *dynamic_state = t->dynamic_state; + jmp_buf registers; + jmp_buf *prev_registers; + ptrdiff_t saved_stack_depth; + uint8_t *mra = NULL; + + prev_registers = t->vm.registers; + saved_stack_depth = t->vm.stack_top - t->vm.sp; + + /* Push the prompt and exception handler onto the dynamic stack. */ + scm_dynstack_push_prompt (dynstack, + SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, + prompt_tag, + t->vm.stack_top - t->vm.fp, + saved_stack_depth, + t->vm.ip, + mra, + ®isters); + scm_dynstack_push_fluid (dynstack, exception_handler_fluid, + scm_cons (prompt_tag, type), + dynamic_state); + + if (setjmp (registers)) + { + /* A non-local return. */ + SCM args; + + t->vm.registers = prev_registers; + scm_gc_after_nonlocal_exit (); + + /* FIXME: We know where the args will be on the stack; we could + avoid consing them. */ + args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth); + + /* The first abort arg is the continuation, which is #f. The + second and final arg is the exception. */ + args = scm_cdr (args); + SCM exn = scm_car (args); + if (!scm_is_null (scm_cdr (args))) + abort (); + return handler (handler_data, exn); + } + + SCM res = thunk (thunk_data); + + scm_dynstack_unwind_fluid (dynstack, dynamic_state); + scm_dynstack_pop (dynstack); + + return res; +} + +SCM +scm_with_exception_handler (SCM type, SCM handler, SCM thunk) +{ + return scm_call_6 (scm_variable_ref (with_exception_handler_var), + handler, thunk, kw_unwind_p, SCM_BOOL_T, + kw_unwind_for_type, type); +} + +SCM +scm_with_pre_unwind_exception_handler (SCM handler, SCM thunk) +{ + return scm_call_2 (scm_variable_ref (with_exception_handler_var), + handler, thunk); +} + + + + +SCM_SYMBOL (sys_exception_sym, "%exception"); +/* Note that these record types are marked as non-extensible, so their + type predicate is a simple vtable comparison. */ +static SCM compound_exception; +static SCM exception_with_kind_and_args; +static SCM quit_exception; + +static SCM +extract_exception (SCM obj, SCM non_extensible_vtable) +{ + if (!SCM_STRUCTP (obj)) { + return SCM_BOOL_F; + } + if (scm_is_eq (SCM_STRUCT_VTABLE (obj), non_extensible_vtable)) { + return obj; + } + if (!scm_is_eq (SCM_STRUCT_VTABLE (obj), compound_exception)) { + return SCM_BOOL_F; + } + + SCM exns = SCM_STRUCT_SLOT_REF (obj, 0); + while (!scm_is_null (exns)) { + SCM exn = scm_car (exns); + if (scm_is_eq (SCM_STRUCT_VTABLE (exn), non_extensible_vtable)) { + return exn; + } + exns = scm_cdr (exns); + } + return SCM_BOOL_F; +} + +SCM +scm_exception_kind (SCM obj) +{ + SCM exn = extract_exception (obj, exception_with_kind_and_args); + if (scm_is_false (exn)) { + return sys_exception_sym; + } + return SCM_STRUCT_SLOT_REF (exn, 0); +} + +SCM +scm_exception_args (SCM obj) +{ + SCM exn = extract_exception (obj, exception_with_kind_and_args); + if (scm_is_false (exn)) { + return scm_list_1 (obj); + } + return SCM_STRUCT_SLOT_REF (exn, 1); +} + +static int +exception_has_type (SCM exn, SCM type) +{ + return scm_is_eq (type, SCM_BOOL_T) || + scm_is_eq (type, scm_exception_kind (exn)); +} + + + + +void +scm_dynwind_throw_handler (void) +{ + scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F); +} + + + + +/* Default exception handlers. */ + +/* Derive the an exit status from the arguments to (quit ...). */ +int +scm_exit_status (SCM args) +{ + if (scm_is_pair (args)) + { + SCM cqa = SCM_CAR (args); + + if (scm_is_integer (cqa)) + return scm_to_int (cqa); + else if (scm_is_false (cqa)) + return EXIT_FAILURE; + else + return EXIT_SUCCESS; + } + else if (scm_is_null (args)) + return EXIT_SUCCESS; + else + /* A type error. Strictly speaking we shouldn't get here. */ + return EXIT_FAILURE; +} + +static SCM +get_quit_exception (SCM obj) +{ + return extract_exception (obj, quit_exception); +} + +static int +quit_exception_code (SCM exn) +{ + return scm_to_int (SCM_STRUCT_SLOT_REF (exn, 0)); +} + +static void +scm_display_exception (SCM port, SCM exn) +{ + // FIXME: Make a good exception printer. + scm_puts ("key: ", port); + scm_write (scm_exception_kind (exn), port); + scm_puts (", args: ", port); + scm_write (scm_exception_args (exn), port); + scm_newline (port); +} + +static void +default_exception_handler (SCM exn) +{ + static int error_printing_error = 0; + static int error_printing_fallback = 0; + + if (error_printing_fallback) + fprintf (stderr, "\nFailed to print exception.\n"); + else if (error_printing_error) + { + fprintf (stderr, "\nError while printing exception:\n"); + error_printing_fallback = 1; + scm_write (exn, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + } + else if (scm_is_true (get_quit_exception (exn))) + { + exit (quit_exception_code (get_quit_exception (exn))); + } + else + { + SCM port = scm_current_error_port (); + error_printing_error = 1; + scm_puts ("Uncaught exception:\n", port); + scm_display_exception (port, exn); + scm_i_pthread_exit (NULL); + } + + /* We fall through here for the error-printing-error cases. */ + fprintf (stderr, "Aborting.\n"); + abort (); +} + +static SCM +default_exception_handler_wrapper (void *data, SCM exn) +{ + default_exception_handler (exn); + return SCM_UNDEFINED; +} + +SCM +scm_c_with_default_exception_handler (scm_t_thunk thunk, void *data) +{ + return scm_c_with_exception_handler (SCM_BOOL_T, + default_exception_handler_wrapper, NULL, + thunk, data); +} + + + + +/* An implementation of "raise" for use during boot and in + resource-exhaustion situations. */ + + + +static void +emergency_raise (SCM exn, const char *reason) +{ + size_t depth = 0; + + /* This function is not only the boot implementation of "raise", it is + also called in response to resource allocation failures such as + stack-overflow or out-of-memory. For that reason we need to be + careful to avoid allocating memory. */ + while (1) + { + SCM eh = scm_fluid_ref_star (exception_handler_fluid, + scm_from_size_t (depth++)); + if (scm_is_false (eh)) { + default_exception_handler (exn); + abort (); + } + + if (!scm_is_pair (eh)) { + fprintf (stderr, "Warning: Unwind-only %s exception; " + "skipping pre-unwind handler.\n", reason); + } else { + SCM prompt_tag = scm_car (eh); + SCM type = scm_cdr (eh); + if (exception_has_type (exn, type)) { + SCM tag_and_exn[] = { prompt_tag, exn }; + scm_i_vm_emergency_abort (tag_and_exn, 2); + /* Unreachable. */ + abort (); + } + } + } +} + +static SCM +pre_boot_raise (SCM exn) +{ + emergency_raise (exn, "pre-boot"); + return SCM_UNDEFINED; +} + +SCM +scm_raise_exception (SCM exn) +{ + scm_call_1 (scm_variable_ref (raise_exception_var), exn); + /* Should not be reached. */ + abort (); +} + + + + +SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow"); +SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory"); + +static SCM stack_overflow_exn = SCM_BOOL_F; +static SCM out_of_memory_exn = SCM_BOOL_F; + +/* Since these two functions may be called in response to resource + exhaustion, we have to avoid allocating memory. */ + +void +scm_report_stack_overflow (void) +{ + if (scm_is_false (stack_overflow_exn)) + abort (); + emergency_raise (stack_overflow_exn, "stack overflow"); + + /* Not reached. */ + abort (); +} + +void +scm_report_out_of_memory (void) +{ + if (scm_is_false (out_of_memory_exn)) + abort (); + emergency_raise (out_of_memory_exn, "out of memory"); + + /* Not reached. */ + abort (); +} + +static SCM +make_scm_exception (SCM type, SCM subr, SCM message, SCM args, SCM rest) +{ + return scm_make_struct_simple + (exception_with_kind_and_args, + scm_list_2 (type, + scm_list_4 (subr, message, args, rest))); +} + +static SCM +sys_init_exceptions_x (SCM compound_exception_type, + SCM exception_with_kind_and_args_type, + SCM quit_exception_type) +{ + compound_exception = compound_exception_type; + exception_with_kind_and_args = exception_with_kind_and_args_type; + quit_exception = quit_exception_type; + + + /* Arguments as if from: + + scm_error (stack-overflow, NULL, "Stack overflow", #f, #f); + + We build the arguments manually to avoid allocating memory in + emergency circumstances. */ + stack_overflow_exn = make_scm_exception + (scm_stack_overflow_key, SCM_BOOL_F, + scm_from_latin1_string ("Stack overflow"), SCM_BOOL_F, SCM_BOOL_F); + out_of_memory_exn = make_scm_exception + (scm_out_of_memory_key, SCM_BOOL_F, + scm_from_latin1_string ("Out of memory"), SCM_BOOL_F, SCM_BOOL_F); + + return SCM_UNDEFINED; +} + + + + +/* Initialization. */ + +void +scm_init_exceptions () +{ + tc16_thunk = scm_make_smob_type ("thunk", 0); + scm_set_smob_apply (tc16_thunk, call_thunk, 0, 0, 0); + + tc16_exception_handler = scm_make_smob_type ("exception-handler", 0); + scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0); + + exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F); + active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F); + /* These binding are later removed when the Scheme definitions of + raise and with-exception-handler are created in boot-9.scm. */ + scm_c_define ("%exception-handler", exception_handler_fluid); + scm_c_define ("%active-exception-handlers", active_exception_handlers_fluid); + + with_exception_handler_var = + scm_c_define ("with-exception-handler", SCM_BOOL_F); + raise_exception_var = + scm_c_define ("raise-exception", + scm_c_make_gsubr ("raise-exception", 1, 0, 0, + (scm_t_subr) pre_boot_raise)); + + scm_c_define ("%init-exceptions!", + scm_c_make_gsubr ("%init-exceptions!", 3, 0, 0, + (scm_t_subr) sys_init_exceptions_x)); + +#include "exceptions.x" +} diff --git a/libguile/exceptions.h b/libguile/exceptions.h new file mode 100644 index 000000000..5f3869bb4 --- /dev/null +++ b/libguile/exceptions.h @@ -0,0 +1,65 @@ +#ifndef SCM_EXCEPTIONS_H +#define SCM_EXCEPTIONS_H + +/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2019 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + +#include "libguile/scm.h" + + + +typedef SCM (*scm_t_thunk) (void *data); +typedef SCM (*scm_t_exception_handler) (void *data, SCM exn); + +SCM_INTERNAL SCM scm_c_make_thunk (scm_t_thunk body, + void *body_data); +SCM_INTERNAL SCM scm_c_make_exception_handler (scm_t_exception_handler h, + void *handler_data); + +SCM_INTERNAL SCM scm_c_with_exception_handler (SCM type, + scm_t_exception_handler handler, + void *handler_data, + scm_t_thunk thunk, + void *thunk_data); + +SCM_INTERNAL SCM scm_c_with_default_exception_handler (scm_t_thunk thunk, + void *data); + +SCM_INTERNAL SCM scm_with_exception_handler (SCM type, SCM handler, SCM thunk); +SCM_INTERNAL SCM scm_with_pre_unwind_exception_handler (SCM handler, SCM thunk); +SCM_INTERNAL SCM scm_raise_exception (SCM exn) SCM_NORETURN; + +SCM_INTERNAL SCM scm_exception_kind (SCM exn); +SCM_INTERNAL SCM scm_exception_args (SCM exn); + +SCM_INTERNAL void scm_dynwind_throw_handler (void); + +/* This raises a `stack-overflow' exception, without running pre-unwind + handlers. */ +SCM_API void scm_report_stack_overflow (void); + +/* This raises an `out-of-memory' exception, without running pre-unwind + handlers. */ +SCM_API void scm_report_out_of_memory (void); + +SCM_INTERNAL void scm_init_exceptions (void); + +#endif /* SCM_EXCEPTIONS_H */ diff --git a/libguile/init.c b/libguile/init.c index e33a60324..504c28831 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -58,6 +58,7 @@ #include "error.h" #include "eval.h" #include "evalext.h" +#include "exceptions.h" #include "expand.h" #include "extensions.h" #include "fdes-finalizers.h" @@ -489,6 +490,7 @@ scm_i_init_guile (void *base) scm_init_strorder (); scm_init_srfi_13 (); scm_init_srfi_14 (); /* Requires smob_prehistory */ + scm_init_exceptions (); scm_init_throw (); /* Requires smob_prehistory */ scm_init_trees (); scm_init_version (); diff --git a/libguile/threads.c b/libguile/threads.c index 86ac5e84b..280d306bf 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -821,9 +821,9 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data, { SCM body_closure, handler_closure; - body_closure = scm_i_make_catch_body_closure (body, body_data); + body_closure = scm_c_make_thunk (body, body_data); handler_closure = handler == NULL ? SCM_UNDEFINED : - scm_i_make_catch_handler_closure (handler, handler_data); + scm_i_make_catch_handler (handler, handler_data); return scm_call_with_new_thread (body_closure, handler_closure); } diff --git a/libguile/throw.c b/libguile/throw.c index 055ad87d2..9c89c6511 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -23,17 +23,16 @@ # include <config.h> #endif -#include <alloca.h> #include <stdio.h> #include <unistdio.h> #include "backtrace.h" #include "boolean.h" -#include "control.h" #include "debug.h" -#include "deprecation.h" +#include "dynwind.h" #include "eq.h" #include "eval.h" +#include "exceptions.h" #include "fluids.h" #include "gsubr.h" #include "init.h" @@ -54,278 +53,13 @@ #include "throw.h" -/* Pleasantly enough, the guts of exception handling are defined in - Scheme, in terms of prompt, abort, and the %exception-handler fluid. - Check boot-9 for the definitions. - - Still, it's useful to be able to throw unwind-only exceptions from C, - for example so that we can recover from stack overflow. We also need - to have an implementation of catch and throw handy before boot time. - For that reason we have a parallel implementation of "catch" that - uses the same fluids here. Throws from C still call out to Scheme - though, so that pre-unwind handlers can be run. Getting the dynamic - environment right for pre-unwind handlers is tricky, and it's - important to have all of the implementation in one place. - - All of these function names and prototypes carry a fair bit of historical - baggage. */ - - static SCM throw_var; -static SCM exception_handler_fluid; - -static SCM -catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) -{ - SCM eh, prompt_tag; - SCM res; - scm_thread *t = SCM_I_CURRENT_THREAD; - scm_t_dynstack *dynstack = &t->dynstack; - scm_t_dynamic_state *dynamic_state = t->dynamic_state; - jmp_buf registers; - jmp_buf *prev_registers; - ptrdiff_t saved_stack_depth; - uint8_t *mra = NULL; - - if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag)) - scm_wrong_type_arg ("catch", 1, tag); - - if (SCM_UNBNDP (handler)) - handler = SCM_BOOL_F; - else if (!scm_is_true (scm_procedure_p (handler))) - scm_wrong_type_arg ("catch", 3, handler); - - if (SCM_UNBNDP (pre_unwind_handler)) - pre_unwind_handler = SCM_BOOL_F; - else if (!scm_is_true (scm_procedure_p (pre_unwind_handler))) - scm_wrong_type_arg ("catch", 4, pre_unwind_handler); - - prompt_tag = scm_cons (SCM_INUM0, SCM_EOL); - - eh = scm_c_make_vector (3, SCM_BOOL_F); - scm_c_vector_set_x (eh, 0, tag); - scm_c_vector_set_x (eh, 1, prompt_tag); - scm_c_vector_set_x (eh, 2, pre_unwind_handler); - - prev_registers = t->vm.registers; - saved_stack_depth = t->vm.stack_top - t->vm.sp; - - /* Push the prompt and exception handler onto the dynamic stack. */ - scm_dynstack_push_prompt (dynstack, - SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, - prompt_tag, - t->vm.stack_top - t->vm.fp, - saved_stack_depth, - t->vm.ip, - mra, - ®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 (); -} -/* Now some support for C bodies and catch handlers */ - -static scm_t_bits tc16_catch_closure; - -enum { - CATCH_CLOSURE_BODY, - CATCH_CLOSURE_HANDLER -}; - -SCM -scm_i_make_catch_body_closure (scm_t_catch_body body, void *body_data) -{ - SCM ret; - SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data); - SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY); - return ret; -} - -SCM -scm_i_make_catch_handler_closure (scm_t_catch_handler handler, - void *handler_data) -{ - SCM ret; - SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data); - SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER); - return ret; -} - -static SCM -apply_catch_closure (SCM clo, SCM args) -{ - void *data = (void*)SCM_SMOB_DATA_2 (clo); - - switch (SCM_SMOB_FLAGS (clo)) - { - case CATCH_CLOSURE_BODY: - { - scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo); - return body (data); - } - case CATCH_CLOSURE_HANDLER: - { - scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo); - return handler (data, scm_car (args), scm_cdr (args)); - } - default: - abort (); - } -} - /* TAG is the catch tag. Typically, this is a symbol, but this function doesn't actually care about that. @@ -365,30 +99,79 @@ apply_catch_closure (SCM clo, SCM args) references anyway, this assures that any references in MUMBLE_DATA will be found. */ +struct scm_catch_data +{ + SCM tag; + scm_t_thunk body; + void *body_data; + scm_t_catch_handler handler; + void *handler_data; + scm_t_catch_handler pre_unwind_handler; + void *pre_unwind_handler_data; + SCM pre_unwind_running; +}; + +static SCM +catch_post_unwind_handler (void *data, SCM exn) +{ + struct scm_catch_data *catch_data = data; + return catch_data->handler (catch_data->handler_data, + scm_exception_kind (exn), + scm_exception_args (exn)); +} + +static SCM +catch_pre_unwind_handler (void *data, SCM exn) +{ + struct scm_catch_data *catch_data = data; + SCM kind = scm_exception_kind (exn); + SCM args = scm_exception_args (exn); + if ((scm_is_eq (catch_data->tag, SCM_BOOL_T) + || scm_is_eq (kind, catch_data->tag)) + && scm_is_false (scm_fluid_ref (catch_data->pre_unwind_running))) { + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_throw_handler (); + scm_dynwind_fluid (catch_data->pre_unwind_running, SCM_BOOL_T); + catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data, + kind, args); + scm_dynwind_end (); + } + return scm_raise_exception (exn); +} + +static SCM +catch_body (void *data) +{ + struct scm_catch_data *catch_data = data; + + if (catch_data->pre_unwind_handler) { + SCM thunk = scm_c_make_thunk (catch_data->body, catch_data->body_data); + SCM handler = scm_c_make_exception_handler (catch_pre_unwind_handler, data); + SCM fluid = scm_make_thread_local_fluid (SCM_BOOL_F); + catch_data->pre_unwind_running = fluid; + return scm_with_pre_unwind_exception_handler (handler, thunk); + } + + return catch_data->body (catch_data->body_data); +} + SCM scm_c_catch (SCM tag, - scm_t_catch_body body, void *body_data, + scm_t_thunk body, void *body_data, scm_t_catch_handler handler, void *handler_data, scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data) { - SCM sbody, shandler, spre_unwind_handler; - - sbody = scm_i_make_catch_body_closure (body, body_data); - shandler = scm_i_make_catch_handler_closure (handler, handler_data); - if (pre_unwind_handler) - spre_unwind_handler = - scm_i_make_catch_handler_closure (pre_unwind_handler, - pre_unwind_handler_data); - else - spre_unwind_handler = SCM_UNDEFINED; - - return scm_catch_with_pre_unwind_handler (tag, sbody, shandler, - spre_unwind_handler); + struct scm_catch_data data = + { tag, body, body_data, handler, handler_data, pre_unwind_handler, + pre_unwind_handler_data, SCM_BOOL_F }; + + return scm_c_with_exception_handler (tag, catch_post_unwind_handler, &data, + catch_body, &data); } SCM scm_internal_catch (SCM tag, - scm_t_catch_body body, void *body_data, + scm_t_thunk body, void *body_data, scm_t_catch_handler handler, void *handler_data) { return scm_c_catch (tag, @@ -400,28 +183,96 @@ scm_internal_catch (SCM tag, SCM scm_c_with_throw_handler (SCM tag, - scm_t_catch_body body, + scm_t_thunk body, void *body_data, scm_t_catch_handler handler, void *handler_data, int lazy_catch_p) { - SCM sbody, shandler; + struct scm_catch_data data = + { tag, body, body_data, NULL, NULL, handler, handler_data, SCM_BOOL_F }; if (lazy_catch_p) - scm_c_issue_deprecation_warning - ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n" - "supported. Instead the handler will be invoked from within the dynamic\n" - "context of the corresponding `throw'.\n" - "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n" - "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n" - "and adapt it (if necessary) to expect to be within the dynamic context\n" - "of the throw."); - - sbody = scm_i_make_catch_body_closure (body, body_data); - shandler = scm_i_make_catch_handler_closure (handler, handler_data); - - return scm_with_throw_handler (tag, sbody, shandler); + /* Non-zero lazy_catch_p arguments have been deprecated since + 2010. */ + abort (); + + return catch_body (&data); +} + +static SCM +call_thunk (void* data) +{ + return scm_call_0 (PTR2SCM (data)); +} + +static SCM +call_handler (void* data, SCM a, SCM b) +{ + return scm_call_2 (PTR2SCM (data), a, b); +} + +SCM +scm_catch (SCM key, SCM thunk, SCM handler) +{ + return scm_c_catch (key, call_thunk, SCM2PTR (thunk), + call_handler, SCM2PTR (handler), NULL, NULL); +} + +SCM +scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler, + SCM pre_unwind_handler) +{ + if (SCM_UNBNDP (pre_unwind_handler)) + return scm_catch (key, thunk, handler); + + return scm_c_catch (key, call_thunk, SCM2PTR (thunk), + call_handler, SCM2PTR (handler), + call_handler, SCM2PTR (pre_unwind_handler)); +} + +SCM +scm_with_throw_handler (SCM key, SCM thunk, SCM handler) +{ + return scm_c_with_throw_handler (key, call_thunk, SCM2PTR (thunk), + call_handler, SCM2PTR (handler), 0); +} + +SCM +scm_throw (SCM key, SCM args) +{ + SCM throw = scm_variable_ref (throw_var); + if (scm_is_false (throw)) { + SCM port = scm_current_error_port (); + scm_puts ("Pre-boot error; key: ", port); + scm_write (key, port); + scm_puts (", args: ", port); + scm_write (args, port); + abort (); + } + scm_apply_1 (throw, key, args); + /* Should not be reached. */ + abort (); +} + + + +/* Now some support for C bodies and catch handlers */ + +static scm_t_bits tc16_catch_handler; + +SCM +scm_i_make_catch_handler (scm_t_catch_handler handler, void *data) +{ + SCM_RETURN_NEWSMOB2 (tc16_catch_handler, handler, data); +} + +static SCM +apply_catch_handler (SCM clo, SCM args) +{ + scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo); + void *data = (void*)SCM_SMOB_DATA_2 (clo); + return handler (data, scm_car (args), scm_cdr (args)); } @@ -490,28 +341,6 @@ scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args) scm_handle_by_message_noexit, NULL); } -/* Derive the an exit status from the arguments to (quit ...). */ -int -scm_exit_status (SCM args) -{ - if (scm_is_pair (args)) - { - SCM cqa = SCM_CAR (args); - - if (scm_is_integer (cqa)) - return (scm_to_int (cqa)); - else if (scm_is_false (cqa)) - return EXIT_FAILURE; - else - return EXIT_SUCCESS; - } - else if (scm_is_null (args)) - return EXIT_SUCCESS; - else - /* A type error. Strictly speaking we shouldn't get here. */ - return EXIT_FAILURE; -} - static int should_print_backtrace (SCM tag, SCM stack) @@ -619,66 +448,13 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED) scm_throw (key, args); } -SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow"); -SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory"); - -static SCM stack_overflow_args = SCM_BOOL_F; -static SCM out_of_memory_args = SCM_BOOL_F; - -/* Since these two functions may be called in response to resource - exhaustion, we have to avoid allocating memory. */ - -void -scm_report_stack_overflow (void) -{ - if (scm_is_false (stack_overflow_args)) - abort (); - throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args); - - /* Not reached. */ - abort (); -} - -void -scm_report_out_of_memory (void) -{ - if (scm_is_false (out_of_memory_args)) - abort (); - throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args); - - /* Not reached. */ - abort (); -} - void scm_init_throw () { - tc16_catch_closure = scm_make_smob_type ("catch-closure", 0); - scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1); - - exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F); - /* This binding is later removed when the Scheme definitions of catch, - throw, and with-throw-handler are created in boot-9.scm. */ - scm_c_define ("%exception-handler", exception_handler_fluid); - - throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1, - throw_without_pre_unwind)); - - /* Arguments as if from: - - scm_error (stack-overflow, NULL, "Stack overflow", #f, #f); - - We build the arguments manually because we throw without running - pre-unwind handlers. (Pre-unwind handlers could rewind the - stack.) */ - stack_overflow_args = scm_list_4 (SCM_BOOL_F, - scm_from_latin1_string ("Stack overflow"), - SCM_BOOL_F, - SCM_BOOL_F); - out_of_memory_args = scm_list_4 (SCM_BOOL_F, - scm_from_latin1_string ("Out of memory"), - SCM_BOOL_F, - SCM_BOOL_F); + tc16_catch_handler = scm_make_smob_type ("catch-handler", 0); + scm_set_smob_apply (tc16_catch_handler, apply_catch_handler, 0, 0, 1); + + throw_var = scm_c_define ("throw", SCM_BOOL_F); #include "throw.x" } diff --git a/libguile/throw.h b/libguile/throw.h index ea206f900..de412763b 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -1,7 +1,7 @@ #ifndef SCM_THROW_H #define SCM_THROW_H -/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2018 +/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2019 Free Software Foundation, Inc. This file is part of Guile. @@ -23,17 +23,15 @@ #include "libguile/scm.h" +#include "libguile/exceptions.h" -typedef SCM (*scm_t_catch_body) (void *data); +typedef scm_t_thunk scm_t_catch_body; typedef SCM (*scm_t_catch_handler) (void *data, SCM tag, SCM throw_args); -SCM_INTERNAL SCM scm_i_make_catch_body_closure (scm_t_catch_body body, - void *body_data); -SCM_INTERNAL SCM scm_i_make_catch_handler_closure (scm_t_catch_handler h, - void *handler_data); +SCM_INTERNAL SCM scm_i_make_catch_handler (scm_t_catch_handler h, void *data); SCM_API SCM scm_c_catch (SCM tag, scm_t_catch_body body, @@ -85,14 +83,6 @@ SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler); SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler); SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return) SCM_NORETURN; -/* This throws to the `stack-overflow' key, without running pre-unwind - handlers. */ -SCM_API void scm_report_stack_overflow (void); - -/* This throws to the `out-of-memory' key, without running pre-unwind - handlers. */ -SCM_API void scm_report_out_of_memory (void); - SCM_API SCM scm_throw (SCM key, SCM args) SCM_NORETURN; SCM_INTERNAL void scm_init_throw (void); |