123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332 |
- /* 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"
- }
|