diff options
Diffstat (limited to 'libguile/backtrace.c')
-rw-r--r-- | libguile/backtrace.c | 331 |
1 files changed, 331 insertions, 0 deletions
diff --git a/libguile/backtrace.c b/libguile/backtrace.c new file mode 100644 index 000000000..4a19d4b8a --- /dev/null +++ b/libguile/backtrace.c @@ -0,0 +1,331 @@ +/* Printing of backtraces and error messages + + Copyright 1996-2001,2003-2004,2006,2009-2011,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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 3 of the License, or + (at your option) any later version. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdio.h> +#include <ctype.h> +#include <unistd.h> + +#ifdef HAVE_IO_H +#include <io.h> +#endif + +#include "boolean.h" +#include "deprecation.h" +#include "dynwind.h" +#include "eval.h" +#include "filesys.h" +#include "fluids.h" +#include "frames.h" +#include "gsubr.h" +#include "keywords.h" +#include "list.h" +#include "modules.h" +#include "numbers.h" +#include "ports.h" +#include "posix.h" +#include "private-options.h" +#include "srcprop.h" +#include "stacks.h" +#include "strings.h" +#include "strports.h" +#include "struct.h" +#include "symbols.h" +#include "throw.h" +#include "variable.h" + +#include "backtrace.h" + +/* {Error reporting and backtraces} + * + * 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 + +static SCM print_exception_var; +static SCM print_frame_var; +static SCM kw_count; +static SCM print_frames_var; +static SCM frame_to_stack_vector_var; + +static void +init_print_exception_var (void) +{ + print_exception_var + = scm_module_variable (scm_the_root_module (), + scm_from_latin1_symbol ("print-exception")); +} + +static void +init_print_frame_var (void) +{ + print_frame_var = + scm_c_public_variable ("system repl debug", "print-frame"); +} + +static void +init_print_frames_var_and_frame_to_stack_vector_var (void) +{ + kw_count = scm_from_latin1_keyword ("count"); + print_frames_var = + scm_c_public_variable ("system repl debug", "print-frames"); + frame_to_stack_vector_var = + scm_c_public_variable ("system repl debug", "frame->stack-vector"); +} + +SCM +scm_print_exception (SCM port, SCM frame, SCM key, SCM args) +#define FUNC_NAME "print-exception" +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_print_exception_var); + + 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); + + return scm_call_4 (scm_variable_ref (print_exception_var), + port, frame, key, args); +} +#undef FUNC_NAME + + + + +/* Print parameters for error messages. */ + +#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7 +#define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10 + +/* Print parameters for failing expressions in error messages. + * (See also `print_params' below for backtrace print parameters.) + */ + +#define DISPLAY_EXPRESSION_MAX_LEVEL 2 +#define DISPLAY_EXPRESSION_MAX_LENGTH 3 + +#undef SCM_ASSERT +#define SCM_ASSERT(_cond, _arg, _pos, _subr) \ + if (!(_cond)) \ + return SCM_BOOL_F; + + +void +scm_display_error_message (SCM message, SCM args, SCM port) +{ + scm_print_exception (port, SCM_BOOL_F, scm_misc_error_key, + scm_list_3 (SCM_BOOL_F, message, args)); +} + + +/* The function scm_i_display_error prints out a detailed error message. This + * function will be called directly within libguile to signal error messages. + * No parameter checks will be performed by scm_i_display_error. Thus, User + * code should rather use the function scm_display_error. + */ +void +scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest) +{ + 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 frame, SCM port, SCM subr, SCM message, SCM args, SCM rest), + "Display an error message to the output port @var{port}.\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" + "the list @var{args} accordingly. @var{rest} is currently\n" + "ignored.") +#define FUNC_NAME s_scm_display_error +{ + SCM_VALIDATE_OUTPUT_PORT (2, port); + + scm_i_display_error (frame, port, subr, message, args, rest); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, + (SCM frame, SCM port, SCM indent), + "Display a procedure application @var{frame} to the output port\n" + "@var{port}. @var{indent} specifies the indentation of the\n" + "output.") +#define FUNC_NAME s_scm_display_application +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_print_frame_var); + + /* FIXME perhaps: ignoring indent. But really we should deprecate + this procedure in favor of print-frame. */ + return scm_call_2 (scm_variable_ref (print_frame_var), frame, port); +} +#undef FUNC_NAME + +struct display_backtrace_args { + SCM stack; + SCM port; + SCM first; + SCM depth; + SCM highlight_objects; +}; + +static SCM +display_backtrace_body (struct display_backtrace_args *a) +#define FUNC_NAME "display-backtrace" +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + SCM frames; + + scm_i_pthread_once (&once, + init_print_frames_var_and_frame_to_stack_vector_var); + + a->port = SCM_COERCE_OUTPORT (a->port); + + /* Argument checking and extraction. */ + SCM_VALIDATE_STACK (1, a->stack); + SCM_VALIDATE_OPOUTPORT (2, a->port); + + if (scm_is_false (a->first)) + a->first = SCM_INUM0; + if (scm_is_false (a->depth)) + a->depth = scm_from_int (SCM_BACKTRACE_DEPTH); + + if (scm_is_false (scm_less_p (a->first, scm_stack_length (a->stack)))) + return SCM_UNSPECIFIED; + + frames = scm_call_1 (scm_variable_ref (frame_to_stack_vector_var), + scm_stack_ref (a->stack, a->first)); + + /* FIXME: highlight_objects */ + scm_call_4 (scm_variable_ref (print_frames_var), frames, a->port, + kw_count, a->depth); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static SCM +error_during_backtrace (void *data, SCM tag, SCM throw_args) +{ + SCM port = SCM_PACK_POINTER (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" + "is the stack to take the backtrace from, @var{first} specifies\n" + "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; + a.stack = stack; + a.port = port; + a.first = SCM_UNBNDP (first) ? SCM_BOOL_F : first; + a.depth = SCM_UNBNDP (depth) ? SCM_BOOL_F : depth; + a.highlight_objects = SCM_UNBNDP (highlights) ? SCM_EOL : highlights; + + scm_internal_catch (SCM_BOOL_T, + (scm_t_catch_body) display_backtrace_body, &a, + (scm_t_catch_handler) error_during_backtrace, SCM_UNPACK_POINTER (port)); + + return SCM_UNSPECIFIED; +} +#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_with_highlights, "backtrace", 0, 1, 0, + (SCM highlights), + "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 stack = scm_make_stack (SCM_BOOL_T, SCM_EOL); + + if (SCM_UNBNDP (highlights)) + highlights = SCM_EOL; + + 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 + +SCM +scm_backtrace (void) +{ + return scm_backtrace_with_highlights (SCM_EOL); +} + + + +void +scm_init_backtrace () +{ + scm_c_define_gsubr ("print-exception", 4, 0, 0, boot_print_exception); +#include "backtrace.x" +} |