-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 License
# include <config.h>
#endif
+#include <alloca.h>
#include <stdio.h>
#include <unistdio.h>
#include "libguile/_scm.h"
#include "libguile/private-options.h"
-/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
- prompt, abort, and the %exception-handler fluid. This file just provides
- shims so that it's easy to have catch functionality from C.
+/* Pleasantly enough, the guts of catch 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 catch_var, throw_var, with_throw_handler_var;
+static SCM throw_var;
-SCM
-scm_catch (SCM key, SCM thunk, SCM handler)
+static SCM exception_handler_fluid;
+
+static SCM
+catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
+ struct scm_vm *vp;
+ SCM eh, prompt_tag;
+ SCM res;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
+ scm_i_jmp_buf registers;
+ scm_t_ptrdiff saved_stack_depth;
+
+ 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 (4, SCM_BOOL_F);
+ scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid));
+ scm_c_vector_set_x (eh, 1, tag);
+ scm_c_vector_set_x (eh, 2, prompt_tag);
+ scm_c_vector_set_x (eh, 3, pre_unwind_handler);
+
+ vp = scm_the_vm ();
+ saved_stack_depth = vp->sp - vp->stack_base;
+
+ /* Push the prompt and exception handler onto the dynamic stack. */
+ scm_dynstack_push_prompt (dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ prompt_tag,
+ vp->fp - vp->stack_base,
+ saved_stack_depth,
+ vp->ip,
+ ®isters);
+ scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
+ dynamic_state);
+
+ if (SCM_I_SETJMP (registers))
+ {
+ /* A non-local return. */
+ SCM args;
+
+ 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 (vp);
+
+ /* 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;
}
-SCM
-scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
- SCM pre_unwind_handler)
+static void
+default_exception_handler (SCM k, SCM args)
{
- if (SCM_UNBNDP (pre_unwind_handler))
- return scm_catch (key, thunk, handler);
+ 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
- return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
- pre_unwind_handler);
+ {
+ 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
-init_with_throw_handler_var (void)
+abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
{
- with_throw_handler_var
- = scm_module_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("with-throw-handler"));
+ SCM *argv;
+ size_t i;
+ long n;
+
+ n = scm_ilength (args) + 1;
+ argv = alloca (sizeof (SCM)*n);
+ argv[0] = tag;
+ for (i = 1; i < n; i++, args = scm_cdr (args))
+ argv[i] = scm_car (args);
+
+ scm_c_abort (scm_the_vm (), prompt_tag, n, argv, NULL);
+
+ /* Oh, what, you're still here? The abort must have been reinstated. Actually,
+ that's quite impossible, given that we're already in C-land here, so...
+ abort! */
+
+ abort ();
+}
+
+static SCM
+throw_without_pre_unwind (SCM tag, SCM args)
+{
+ SCM eh;
+
+ /* 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. */
+ for (eh = scm_fluid_ref (exception_handler_fluid);
+ scm_is_true (eh);
+ eh = scm_c_vector_ref (eh, 0))
+ {
+ SCM catch_key, prompt_tag;
+
+ catch_key = scm_c_vector_ref (eh, 1);
+ 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, 3)))
+ {
+ 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, 2);
+ if (scm_is_true (prompt_tag))
+ abort_to_prompt (prompt_tag, tag, args);
+ }
+
+ default_exception_handler (tag, args);
+ return SCM_UNSPECIFIED;
}
SCM
-scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+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)
{
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- scm_i_pthread_once (&once, init_with_throw_handler_var);
+ return catch (key, thunk, handler, pre_unwind_handler);
+}
- return scm_call_3 (scm_variable_ref (with_throw_handler_var),
- key, thunk, handler);
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+{
+ return catch (key, thunk, SCM_UNDEFINED, handler);
}
SCM
int
scm_exit_status (SCM args)
{
- if (!SCM_NULL_OR_NIL_P (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 1;
+ return EXIT_FAILURE;
+ else
+ return EXIT_SUCCESS;
}
- return 0;
+ else if (scm_is_null (args))
+ return EXIT_SUCCESS;
+ else
+ /* A type error. Strictly speaking we shouldn't get here. */
+ return EXIT_FAILURE;
}
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", p);
+ scm_puts_unlocked ("Backtrace:\n", p);
scm_display_backtrace_with_highlights (stack, p,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
return scm_throw (key, args);
}
-/* Unfortunately we have to support catch and throw before boot-9 has, um,
- booted. So here are lame versions, which will get replaced with their scheme
- equivalents. */
-
-SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
+SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
-static SCM
-pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
-{
- SCM vm, prompt, res;
+static SCM stack_overflow_args = SCM_BOOL_F;
+static SCM out_of_memory_args = SCM_BOOL_F;
- /* Only handle catch-alls without pre-unwind handlers */
- if (!SCM_UNBNDP (pre_unwind_handler))
- abort ();
- if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
- abort ();
-
- vm = scm_the_vm ();
- prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
- SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
-
- if (SCM_PROMPT_SETJMP (prompt))
- {
- /* nonlocal exit */
- SCM args = scm_i_prompt_pop_abort_args_x (vm);
- /* cdr past the continuation */
- return scm_apply_0 (handler, scm_cdr (args));
- }
+/* Since these two functions may be called in response to resource
+ exhaustion, we have to avoid allocating memory. */
- res = scm_call_0 (thunk);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
-
- return res;
-}
-
-static int
-find_pre_init_catch (void)
+void
+scm_report_stack_overflow (void)
{
- SCM winds;
-
- /* Search the wind list for an appropriate prompt.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
- if (SCM_PROMPT_P (SCM_CAR (winds))
- && scm_is_eq (SCM_PROMPT_TAG (SCM_CAR (winds)), sym_pre_init_catch_tag))
- return 1;
+ if (scm_is_false (stack_overflow_args))
+ abort ();
+ throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
- return 0;
+ /* Not reached. */
+ abort ();
}
-static SCM
-pre_init_throw (SCM k, SCM args)
+void
+scm_report_out_of_memory (void)
{
- if (find_pre_init_catch ())
- return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
- else
- {
- 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, "Throw without catch before boot:\n");
- error_printing_error = 1;
- scm_handle_by_message_noexit (NULL, k, args);
- }
+ if (scm_is_false (out_of_memory_args))
+ abort ();
+ throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args);
- fprintf (stderr, "Aborting.\n");
- abort ();
- return SCM_BOOL_F; /* not reached */
- }
+ /* Not reached. */
+ abort ();
}
void
tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
- pre_init_catch));
+ exception_handler_fluid = scm_make_fluid_with_default (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);
+
+ scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, catch));
throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
- pre_init_throw));
+ 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);
#include "libguile/throw.x"
}
HCoop / bpt / guile.git / blobdiff