/* Printing of backtraces and error messages
- * Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation
+ * Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * 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.
*
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
+ * 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 General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+ * 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
+ */
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
#include <stdio.h>
#include <ctype.h>
-#include "_scm.h"
+#include "libguile/_scm.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
-#include "stacks.h"
-#include "srcprop.h"
-#include "struct.h"
-#include "strports.h"
-#include "throw.h"
-#include "fluids.h"
-#include "ports.h"
-#include "strings.h"
+#include "libguile/stacks.h"
+#include "libguile/srcprop.h"
+#include "libguile/struct.h"
+#include "libguile/strports.h"
+#include "libguile/throw.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
-#include "validate.h"
-#include "backtrace.h"
+#include "libguile/validate.h"
+#include "libguile/lang.h"
+#include "libguile/backtrace.h"
+#include "libguile/filesys.h"
/* {Error reporting and backtraces}
* (A first approximation.)
* Note that these functions shouldn't generate errors themselves.
*/
-#ifndef SCM_RECKLESS
#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
if (!(_cond)) \
return SCM_BOOL_F;
-#endif
-SCM scm_the_last_stack_fluid;
+SCM scm_the_last_stack_fluid_var;
static void
display_header (SCM source, SCM port)
{
- SCM fname = (SCM_MEMOIZEDP (source)
- ? scm_source_property (source, scm_sym_filename)
- : SCM_BOOL_F);
- if (SCM_STRINGP (fname))
+ if (SCM_MEMOIZEDP (source))
{
- scm_prin1 (fname, port, 0);
- scm_putc (':', port);
- scm_intprint (SCM_INUM (scm_source_property (source, scm_sym_line)) + 1,
- 10,
- port);
- scm_putc (':', port);
- scm_intprint (SCM_INUM (scm_source_property (source, scm_sym_column)) + 1,
- 10,
- port);
+ 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
+ * "<unnamed port>". */
+ if (SCM_STRINGP (fname))
+ scm_prin1 (fname, port, 0);
+ else
+ scm_puts ("<unnamed port>", port);
+
+ if (!SCM_FALSEP (line) && !SCM_FALSEP (col))
+ {
+ scm_putc (':', port);
+ scm_intprint (SCM_INUM (line) + 1, 10, port);
+ scm_putc (':', port);
+ scm_intprint (SCM_INUM (col) + 1, 10, port);
+ }
}
else
scm_puts ("ERROR", port);
void
scm_display_error_message (SCM message, SCM args, SCM port)
{
- if (SCM_ROSTRINGP (message) && SCM_NFALSEP (scm_list_p (args)))
+ if (SCM_STRINGP (message) && !SCM_FALSEP (scm_list_p (args)))
{
scm_simple_format (port, message, args);
scm_newline (port);
}
else
{
- scm_prin1 (message, port, 0);
- scm_putc ('\n', port);
+ scm_display (message, port);
+ scm_newline (port);
}
}
static void
-display_expression (SCM frame,SCM pname,SCM source,SCM port)
+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->fancyp = 1;
pstate->level = 2;
pstate->length = 3;
- if (SCM_ROSTRINGP (pname))
+ if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname))
{
if (SCM_FRAMEP (frame)
&& SCM_FRAME_EVAL_ARGS_P (frame))
scm_iprin1 (scm_unmemoize (source), port, pstate);
}
}
- else if (SCM_NIMP (source))
+ else if (SCM_MEMOIZEDP (source))
{
scm_puts ("In expression ", port);
pstate->writingp = 1;
{
SCM current_frame = SCM_BOOL_F;
SCM source = SCM_BOOL_F;
- SCM pname = SCM_BOOL_F;
SCM prev_frame = SCM_BOOL_F;
+ SCM pname = a->subr;
if (SCM_DEBUGGINGP
&& SCM_STACKP (a->stack)
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)
- && prev_frame != SCM_BOOL_F)
+ if (!SCM_MEMOIZEDP (source) && !SCM_FALSEP (prev_frame))
source = SCM_FRAME_SOURCE (prev_frame);
- if (SCM_FRAME_PROC_P (current_frame)
- && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
+ if (!SCM_SYMBOLP (pname) && !SCM_STRINGP (pname) && SCM_FRAME_PROC_P (current_frame)
+ && SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame)), SCM_BOOL_T))
pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
}
- if (!SCM_ROSTRINGP (pname))
- pname = a->subr;
- if (SCM_ROSTRINGP (pname) || SCM_MEMOIZEDP (source))
+ if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname) || SCM_MEMOIZEDP (source))
{
display_header (source, a->port);
display_expression (current_frame, pname, source, a->port);
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 tag, SCM args SCM_UNUSED)
{
SCM print_state = scm_make_print_state ();
scm_puts ("\nException during displaying of ", data->port);
return SCM_UNSPECIFIED;
}
-SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
- (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
-"")
-#define FUNC_NAME s_scm_display_error
+
+/* 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 stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)
{
struct display_error_args a;
struct display_error_handler_data data;
data.mode = "error";
data.port = port;
scm_internal_catch (SCM_BOOL_T,
- (scm_catch_body_t) display_error_body, &a,
- (scm_catch_handler_t) display_error_handler, &data);
+ (scm_t_catch_body) display_error_body, &a,
+ (scm_t_catch_handler) display_error_handler, &data);
+}
+
+
+SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
+ (SCM stack, 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"
+ "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 (stack, port, subr, message, args, rest);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
typedef struct {
int level;
int length;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0,
(SCM params),
-"")
+ "Set the print parameters to the values from @var{params}.\n"
+ "@var{params} must be a list of two-element lists which must\n"
+ "hold two integer values.")
#define FUNC_NAME s_scm_set_print_params_x
{
int i;
print_params_t *new_params;
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n);
- for (ls = params; SCM_NNULLP (ls); ls = SCM_CDR (ls))
+ for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls))
SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
&& SCM_INUMP (SCM_CAAR (ls))
&& SCM_INUM (SCM_CAAR (ls)) >= 0
params,
SCM_ARG2,
s_scm_set_print_params_x);
- new_params = scm_must_malloc (n * sizeof (print_params_t),
- FUNC_NAME);
+ new_params = scm_malloc (n * sizeof (print_params_t));
if (print_params != default_print_params)
- scm_must_free (print_params);
+ free (print_params);
print_params = new_params;
for (i = 0; i < n; ++i)
{
}
static void
-display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM port,scm_print_state *pstate)
+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_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
do
{
pstate->length = print_params[i].length;
string = scm_strport_to_string (sport);
/* Remove control characters */
for (i = 0; i < n; ++i)
- if (iscntrl (SCM_CHARS (string)[i]))
- SCM_CHARS (string)[i] = ' ';
+ if (iscntrl (SCM_STRING_CHARS (string)[i]))
+ SCM_STRING_CHARS (string)[i] = ' ';
/* Truncate */
if (indentation + n > SCM_BACKTRACE_WIDTH)
{
n = SCM_BACKTRACE_WIDTH - indentation;
- SCM_CHARS (string)[n - 1] = '$';
+ SCM_STRING_CHARS (string)[n - 1] = '$';
}
- scm_lfwrite (SCM_CHARS (string), n, port);
+ scm_lfwrite (SCM_STRING_CHARS (string), n, port);
}
static void
-display_application (SCM frame,int indentation,SCM sport,SCM port,scm_print_state *pstate)
+display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
SCM proc = SCM_FRAME_PROC (frame);
- SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
+ SCM name = (!SCM_FALSEP (scm_procedure_p (proc))
? scm_procedure_name (proc)
: SCM_BOOL_F);
display_frame_expr ("[",
- scm_cons (SCM_NFALSEP (name) ? name : proc,
+ scm_cons (!SCM_FALSEP (name) ? name : proc,
SCM_FRAME_ARGS (frame)),
SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
indentation,
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
{
- SCM_VALIDATE_FRAME (1,frame);
+ SCM_VALIDATE_FRAME (1, frame);
if (SCM_UNBNDP (port))
port = scm_cur_outp;
else
- SCM_VALIDATE_OPOUTPORT (2,port);
+ SCM_VALIDATE_OPOUTPORT (2, port);
if (SCM_UNBNDP (indent))
indent = SCM_INUM0;
else
- SCM_VALIDATE_INUM (3,indent);
+ SCM_VALIDATE_INUM (3, indent);
if (SCM_FRAME_PROC_P (frame))
/* Display an application. */
}
#undef FUNC_NAME
+SCM_SYMBOL (sym_base, "base");
+
+static void
+display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
+{
+ SCM source = SCM_FRAME_SOURCE (frame);
+ *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
+ *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
+}
+
static void
-display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print_state *pstate)
+display_backtrace_file (frame, last_file, port, pstate)
+ SCM frame;
+ SCM *last_file;
+ SCM port;
+ scm_print_state *pstate;
+{
+ SCM file, line;
+
+ display_backtrace_get_file_line (frame, &file, &line);
+
+ if (SCM_EQ_P (file, *last_file))
+ return;
+
+ *last_file = file;
+
+ scm_puts ("In ", port);
+ if (SCM_FALSEP (file))
+ if (SCM_FALSEP (line))
+ scm_puts ("unknown file", port);
+ else
+ scm_puts ("current input", port);
+ else
+ {
+ pstate->writingp = 0;
+ scm_iprin1 (file, port, pstate);
+ pstate->writingp = 1;
+ }
+ scm_puts (":\n", port);
+}
+
+static void
+display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
+{
+ SCM file, line;
+
+ display_backtrace_get_file_line (frame, &file, &line);
+
+ if (SCM_EQ_P (SCM_SHOW_FILE_NAME, sym_base))
+ {
+ if (SCM_FALSEP (file))
+ {
+ if (SCM_FALSEP (line))
+ scm_putc ('?', port);
+ else
+ scm_puts ("<stdin>", port);
+ }
+ else
+ {
+ pstate -> writingp = 0;
+#ifdef HAVE_POSIX
+ scm_iprin1 (SCM_STRINGP (file) ? scm_basename (file, SCM_UNDEFINED) : file,
+ port, pstate);
+#else
+ scm_iprin1 (file, port, pstate);
+#endif
+ pstate -> writingp = 1;
+ }
+
+ scm_putc (':', port);
+ }
+ else if (!SCM_FALSEP (line))
+ {
+ int i, j=0;
+ for (i = SCM_INUM (line)+1; i > 0; i = i/10, j++)
+ ;
+ indent (4-j, port);
+ }
+
+ if (SCM_FALSEP (line))
+ scm_puts (" ?", port);
+ else
+ scm_intprint (SCM_INUM (line) + 1, 10, port);
+ scm_puts (": ", port);
+}
+
+static void
+display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
int n, i, j;
scm_puts ("...\n", port);
}
+ /* display file name and line number */
+ if (!SCM_FALSEP (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;
};
static SCM
-display_backtrace_body(struct display_backtrace_args *a)
+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;
SCM frame, sport, print_state;
+ SCM last_file;
scm_print_state *pstate;
a->port = SCM_COERCE_OUTPORT (a->port);
/* Argument checking and extraction. */
- SCM_ASSERT (SCM_STACKP (a->stack),
- a->stack,
- SCM_ARG1,
- s_display_backtrace);
- SCM_ASSERT (SCM_OPOUTPORTP (a->port),
- a->port,
- SCM_ARG2,
- s_display_backtrace);
+ SCM_VALIDATE_STACK (1, a->stack);
+ SCM_VALIDATE_OPOUTPORT (2, a->port);
n_frames = SCM_INUM (scm_stack_length (a->stack));
n = SCM_INUMP (a->depth) ? SCM_INUM (a->depth) : SCM_BACKTRACE_DEPTH;
if (SCM_BACKWARDS_P)
indent_p = 0;
else
{
+ unsigned int j;
+
indent_p = 1;
frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
for (i = 0, j = 0; i < n; ++i)
/* Print frames. */
frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
indentation = 1;
- display_frame (frame, nfield, indentation, sport, a->port, pstate);
- for (i = 1; i < n; ++i)
+ last_file = SCM_UNDEFINED;
+ for (i = 0; i < n; ++i)
{
+ if (!SCM_EQ_P (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, nfield, indentation, sport, a->port, pstate);
+ frame = (SCM_BACKWARDS_P ?
+ SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
}
+ scm_remember_upto_here_1 (print_state);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0,
- (SCM stack, SCM port, SCM first, SCM depth),
-"")
+ (SCM stack, SCM port, SCM first, SCM depth),
+ "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
{
struct display_backtrace_args a;
data.mode = "backtrace";
data.port = port;
scm_internal_catch (SCM_BOOL_T,
- (scm_catch_body_t) display_backtrace_body, &a,
- (scm_catch_handler_t) display_error_handler, &data);
+ (scm_t_catch_body) display_backtrace_body, &a,
+ (scm_t_catch_handler) display_error_handler, &data);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
+SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0,
- (),
-"")
+ (),
+ "Display a backtrace of the stack saved by the last error\n"
+ "to the current output port.")
#define FUNC_NAME s_scm_backtrace
{
- SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid));
- if (SCM_NFALSEP (the_last_stack))
+ SCM the_last_stack =
+ scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var));
+ if (!SCM_FALSEP (the_last_stack))
{
scm_newline (scm_cur_outp);
scm_puts ("Backtrace:\n", scm_cur_outp);
SCM_UNDEFINED,
SCM_UNDEFINED);
scm_newline (scm_cur_outp);
- if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
+ if (SCM_FALSEP (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);
- SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
+ SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
}
}
else
scm_init_backtrace ()
{
SCM f = scm_make_fluid ();
- scm_the_last_stack_fluid = scm_sysintern ("the-last-stack", f);
+ scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f);
-#include "backtrace.x"
+#include "libguile/backtrace.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/