-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 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 "libguile/stacks.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/vm.h"
#include "libguile/throw.h"
baggage. */
-#define CACHE_VAR(var,name) \
- static SCM var = SCM_BOOL_F; \
- if (scm_is_false (var)) \
- { \
- var = scm_module_variable (scm_the_root_module (), \
- scm_from_locale_symbol (name)); \
- if (scm_is_false (var)) \
- abort (); \
- }
-
\f
+static SCM catch_var, throw_var, with_throw_handler_var;
+
SCM
scm_catch (SCM key, SCM thunk, SCM handler)
{
- CACHE_VAR (var, "catch");
-
- return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+ return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
}
SCM
if (SCM_UNBNDP (pre_unwind_handler))
return scm_catch (key, thunk, handler);
else
- {
- CACHE_VAR (var, "catch");
-
- return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
- pre_unwind_handler);
- }
+ return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
+ pre_unwind_handler);
+}
+
+static void
+init_with_throw_handler_var (void)
+{
+ with_throw_handler_var
+ = scm_module_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("with-throw-handler"));
}
SCM
scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
{
- CACHE_VAR (var, "with-throw-handler");
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_with_throw_handler_var);
- return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+ return scm_call_3 (scm_variable_ref (with_throw_handler_var),
+ key, thunk, handler);
}
SCM
scm_throw (SCM key, SCM args)
{
- CACHE_VAR (var, "throw");
-
- return scm_apply_1 (scm_variable_ref (var), key, args);
+ return scm_apply_1 (scm_variable_ref (throw_var), key, args);
}
\f
}
\f
-/* scm_internal_stack_catch
- Use this one if you want debugging information to be stored in
- scm_the_last_stack_fluid_var on error. */
-
-static SCM
-ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
-{
- /* Save the stack */
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
- scm_make_stack (SCM_BOOL_T, SCM_EOL));
- /* Throw the error */
- return scm_throw (tag, throw_args);
-}
-
-struct cwss_data
-{
- SCM tag;
- scm_t_catch_body body;
- void *data;
-};
-
-static SCM
-cwss_body (void *data)
-{
- struct cwss_data *d = data;
- return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
-}
-
-SCM
-scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data)
-{
- struct cwss_data d;
- d.tag = tag;
- d.body = body;
- d.data = body_data;
- return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
-}
-
-
-\f
/* body and handler functions for use with any of the above catch variants */
/* This is a body function you can pass to scm_internal_catch if you
}
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+ return SCM_BACKTRACE_P
+ && scm_is_true (stack)
+ && scm_initialized_p
+ /* It's generally not useful to print backtraces for errors reading
+ or expanding code in these fallback catch statements. */
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
static void
handler_message (void *handler_data, SCM tag, SCM args)
{
- char *prog_name = (char *) handler_data;
- SCM p = scm_current_error_port ();
-
- if (scm_ilength (args) == 4)
+ SCM p, stack, frame;
+
+ p = scm_current_error_port ();
+ /* Usually we get here via a throw to a catch-all. In that case
+ there is the throw frame active, and the catch closure, so narrow by
+ two frames. It is possible for a user to invoke
+ scm_handle_by_message directly, though, so it could be this
+ narrows too much. We'll have to see how this works out in
+ practice. */
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+ frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
+
+ if (should_print_backtrace (tag, stack))
{
- SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
- SCM subr = SCM_CAR (args);
- SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (args);
- SCM rest = SCM_CADDDR (args);
-
- if (SCM_BACKTRACE_P && scm_is_true (stack))
- {
- SCM highlights;
-
- if (scm_is_eq (tag, scm_arg_type_key)
- || scm_is_eq (tag, scm_out_of_range_key))
- highlights = rest;
- else
- highlights = SCM_EOL;
-
- scm_puts ("Backtrace:\n", p);
- scm_display_backtrace_with_highlights (stack, p,
- SCM_BOOL_F, SCM_BOOL_F,
- highlights);
- scm_newline (p);
- }
- scm_i_display_error (stack, p, subr, message, parts, rest);
+ scm_puts ("Backtrace:\n", p);
+ scm_display_backtrace_with_highlights (stack, p,
+ SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL);
+ scm_newline (p);
}
- else
- {
- if (! prog_name)
- prog_name = "guile";
-
- scm_puts (prog_name, p);
- scm_puts (": ", p);
- scm_puts ("uncaught throw to ", p);
- scm_prin1 (tag, p, 0);
- scm_puts (": ", p);
- scm_prin1 (args, p, 1);
- scm_putc ('\n', p);
- }
+ scm_print_exception (p, frame, tag, args);
}
SCM
scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
- if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
+ if (scm_is_true (scm_eq_p (tag, scm_from_latin1_symbol ("quit"))))
exit (scm_exit_status (args));
handler_message (handler_data, tag, args);
SCM
scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
{
- if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
+ if (scm_is_true (scm_eq_p (tag, scm_from_latin1_symbol ("quit"))))
exit (scm_exit_status (args));
handler_message (handler_data, tag, args);
}
SCM
-scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
+scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
{
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");
+
static SCM
pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
abort ();
vm = scm_the_vm ();
- prompt = scm_c_make_prompt (scm_fluid_ref (scm_sys_default_prompt_tag),
+ 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_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+ 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 (prompt);
+ SCM args = scm_i_prompt_pop_abort_args_x (vm);
/* cdr past the continuation */
return scm_apply_0 (handler, scm_cdr (args));
}
return res;
}
+static int
+find_pre_init_catch (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;
+
+ return 0;
+}
+
static SCM
-pre_init_throw (SCM args)
+pre_init_throw (SCM k, SCM args)
{
- return scm_at_abort (scm_fluid_ref (scm_sys_default_prompt_tag), args);
+ 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);
+ }
+
+ fprintf (stderr, "Aborting.\n");
+ abort ();
+ return SCM_BOOL_F; /* not reached */
+ }
}
void
tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
- scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));
+ catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
+ pre_init_catch));
+ throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
+ pre_init_throw));
#include "libguile/throw.x"
}
HCoop / bpt / guile.git / blobdiff