mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 07:50:20 +02:00
Code Activity

* Makefile.in: Added entries for new files: backtrace.c,

Browse source 
backtrace.h, stacks.c and stacks.h.
This commit is contained in:
Mikael Djurfeldt 1996-10-14 03:24:16 +00:00
parent 8cac820d17
commit ab4f3efbfc
2 changed files with 453 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

20
libguile/Makefile.in
View file

@ -157,6 +157,7 @@ inner_h_files= __scm.h \
append.h \
arbiters.h \
async.h \
backtrace.h \
boolean.h \
chars.h \
continuations.h \
@ -205,6 +206,7 @@ inner_h_files= __scm.h \
socket.h \
srcprop.h \
stackchk.h \
stacks.h \
stime.h \
strings.h \
strop.h \
@ -229,6 +231,7 @@ c_files= alist.c \
appinit.c \
arbiters.c \
async.c \
backtrace.c \
boolean.c \
chars.c \
continuations.c \
@ -276,6 +279,7 @@ c_files= alist.c \
socket.c \
srcprop.c \
stackchk.c \
stacks.c \
stime.c \
strerror.c \
strings.c \
@ -297,6 +301,7 @@ gen_c_files= alist.x \
append.x \
arbiters.x \
async.x \
backtrace.x \
boolean.x \
chars.x \
continuations.x \
@ -342,6 +347,7 @@ gen_c_files= alist.x \
socket.x \
srcprop.x \
stackchk.x \
stacks.x \
stime.x \
strings.x \
strop.x \
@ -496,6 +502,13 @@ async.o: async.c _scm.h __scm.h scmconfig.h \
symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
throw.h smob.h ports.h genio.h \
markers.h async.x
backtrace.o: backtrace.c _scm.h __scm.h scmconfig.h \
tags.h error.h __scm.h print.h \
options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
throw.h genio.h smob.h ports.h genio.h \
markers.h procprop.h srcprop.h alist.h continuations.h \
strports.h read.h feature.h backtrace.h backtrace.x
boolean.o: boolean.c _scm.h __scm.h scmconfig.h \
tags.h error.h __scm.h print.h \
options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
@ -755,6 +768,13 @@ stackchk.o: stackchk.c _scm.h __scm.h scmconfig.h \
symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
genio.h stackchk.h continuations.h debug.h \
stackchk.x
stacks.o: stacks.c _scm.h __scm.h scmconfig.h \
tags.h error.h __scm.h print.h \
options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
throw.h genio.h smob.h ports.h genio.h \
markers.h procprop.h srcprop.h alist.h continuations.h \
strports.h read.h feature.h stacks.h stacks.x
stime.o: stime.c _scm.h __scm.h scmconfig.h \
tags.h error.h __scm.h print.h \
options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \

433
libguile/backtrace.c Normal file
View file

@ -0,0 +1,433 @@
/* Printing of backtraces and error messages
* Copyright (C) 1996 Mikael Djurfeldt
*
* 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 program 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.
*
* 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, 675 Mass Ave, Cambridge, MA 02139, 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
*/
#include <stdio.h>
#include "_scm.h"
#include "stacks.h"
#include "srcprop.h"
#include "genio.h"
#include "struct.h"
#include "strports.h"
#include "backtrace.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
static void display_header SCM_P ((SCM source, SCM port));
static void
display_header (source, port)
SCM source;
SCM port;
{
SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
? scm_source_property (source, scm_i_filename)
: SCM_BOOL_F);
if (SCM_NIMP (fname) && SCM_STRINGP (fname))
{
scm_prin1 (fname, port, 0);
scm_gen_putc (':', port);
scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
scm_gen_putc (':', port);
scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
}
else
scm_gen_puts (scm_regular_string, "ERROR", port);
scm_gen_puts (scm_regular_string, ": ", port);
}
static void display_error_message SCM_P ((SCM message, SCM args, SCM port));
static void
display_error_message (message, args, port)
SCM message;
SCM args;
SCM port;
{
int writingp;
char *start;
char *p;
if (!SCM_STRINGP (message) || SCM_IMP (args) || !scm_list_p (args))
{
scm_prin1 (message, port, 0);
scm_gen_putc ('\n', port);
return;
}
start = SCM_CHARS (message);
for (p = start; *p != '\0'; ++p)
if (*p == '%')
{
if (SCM_IMP (args) || SCM_NCONSP (args))
continue;
++p;
if (*p == 's')
writingp = 0;
else if (*p == 'S')
writingp = 1;
else
continue;
scm_gen_write (scm_regular_string, start, p - start - 1, port);
scm_prin1 (SCM_CAR (args), port, writingp);
args = SCM_CDR (args);
start = p + 1;
}
scm_gen_write (scm_regular_string, start, p - start, port);
scm_gen_putc ('\n', port);
}
static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
static void
display_expression (frame, pname, source, port)
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 = 2;
pstate->length = 3;
if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
{
if (SCM_NIMP (frame)
&& SCM_FRAMEP (frame)
&& SCM_FRAME_EVAL_ARGS_P (frame))
scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
else
scm_gen_puts (scm_regular_string, "In procedure ", port);
scm_iprin1 (pname, port, pstate);
if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
{
scm_gen_puts (scm_regular_string, " in expression ", port);
pstate->writingp = 1;
scm_iprin1 (scm_unmemoize (source), port, pstate);
}
}
else if (SCM_NIMP (source))
{
scm_gen_puts (scm_regular_string, "In expression ", port);
pstate->writingp = 1;
scm_iprin1 (scm_unmemoize (source), port, pstate);
}
scm_gen_puts (scm_regular_string, ":\n", port);
scm_free_print_state (print_state);
}
SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
SCM
scm_display_error (stack, port, subr, message, args, rest)
SCM stack;
SCM port;
SCM subr;
SCM message;
SCM args;
SCM rest;
{
SCM current_frame = SCM_BOOL_F;
SCM source = SCM_BOOL_F;
SCM pname = SCM_BOOL_F;
if (SCM_DEBUGGINGP && SCM_NIMP (stack) && SCM_STACKP (stack))
{
current_frame = scm_stack_ref (stack, SCM_INUM0);
source = SCM_FRAME_SOURCE (current_frame);
if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
if (SCM_FRAME_PROC_P (current_frame)
&& scm_procedure_p (SCM_FRAME_PROC (current_frame)))
pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
}
if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
pname = subr;
if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
|| (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
{
display_header (source, port);
display_expression (current_frame, pname, source, port);
}
display_header (source, port);
display_error_message (message, args, port);
return SCM_UNSPECIFIED;
}
static void indent SCM_P ((int n, SCM port));
static void
indent (n, port)
int n;
SCM port;
{
int i;
for (i = 0; i < n; ++i)
scm_gen_putc (' ', port);
}
static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
char *hdr;
SCM exp;
char *tlr;
int indentation;
SCM sport;
SCM port;
scm_print_state *pstate;
{
pstate->level = 2;
pstate->length = 3;
if (SCM_NIMP (exp) && SCM_CONSP (exp))
{
scm_iprlist (hdr, exp, tlr[0], port, pstate);
scm_gen_puts (scm_regular_string, &tlr[1], port);
}
else
scm_iprin1 (exp, port, pstate);
scm_gen_putc ('\n', port);
}
static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_frame (frame, nfield, indentation, sport, port, pstate)
SCM frame;
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_gen_puts (scm_regular_string, "...\n", port);
}
/* Check size of frame number. */
n = SCM_FRAME_NUMBER (frame);
for (i = 0, j = n; j > 0; ++i) j /= 10;
/* Number indentation. */
indent (nfield - (i ? i : 1), port);
/* Frame number. */
scm_iprin1 (SCM_MAKINUM (n), port, pstate);
/* Real frame marker */
scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
/* Indentation. */
indent (indentation, port);
if (SCM_FRAME_PROC_P (frame))
/* Display an application. */
{
SCM proc = SCM_FRAME_PROC (frame);
SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
? scm_procedure_name (proc)
: SCM_BOOL_F);
display_frame_expr ("[",
scm_cons (SCM_NFALSEP (name) ? name : proc,
SCM_FRAME_ARGS (frame)),
SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
nfield + 1 + indentation,
sport,
port,
pstate);
}
else
/* Display a special form. */
{
SCM source = SCM_FRAME_SOURCE (frame);
SCM copy = scm_source_property (source, scm_i_copy);
display_frame_expr ("(",
SCM_NIMP (copy) && SCM_CONSP (copy)
? copy
: scm_unmemoize (source),
")",
nfield + 1 + indentation,
sport,
port,
pstate);
}
/* Announce missing frames? */
if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{
indent (nfield + 1 + indentation, port);
scm_gen_puts (scm_regular_string, "...\n", port);
}
}
SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
SCM
scm_display_backtrace (stack, port, first, depth)
SCM stack;
SCM port;
SCM first;
SCM depth;
{
int n_frames, beg, end, n, i, j;
int nfield, indent_p, indentation;
SCM frame, sport, print_state;
scm_print_state *pstate;
/* Argument checking and extraction. */
SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
stack,
SCM_ARG1,
s_display_backtrace);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
port,
SCM_ARG2,
s_display_backtrace);
n_frames = SCM_INUM (scm_stack_length (stack));
n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
if (SCM_BACKWARDS_P)
{
beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
end = beg + n - 1;
if (end >= n_frames)
end = n_frames - 1;
n = end - beg + 1;
}
else
{
if (SCM_INUMP (first))
{
beg = SCM_INUM (first);
end = beg - n + 1;
if (end < 0)
end = 0;
}
else
{
beg = n - 1;
end = 0;
if (beg >= n_frames)
beg = n_frames - 1;
}
n = beg - end + 1;
}
SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
SCM_ASSERT (n > 0, 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_MAKINUM (240), SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
s_display_backtrace);
/* 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;
/* First find out if it's reasonable to do indentation. */
if (SCM_BACKWARDS_P)
indent_p = 0;
else
{
indent_p = 1;
frame = scm_stack_ref (stack, SCM_MAKINUM (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 (stack, SCM_MAKINUM (end)));
for (i = 0; j > 0; ++i) j /= 10;
nfield = i ? i : 1;
scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
/* Print frames. */
frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
indentation = 1;
display_frame (frame, nfield, indentation, sport, port, pstate);
for (i = 1; i < n; ++i)
{
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, port, pstate);
}
return SCM_UNSPECIFIED;
}
void
scm_init_backtrace ()
{
#include "backtrace.x"
}