diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1996-10-14 03:24:16 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1996-10-14 03:24:16 +0000 |
commit | ab4f3efbfc66977d29e1ebac8f7496bca5a22944 (patch) | |
tree | 7050b8fac6e407b5b9fbf73cbb30e7b22816b370 | |
parent | 8cac820d17dc8436ce8e784474b1eb2cfbe447d8 (diff) | |
download | guile-ab4f3efbfc66977d29e1ebac8f7496bca5a22944.tar.gz |
* Makefile.in: Added entries for new files: backtrace.c,
backtrace.h, stacks.c and stacks.h.
-rw-r--r-- | libguile/Makefile.in | 20 | ||||
-rw-r--r-- | libguile/backtrace.c | 433 |
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" +} |