summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-14 03:24:16 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-14 03:24:16 +0000
commitab4f3efbfc66977d29e1ebac8f7496bca5a22944 (patch)
tree7050b8fac6e407b5b9fbf73cbb30e7b22816b370
parent8cac820d17dc8436ce8e784474b1eb2cfbe447d8 (diff)
downloadguile-ab4f3efbfc66977d29e1ebac8f7496bca5a22944.tar.gz
* Makefile.in: Added entries for new files: backtrace.c,
backtrace.h, stacks.c and stacks.h.
-rw-r--r--libguile/Makefile.in20
-rw-r--r--libguile/backtrace.c433
2 files changed, 453 insertions, 0 deletions
diff --git a/libguile/Makefile.in b/libguile/Makefile.in
index dae40ee9e..ac6f6bc63 100644
--- a/libguile/Makefile.in
+++ b/libguile/Makefile.in
@@ -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 \
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
new file mode 100644
index 000000000..dd578196d
--- /dev/null
+++ b/libguile/backtrace.c
@@ -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"
+}