X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/bb06fceef02a20ce42b069192eb45ddd9012e5ab..4af0d97ee65f298be33d5959cd36a5bea8797be9:/libguile/backtrace.c diff --git a/libguile/backtrace.c b/libguile/backtrace.c index a8afcdf34..7dd66ad2e 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,19 +1,20 @@ /* Printing of backtraces and error messages - * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation + * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation * * This library 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 2.1 of the License, or (at your option) any later version. + * 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. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H @@ -22,7 +23,6 @@ #include #include -#include #include "libguile/_scm.h" @@ -33,6 +33,7 @@ #include #endif +#include "libguile/deprecation.h" #include "libguile/stacks.h" #include "libguile/srcprop.h" #include "libguile/struct.h" @@ -42,9 +43,9 @@ #include "libguile/ports.h" #include "libguile/strings.h" #include "libguile/dynwind.h" +#include "libguile/frames.h" #include "libguile/validate.h" -#include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" #include "libguile/private-options.h" @@ -54,6 +55,43 @@ * Note that these functions shouldn't generate errors themselves. */ +static SCM +boot_print_exception (SCM port, SCM frame, SCM key, SCM args) +#define FUNC_NAME "boot-print-exception" +{ + scm_puts ("Throw to key ", port); + scm_write (key, port); + scm_puts (" with args ", port); + scm_write (args, port); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM +scm_print_exception (SCM port, SCM frame, SCM key, SCM args) +#define FUNC_NAME "print-exception" +{ + static SCM print_exception = SCM_BOOL_F; + + SCM_VALIDATE_OPOUTPORT (1, port); + if (scm_is_true (frame)) + SCM_VALIDATE_FRAME (2, frame); + SCM_VALIDATE_SYMBOL (3, key); + SCM_VALIDATE_LIST (4, args); + + if (scm_is_false (print_exception)) + print_exception = + scm_module_variable (scm_the_root_module (), + scm_from_latin1_symbol ("print-exception")); + + return scm_call_4 (scm_variable_ref (print_exception), + port, frame, key, args); +} +#undef FUNC_NAME + + + + /* Print parameters for error messages. */ #define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7 @@ -71,201 +109,12 @@ if (!(_cond)) \ return SCM_BOOL_F; -SCM scm_the_last_stack_fluid_var; - -static void -display_header (SCM source, SCM port) -{ - if (SCM_MEMOIZEDP (source)) - { - SCM fname = scm_source_property (source, scm_sym_filename); - SCM line = scm_source_property (source, scm_sym_line); - SCM col = scm_source_property (source, scm_sym_column); - - /* Dirk:FIXME:: Maybe we should store the _port_ rather than the - * filename with the source properties? Then we could in case of - * non-file ports give at least some more details than just - * "". */ - if (scm_is_true (fname)) - scm_prin1 (fname, port, 0); - else - scm_puts ("", port); - - if (scm_is_true (line) && scm_is_true (col)) - { - scm_putc (':', port); - scm_intprint (scm_to_long (line) + 1, 10, port); - scm_putc (':', port); - scm_intprint (scm_to_long (col) + 1, 10, port); - } - } - else - scm_puts ("ERROR", port); - scm_puts (": ", port); -} - - -struct display_error_message_data { - SCM message; - SCM args; - SCM port; - scm_print_state *pstate; - int old_fancyp; - int old_level; - int old_length; -}; - -static SCM -display_error_message (struct display_error_message_data *d) -{ - if (scm_is_string (d->message) && scm_is_true (scm_list_p (d->args))) - scm_simple_format (d->port, d->message, d->args); - else - scm_display (d->message, d->port); - scm_newline (d->port); - return SCM_UNSPECIFIED; -} - -static void -before_display_error_message (struct display_error_message_data *d) -{ - scm_print_state *pstate = d->pstate; - d->old_fancyp = pstate->fancyp; - d->old_level = pstate->level; - d->old_length = pstate->length; - pstate->fancyp = 1; - pstate->level = DISPLAY_ERROR_MESSAGE_MAX_LEVEL; - pstate->length = DISPLAY_ERROR_MESSAGE_MAX_LENGTH; -} - -static void -after_display_error_message (struct display_error_message_data *d) -{ - scm_print_state *pstate = d->pstate; - pstate->fancyp = d->old_fancyp; - pstate->level = d->old_level; - pstate->length = d->old_length; -} void scm_display_error_message (SCM message, SCM args, SCM port) { - struct display_error_message_data d; - SCM print_state; - scm_print_state *pstate; - - port = scm_i_port_with_print_state (port, SCM_UNDEFINED); - print_state = SCM_PORT_WITH_PS_PS (port); - pstate = SCM_PRINT_STATE (print_state); - - d.message = message; - d.args = args; - d.port = port; - d.pstate = pstate; - scm_internal_dynamic_wind ((scm_t_guard) before_display_error_message, - (scm_t_inner) display_error_message, - (scm_t_guard) after_display_error_message, - &d, - &d); -} - -static void -display_expression (SCM frame, SCM pname, SCM source, SCM port) -{ - SCM print_state = scm_make_print_state (); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 0; - pstate->fancyp = 1; - pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL; - pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH; - if (scm_is_symbol (pname) || scm_is_string (pname)) - { - if (SCM_FRAMEP (frame) - && SCM_FRAME_EVAL_ARGS_P (frame)) - scm_puts ("While evaluating arguments to ", port); - else - scm_puts ("In procedure ", port); - scm_iprin1 (pname, port, pstate); - if (SCM_MEMOIZEDP (source)) - { - scm_puts (" in expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate); - } - } - else if (SCM_MEMOIZEDP (source)) - { - scm_puts ("In expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate); - } - scm_puts (":\n", port); - scm_free_print_state (print_state); -} - -struct display_error_args { - SCM stack; - SCM port; - SCM subr; - SCM message; - SCM args; - SCM rest; -}; - -static SCM -display_error_body (struct display_error_args *a) -{ - SCM current_frame = SCM_BOOL_F; - SCM source = SCM_BOOL_F; - SCM prev_frame = SCM_BOOL_F; - SCM pname = a->subr; - - if (scm_debug_mode_p - && SCM_STACKP (a->stack) - && SCM_STACK_LENGTH (a->stack) > 0) - { - current_frame = scm_stack_ref (a->stack, SCM_INUM0); - source = SCM_FRAME_SOURCE (current_frame); - prev_frame = SCM_FRAME_PREV (current_frame); - if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame)) - source = SCM_FRAME_SOURCE (prev_frame); - if (!scm_is_symbol (pname) - && !scm_is_string (pname) - && SCM_FRAME_PROC_P (current_frame) - && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame)))) - pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); - } - if (scm_is_symbol (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source)) - { - display_header (source, a->port); - display_expression (current_frame, pname, source, a->port); - } - display_header (source, a->port); - scm_display_error_message (a->message, a->args, a->port); - return SCM_UNSPECIFIED; -} - -struct display_error_handler_data { - char *mode; - SCM port; -}; - -/* This is the exception handler for error reporting routines. - Note that it is very important that this handler *doesn't* try to - print more than the error tag, since the error very probably is - caused by an erroneous print call-back routine. If we would - try to print all objects, we would enter an infinite loop. */ -static SCM -display_error_handler (struct display_error_handler_data *data, - SCM tag, SCM args SCM_UNUSED) -{ - SCM print_state = scm_make_print_state (); - scm_puts ("\nException during displaying of ", data->port); - scm_puts (data->mode, data->port); - scm_puts (": ", data->port); - scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state)); - scm_putc ('\n', data->port); - return SCM_UNSPECIFIED; + scm_print_exception (port, SCM_BOOL_F, scm_misc_error_key, + scm_list_3 (SCM_BOOL_F, message, args)); } @@ -275,28 +124,17 @@ display_error_handler (struct display_error_handler_data *data, * code should rather use the function scm_display_error. */ void -scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest) +scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest) { - struct display_error_args a; - struct display_error_handler_data data; - a.stack = stack; - a.port = port; - a.subr = subr; - a.message = message; - a.args = args; - a.rest = rest; - data.mode = "error"; - data.port = port; - scm_internal_catch (SCM_BOOL_T, - (scm_t_catch_body) display_error_body, &a, - (scm_t_catch_handler) display_error_handler, &data); + scm_print_exception (port, frame, scm_misc_error_key, + scm_list_3 (subr, message, args)); } SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, - (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest), + (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest), "Display an error message to the output port @var{port}.\n" - "@var{stack} is the saved stack for the error, @var{subr} is\n" + "@var{frame} is the frame in which the error occurred, @var{subr} is\n" "the name of the procedure in which the error occurred and\n" "@var{message} is the actual error message, which may contain\n" "formatting instructions. These will format the arguments in\n" @@ -306,7 +144,20 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, { SCM_VALIDATE_OUTPUT_PORT (2, port); - scm_i_display_error (stack, port, subr, message, args, rest); +#if SCM_ENABLE_DEPRECATED + if (SCM_STACKP (frame)) + { + scm_c_issue_deprecation_warning + ("Passing a stack as the first argument to `scm_display_error' is " + "deprecated. Pass a frame instead."); + if (SCM_STACK_LENGTH (frame)) + frame = scm_stack_ref (frame, SCM_INUM0); + else + frame = SCM_BOOL_F; + } +#endif + + scm_i_display_error (frame, port, subr, message, args, rest); return SCM_UNSPECIFIED; } @@ -405,14 +256,14 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S static void display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate) { - SCM proc = SCM_FRAME_PROC (frame); + SCM proc = scm_frame_procedure (frame); SCM name = (scm_is_true (scm_procedure_p (proc)) ? scm_procedure_name (proc) : SCM_BOOL_F); display_frame_expr ("[", scm_cons (scm_is_true (name) ? name : proc, - SCM_FRAME_ARGS (frame)), - SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]", + scm_frame_arguments (frame)), + "]", indentation, sport, port, @@ -434,30 +285,25 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, if (SCM_UNBNDP (indent)) indent = SCM_INUM0; - if (SCM_FRAME_PROC_P (frame)) - /* Display an application. */ - { - SCM sport, print_state; - scm_print_state *pstate; + /* Display an application. */ + { + SCM sport, print_state; + scm_print_state *pstate; - /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (240), - SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - FUNC_NAME); - - /* Create a print state for printing of frames. */ - print_state = scm_make_print_state (); - pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 1; - pstate->fancyp = 1; + /* Create a string port used for adaptation of printing parameters. */ + sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + + /* Create a print state for printing of frames. */ + print_state = scm_make_print_state (); + pstate = SCM_PRINT_STATE (print_state); + pstate->writingp = 1; + pstate->fancyp = 1; - display_application (frame, scm_to_int (indent), sport, port, pstate); - return SCM_BOOL_T; - } - else - return SCM_BOOL_F; + display_application (frame, scm_to_int (indent), sport, port, pstate); + return SCM_BOOL_T; + } } #undef FUNC_NAME @@ -466,17 +312,12 @@ SCM_SYMBOL (sym_base, "base"); static void display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line) { - SCM source = SCM_FRAME_SOURCE (frame); + SCM source = scm_frame_source (frame); *file = *line = SCM_BOOL_F; - if (SCM_MEMOIZEDP (source)) - { - *file = scm_source_property (source, scm_sym_filename); - *line = scm_source_property (source, scm_sym_line); - } - else if (scm_is_pair (source) - && scm_is_pair (scm_cdr (source)) - && scm_is_pair (scm_cddr (source)) - && !scm_is_pair (scm_cdddr (source))) + if (scm_is_pair (source) + && scm_is_pair (scm_cdr (source)) + && scm_is_pair (scm_cddr (source)) + && !scm_is_pair (scm_cdddr (source))) { /* (addr . (filename . (line . column))), from vm compilation */ *file = scm_cadr (source); @@ -495,7 +336,7 @@ display_backtrace_file (frame, last_file, port, pstate) display_backtrace_get_file_line (frame, &file, &line); - if (scm_is_eq (file, *last_file)) + if (scm_is_true (scm_equal_p (file, *last_file))) return; *last_file = file; @@ -562,23 +403,16 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) } static void -display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate) +display_frame (SCM frame, int n, int nfield, int indentation, + SCM sport, SCM port, scm_print_state *pstate) { - int n, i, j; - - /* Announce missing frames? */ - if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_puts ("...\n", port); - } + int i, j; /* display file name and line number */ if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME))) display_backtrace_file_and_line (frame, port, pstate); /* Check size of frame number. */ - n = SCM_FRAME_NUMBER (frame); for (i = 0, j = n; j > 0; ++i) j /= 10; /* Number indentation. */ @@ -587,41 +421,12 @@ display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_ /* Frame number. */ scm_iprin1 (scm_from_int (n), port, pstate); - /* Real frame marker */ - scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port); - /* Indentation. */ indent (indentation, port); - if (SCM_FRAME_PROC_P (frame)) - /* Display an application. */ - display_application (frame, nfield + 1 + indentation, sport, port, pstate); - else - /* Display a special form. */ - { - SCM source = SCM_FRAME_SOURCE (frame); - SCM copy = (scm_is_pair (source) - ? scm_source_property (source, scm_sym_copy) - : SCM_BOOL_F); - SCM umcopy = (SCM_MEMOIZEDP (source) - ? scm_i_unmemoize_expr (source) - : SCM_BOOL_F); - display_frame_expr ("(", - scm_is_pair (copy) ? copy : umcopy, - ")", - nfield + 1 + indentation, - sport, - port, - pstate); - } + /* Display an application. */ + display_application (frame, nfield + 1 + indentation, sport, port, pstate); scm_putc ('\n', port); - - /* Announce missing frames? */ - if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_puts ("...\n", port); - } } struct display_backtrace_args { @@ -637,7 +442,7 @@ display_backtrace_body (struct display_backtrace_args *a) #define FUNC_NAME "display_backtrace_body" { int n_frames, beg, end, n, i, j; - int nfield, indent_p, indentation; + int nfield, indentation; SCM frame, sport, print_state; SCM last_file; scm_print_state *pstate; @@ -679,8 +484,7 @@ display_backtrace_body (struct display_backtrace_args *a) SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace); /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (240), SCM_UNDEFINED), + sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); @@ -691,49 +495,24 @@ display_backtrace_body (struct display_backtrace_args *a) pstate->fancyp = 1; pstate->highlight_objects = a->highlight_objects; - /* First find out if it's reasonable to do indentation. */ - if (SCM_BACKWARDS_P) - indent_p = 0; - else - { - unsigned int j; - - indent_p = 1; - frame = scm_stack_ref (a->stack, scm_from_int (beg)); - for (i = 0, j = 0; i < n; ++i) - { - if (SCM_FRAME_REAL_P (frame)) - ++j; - if (j > SCM_BACKTRACE_INDENT) - { - indent_p = 0; - break; - } - frame = (SCM_BACKWARDS_P - ? SCM_FRAME_PREV (frame) - : SCM_FRAME_NEXT (frame)); - } - } - /* Determine size of frame number field. */ - j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end))); + j = end; for (i = 0; j > 0; ++i) j /= 10; nfield = i ? i : 1; /* Print frames. */ - frame = scm_stack_ref (a->stack, scm_from_int (beg)); indentation = 1; last_file = SCM_UNDEFINED; - for (i = 0; i < n; ++i) + if (SCM_BACKWARDS_P) + end++; + else + end--; + for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i) { + frame = scm_stack_ref (a->stack, scm_from_int (i)); if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) display_backtrace_file (frame, &last_file, a->port, pstate); - - display_frame (frame, nfield, indentation, sport, a->port, pstate); - if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame)) - ++indentation; - frame = (SCM_BACKWARDS_P ? - SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame)); + display_frame (frame, i, nfield, indentation, sport, a->port, pstate); } scm_remember_upto_here_1 (print_state); @@ -742,6 +521,18 @@ display_backtrace_body (struct display_backtrace_args *a) } #undef FUNC_NAME +static SCM +error_during_backtrace (void *data, SCM tag, SCM throw_args) +{ + SCM port = PTR2SCM (data); + + scm_puts ("Exception thrown while printing backtrace:\n", port); + scm_print_exception (port, SCM_BOOL_F, tag, throw_args); + + return SCM_UNSPECIFIED; +} + + SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, (SCM stack, SCM port, SCM first, SCM depth, SCM highlights), "Display a backtrace to the output port @var{port}. @var{stack}\n" @@ -755,7 +546,6 @@ SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, #define FUNC_NAME s_scm_display_backtrace_with_highlights { struct display_backtrace_args a; - struct display_error_handler_data data; a.stack = stack; a.port = port; a.first = first; @@ -764,11 +554,11 @@ SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, a.highlight_objects = SCM_EOL; else a.highlight_objects = highlights; - data.mode = "backtrace"; - data.port = port; + scm_internal_catch (SCM_BOOL_T, (scm_t_catch_body) display_backtrace_body, &a, - (scm_t_catch_handler) display_error_handler, &data); + (scm_t_catch_handler) error_during_backtrace, SCM2PTR (port)); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -784,43 +574,24 @@ SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0, (SCM highlights), - "Display a backtrace of the stack saved by the last error\n" - "to the current output port. If @var{highlights} is given\n" - "it should be a list; the elements of this list will be\n" - "highlighted wherever they appear in the backtrace.") + "Display a backtrace of the current stack to the current\n" + "output port. If @var{highlights} is given, it should be\n" + "a list; the elements of this list will be highlighted\n" + "wherever they appear in the backtrace.") #define FUNC_NAME s_scm_backtrace_with_highlights { SCM port = scm_current_output_port (); - SCM the_last_stack = - scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var)); - + SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL); + if (SCM_UNBNDP (highlights)) highlights = SCM_EOL; - if (scm_is_true (the_last_stack)) - { - scm_newline (port); - scm_puts ("Backtrace:\n", port); - scm_display_backtrace_with_highlights (the_last_stack, - port, - SCM_BOOL_F, - SCM_BOOL_F, - highlights); - scm_newline (port); - if (scm_is_false (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var)) - && !SCM_BACKTRACE_P) - { - scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like " - "a backtrace\n" - "automatically if an error occurs in the future.\n", - port); - SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); - } - } - else - { - scm_puts ("No backtrace available.\n", port); - } + scm_newline (port); + scm_puts ("Backtrace:\n", port); + scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F, + highlights); + scm_newline (port); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -836,9 +607,7 @@ scm_backtrace (void) void scm_init_backtrace () { - SCM f = scm_make_fluid (); - scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f); - + scm_c_define_gsubr ("print-exception", 4, 0, 0, boot_print_exception); #include "libguile/backtrace.x" }