diff --git a/libguile/throw.c b/libguile/throw.c index b5931fb63..7b2a98bd5 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -335,109 +335,37 @@ scm_exit_status (SCM args) } +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 (); + SCM p, stack, frame; - if (scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error")) - && scm_ilength (args) >= 5) + p = scm_current_error_port (); + stack = scm_make_stack (SCM_BOOL_T, SCM_EOL); + frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F; + + if (should_print_backtrace (tag, stack)) { - SCM who = SCM_CAR (args); - SCM what = SCM_CADR (args); - SCM where = SCM_CADDR (args); - SCM form = SCM_CADDDR (args); - SCM subform = SCM_CAR (SCM_CDDDDR (args)); - - scm_puts ("Syntax error:\n", p); - - if (scm_is_true (where)) - { - SCM file, line, col; - - file = scm_assq_ref (where, scm_sym_filename); - line = scm_assq_ref (where, scm_sym_line); - col = scm_assq_ref (where, scm_sym_column); - - if (scm_is_true (file)) - scm_display (file, p); - else - scm_puts ("unknown file", p); - scm_puts (":", p); - scm_display (line, p); - scm_puts (":", p); - scm_display (col, p); - scm_puts (": ", p); - } - else - scm_puts ("unknown location: ", p); - - if (scm_is_true (who)) - { - scm_display (who, p); - scm_puts (": ", p); - } - - scm_display (what, p); - - if (scm_is_true (subform)) - { - scm_puts (" in subform ", p); - scm_write (subform, p); - scm_puts (" of ", p); - scm_write (form, p); - } - else if (scm_is_true (form)) - { - scm_puts (" in form ", p); - scm_write (form, p); - } - + 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 (scm_ilength (args) == 4) - { - 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_initialized_p) - { - 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 (scm_is_true (stack) - ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F, - p, subr, message, parts, rest); - } - 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); }