X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/cc95e00ac63820cbc03ca858ff6b8e1015c9d168..82ae1b8eb3413e6be6bd2aa032986fc7782e85ac:/libguile/backtrace.c diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 09430f5cc..a8bc12059 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,5 +1,5 @@ /* Printing of backtraces and error messages - * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation + * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 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 @@ -13,7 +13,7 @@ * * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ #if HAVE_CONFIG_H @@ -47,6 +47,7 @@ #include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" +#include "libguile/private-options.h" /* {Error reporting and backtraces} * @@ -374,14 +375,13 @@ indent (int n, SCM port) static void display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate) { - SCM string; int i = 0, n; scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport); do { pstate->length = print_params[i].length; ptob->seek (sport, 0, SEEK_SET); - if (SCM_CONSP (exp)) + if (scm_is_pair (exp)) { pstate->level = print_params[i].level - 1; scm_iprlist (hdr, exp, tlr[0], sport, pstate); @@ -398,28 +398,8 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S } while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params); ptob->truncate (sport, n); - string = scm_strport_to_string (sport); - assert (scm_is_string (string)); - - { - char *data = scm_i_string_writable_chars (string); - - /* Remove control characters */ - for (i = 0; i < n; ++i) - if (iscntrl (data[i])) - data[i] = ' '; - /* Truncate */ - if (indentation + n > SCM_BACKTRACE_WIDTH) - { - n = SCM_BACKTRACE_WIDTH - indentation; - data[n-1] = '$'; - } - - scm_i_string_stop_writing (); - } - scm_lfwrite (scm_i_string_chars (string), n, port); - scm_remember_upto_here_1 (string); + scm_display (scm_strport_to_string (sport), port); } static void @@ -448,7 +428,7 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, { SCM_VALIDATE_FRAME (1, frame); if (SCM_UNBNDP (port)) - port = scm_cur_outp; + port = scm_current_output_port (); else SCM_VALIDATE_OPOUTPORT (2, port); if (SCM_UNBNDP (indent)) @@ -607,14 +587,14 @@ display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_ /* Display a special form. */ { SCM source = SCM_FRAME_SOURCE (frame); - SCM copy = (SCM_CONSP (source) + 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_CONSP (copy) ? copy : umcopy, + scm_is_pair (copy) ? copy : umcopy, ")", nfield + 1 + indentation, sport, @@ -636,6 +616,7 @@ struct display_backtrace_args { SCM port; SCM first; SCM depth; + SCM highlight_objects; }; static SCM @@ -695,6 +676,7 @@ display_backtrace_body (struct display_backtrace_args *a) pstate = SCM_PRINT_STATE (print_state); pstate->writingp = 1; pstate->fancyp = 1; + pstate->highlight_objects = a->highlight_objects; /* First find out if it's reasonable to do indentation. */ if (SCM_BACKWARDS_P) @@ -747,14 +729,17 @@ display_backtrace_body (struct display_backtrace_args *a) } #undef FUNC_NAME -SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, - (SCM stack, SCM port, SCM first, SCM depth), - "Display a backtrace to the output port @var{port}. @var{stack}\n" +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" "is the stack to take the backtrace from, @var{first} specifies\n" - "where in the stack to start and @var{depth} how much frames\n" - "to display. Both @var{first} and @var{depth} can be @code{#f},\n" - "which means that default values will be used.") -#define FUNC_NAME s_scm_display_backtrace + "where in the stack to start and @var{depth} how many frames\n" + "to display. @var{first} and @var{depth} can be @code{#f},\n" + "which means that default values will be used.\n" + "If @var{highlights} is given it should be a list; the elements\n" + "of this list will be highlighted wherever they appear in the\n" + "backtrace.") +#define FUNC_NAME s_scm_display_backtrace_with_highlights { struct display_backtrace_args a; struct display_error_handler_data data; @@ -762,6 +747,10 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, a.port = port; a.first = first; a.depth = depth; + if (SCM_UNBNDP (highlights)) + a.highlight_objects = SCM_EOL; + else + a.highlight_objects = highlights; data.mode = "backtrace"; data.port = port; scm_internal_catch (SCM_BOOL_T, @@ -771,43 +760,64 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, } #undef FUNC_NAME +SCM +scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth) +{ + return scm_display_backtrace_with_highlights (stack, port, first, depth, + SCM_EOL); +} + SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); -SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, - (), +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.") -#define FUNC_NAME s_scm_backtrace + "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.") +#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)); + + if (SCM_UNBNDP (highlights)) + highlights = SCM_EOL; + if (scm_is_true (the_last_stack)) { - scm_newline (scm_cur_outp); - scm_puts ("Backtrace:\n", scm_cur_outp); - scm_display_backtrace (the_last_stack, - scm_cur_outp, - SCM_UNDEFINED, - SCM_UNDEFINED); - scm_newline (scm_cur_outp); + 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", - scm_cur_outp); + port); SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); } } else { - scm_puts ("No backtrace available.\n", scm_cur_outp); + scm_puts ("No backtrace available.\n", port); } return SCM_UNSPECIFIED; } #undef FUNC_NAME +SCM +scm_backtrace (void) +{ + return scm_backtrace_with_highlights (SCM_EOL); +} + void