summaryrefslogtreecommitdiff
path: root/libguile/throw.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/throw.c')
-rw-r--r--libguile/throw.c87
1 files changed, 73 insertions, 14 deletions
diff --git a/libguile/throw.c b/libguile/throw.c
index bef1ecf03..b9a4ab514 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -22,6 +22,7 @@
# include <config.h>
#endif
+#include <alloca.h>
#include <stdio.h>
#include <unistdio.h>
#include "libguile/_scm.h"
@@ -119,6 +120,8 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
/* A non-local return. */
+ scm_gc_after_nonlocal_exit ();
+
/* FIXME: We know where the args will be on the stack; we could
avoid consing them. */
SCM args = scm_i_prompt_pop_abort_args_x (vp);
@@ -168,11 +171,39 @@ default_exception_handler (SCM k, SCM args)
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 *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))
@@ -185,17 +216,20 @@ throw_without_pre_unwind (SCM tag, SCM args)
if (scm_is_true (scm_c_vector_ref (eh, 3)))
{
- char *key_chars;
+ const char *key_chars;
+
+ if (scm_i_is_narrow_symbol (tag))
+ key_chars = scm_i_symbol_chars (tag);
+ else
+ key_chars = "(wide symbol)";
- key_chars = scm_to_locale_string (scm_symbol_to_string (tag));
fprintf (stderr, "Warning: Unwind-only `%s' exception; "
"skipping pre-unwind handler.\n", key_chars);
- free (key_chars);
}
prompt_tag = scm_c_vector_ref (eh, 2);
if (scm_is_true (prompt_tag))
- scm_abort_to_prompt_star (prompt_tag, scm_cons (tag, args));
+ abort_to_prompt (prompt_tag, tag, args);
}
default_exception_handler (tag, args);
@@ -571,22 +605,31 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
}
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)
{
- /* Arguments as if from:
+ if (scm_is_false (stack_overflow_args))
+ abort ();
+ throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
- scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
+ /* Not reached. */
+ abort ();
+}
- We build the arguments manually because we throw without running
- pre-unwind handlers. (Pre-unwind handlers could rewind the
- stack.) */
- SCM args = scm_list_4 (SCM_BOOL_F,
- scm_from_latin1_string ("Stack overflow"),
- SCM_BOOL_F,
- SCM_BOOL_F);
- throw_without_pre_unwind (scm_stack_overflow_key, args);
+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 ();
@@ -607,6 +650,22 @@ scm_init_throw ()
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);
+
#include "libguile/throw.x"
}