1 /* Printing of backtraces and error messages
2 * Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2, or (at your option)
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this software; see the file COPYING. If not, write to
16 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
17 * Boston, MA 02111-1307 USA
19 * As a special exception, the Free Software Foundation gives permission
20 * for additional uses of the text contained in its release of GUILE.
22 * The exception is that, if you link the GUILE library with other files
23 * to produce an executable, this does not by itself cause the
24 * resulting executable to be covered by the GNU General Public License.
25 * Your use of that executable is in no way restricted on account of
26 * linking the GUILE library code into it.
28 * This exception does not however invalidate any other reasons why
29 * the executable file might be covered by the GNU General Public License.
31 * This exception applies only to the code released by the
32 * Free Software Foundation under the name GUILE. If you copy
33 * code from other Free Software Foundation releases into a copy of
34 * GUILE, as the General Public License permits, the exception does
35 * not apply to the code that you add in this way. To avoid misleading
36 * anyone as to the status of such modified files, you must delete
37 * this exception notice from them.
39 * If you write modifications of your own for GUILE, it is your choice
40 * whether to permit this exception to apply to your modifications.
41 * If you do not wish that, delete this exception notice.
43 * The author can be reached at djurfeldt@nada.kth.se
44 * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
51 #include "libguile/_scm.h"
60 #include "libguile/stacks.h"
61 #include "libguile/srcprop.h"
62 #include "libguile/struct.h"
63 #include "libguile/strports.h"
64 #include "libguile/throw.h"
65 #include "libguile/fluids.h"
66 #include "libguile/ports.h"
67 #include "libguile/strings.h"
69 #include "libguile/validate.h"
70 #include "libguile/lang.h"
71 #include "libguile/backtrace.h"
72 #include "libguile/filesys.h"
74 /* {Error reporting and backtraces}
75 * (A first approximation.)
77 * Note that these functions shouldn't generate errors themselves.
82 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
87 SCM scm_the_last_stack_fluid_var
;
90 display_header (SCM source
, SCM port
)
92 if (SCM_MEMOIZEDP (source
))
94 SCM fname
= scm_source_property (source
, scm_sym_filename
);
95 SCM line
= scm_source_property (source
, scm_sym_line
);
96 SCM col
= scm_source_property (source
, scm_sym_column
);
98 /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
99 * filename with the source properties? Then we could in case of
100 * non-file ports give at least some more details than just
101 * "<unnamed port>". */
102 if (SCM_STRINGP (fname
))
103 scm_prin1 (fname
, port
, 0);
105 scm_puts ("<unnamed port>", port
);
107 if (!SCM_FALSEP (line
) && !SCM_FALSEP (col
))
109 scm_putc (':', port
);
110 scm_intprint (SCM_INUM (line
) + 1, 10, port
);
111 scm_putc (':', port
);
112 scm_intprint (SCM_INUM (col
) + 1, 10, port
);
116 scm_puts ("ERROR", port
);
117 scm_puts (": ", port
);
122 scm_display_error_message (SCM message
, SCM args
, SCM port
)
124 if (SCM_STRINGP (message
) && !SCM_FALSEP (scm_list_p (args
)))
126 scm_simple_format (port
, message
, args
);
131 scm_display (message
, port
);
137 display_expression (SCM frame
,SCM pname
,SCM source
,SCM port
)
139 SCM print_state
= scm_make_print_state ();
140 scm_print_state
*pstate
= SCM_PRINT_STATE (print_state
);
141 pstate
->writingp
= 0;
145 if (SCM_SYMBOLP (pname
) || SCM_STRINGP (pname
))
147 if (SCM_FRAMEP (frame
)
148 && SCM_FRAME_EVAL_ARGS_P (frame
))
149 scm_puts ("While evaluating arguments to ", port
);
151 scm_puts ("In procedure ", port
);
152 scm_iprin1 (pname
, port
, pstate
);
153 if (SCM_MEMOIZEDP (source
))
155 scm_puts (" in expression ", port
);
156 pstate
->writingp
= 1;
157 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
160 else if (SCM_MEMOIZEDP (source
))
162 scm_puts ("In expression ", port
);
163 pstate
->writingp
= 1;
164 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
166 scm_puts (":\n", port
);
167 scm_free_print_state (print_state
);
170 struct display_error_args
{
180 display_error_body (struct display_error_args
*a
)
182 SCM current_frame
= SCM_BOOL_F
;
183 SCM source
= SCM_BOOL_F
;
184 SCM prev_frame
= SCM_BOOL_F
;
188 && SCM_STACKP (a
->stack
)
189 && SCM_STACK_LENGTH (a
->stack
) > 0)
191 current_frame
= scm_stack_ref (a
->stack
, SCM_INUM0
);
192 source
= SCM_FRAME_SOURCE (current_frame
);
193 prev_frame
= SCM_FRAME_PREV (current_frame
);
194 if (!SCM_MEMOIZEDP (source
) && !SCM_FALSEP (prev_frame
))
195 source
= SCM_FRAME_SOURCE (prev_frame
);
196 if (!SCM_SYMBOLP (pname
) && !SCM_STRINGP (pname
) && SCM_FRAME_PROC_P (current_frame
)
197 && SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame
)), SCM_BOOL_T
))
198 pname
= scm_procedure_name (SCM_FRAME_PROC (current_frame
));
200 if (SCM_SYMBOLP (pname
) || SCM_STRINGP (pname
) || SCM_MEMOIZEDP (source
))
202 display_header (source
, a
->port
);
203 display_expression (current_frame
, pname
, source
, a
->port
);
205 display_header (source
, a
->port
);
206 scm_display_error_message (a
->message
, a
->args
, a
->port
);
207 return SCM_UNSPECIFIED
;
210 struct display_error_handler_data
{
215 /* This is the exception handler for error reporting routines.
216 Note that it is very important that this handler *doesn't* try to
217 print more than the error tag, since the error very probably is
218 caused by an erroneous print call-back routine. If we would
219 try to print all objects, we would enter an infinite loop. */
221 display_error_handler (struct display_error_handler_data
*data
,
222 SCM tag
, SCM args SCM_UNUSED
)
224 SCM print_state
= scm_make_print_state ();
225 scm_puts ("\nException during displaying of ", data
->port
);
226 scm_puts (data
->mode
, data
->port
);
227 scm_puts (": ", data
->port
);
228 scm_iprin1 (tag
, data
->port
, SCM_PRINT_STATE (print_state
));
229 scm_putc ('\n', data
->port
);
230 return SCM_UNSPECIFIED
;
234 /* The function scm_i_display_error prints out a detailed error message. This
235 * function will be called directly within libguile to signal error messages.
236 * No parameter checks will be performed by scm_i_display_error. Thus, User
237 * code should rather use the function scm_display_error.
240 scm_i_display_error (SCM stack
, SCM port
, SCM subr
, SCM message
, SCM args
, SCM rest
)
242 struct display_error_args a
;
243 struct display_error_handler_data data
;
252 scm_internal_catch (SCM_BOOL_T
,
253 (scm_t_catch_body
) display_error_body
, &a
,
254 (scm_t_catch_handler
) display_error_handler
, &data
);
258 SCM_DEFINE (scm_display_error
, "display-error", 6, 0, 0,
259 (SCM stack
, SCM port
, SCM subr
, SCM message
, SCM args
, SCM rest
),
260 "Display an error message to the output port @var{port}.\n"
261 "@var{stack} is the saved stack for the error, @var{subr} is\n"
262 "the name of the procedure in which the error occured and\n"
263 "@var{message} is the actual error message, which may contain\n"
264 "formatting instructions. These will format the arguments in\n"
265 "the list @var{args} accordingly. @var{rest} is currently\n"
267 #define FUNC_NAME s_scm_display_error
269 SCM_VALIDATE_OUTPUT_PORT (2, port
);
271 scm_i_display_error (stack
, port
, subr
, message
, args
, rest
);
273 return SCM_UNSPECIFIED
;
283 static int n_print_params
= 9;
284 static print_params_t default_print_params
[] = {
288 { 1, 4 }, { 1, 3 }, { 1, 2 }
290 static print_params_t
*print_params
= default_print_params
;
293 SCM_DEFINE (scm_set_print_params_x
, "set-print-params!", 1, 0, 0,
295 "Set the print parameters to the values from @var{params}.\n"
296 "@var{params} must be a list of two-element lists which must\n"
297 "hold two integer values.")
298 #define FUNC_NAME s_scm_set_print_params_x
303 print_params_t
*new_params
;
305 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params
, n
);
306 for (ls
= params
; !SCM_NULL_OR_NIL_P (ls
); ls
= SCM_CDR (ls
))
307 SCM_ASSERT (scm_ilength (SCM_CAR (params
)) == 2
308 && SCM_INUMP (SCM_CAAR (ls
))
309 && SCM_INUM (SCM_CAAR (ls
)) >= 0
310 && SCM_INUMP (SCM_CADAR (ls
))
311 && SCM_INUM (SCM_CADAR (ls
)) >= 0,
314 s_scm_set_print_params_x
);
315 new_params
= scm_must_malloc (n
* sizeof (print_params_t
),
317 if (print_params
!= default_print_params
)
318 scm_must_free (print_params
);
319 print_params
= new_params
;
320 for (i
= 0; i
< n
; ++i
)
322 print_params
[i
].level
= SCM_INUM (SCM_CAAR (params
));
323 print_params
[i
].length
= SCM_INUM (SCM_CADAR (params
));
324 params
= SCM_CDR (params
);
327 return SCM_UNSPECIFIED
;
333 indent (int n
, SCM port
)
336 for (i
= 0; i
< n
; ++i
)
337 scm_putc (' ', port
);
341 display_frame_expr (char *hdr
,SCM exp
,char *tlr
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
345 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (sport
);
348 pstate
->length
= print_params
[i
].length
;
349 ptob
->seek (sport
, 0, SEEK_SET
);
352 pstate
->level
= print_params
[i
].level
- 1;
353 scm_iprlist (hdr
, exp
, tlr
[0], sport
, pstate
);
354 scm_puts (&tlr
[1], sport
);
358 pstate
->level
= print_params
[i
].level
;
359 scm_iprin1 (exp
, sport
, pstate
);
362 n
= ptob
->seek (sport
, 0, SEEK_CUR
);
365 while (indentation
+ n
> SCM_BACKTRACE_WIDTH
&& i
< n_print_params
);
366 ptob
->truncate (sport
, n
);
367 string
= scm_strport_to_string (sport
);
368 /* Remove control characters */
369 for (i
= 0; i
< n
; ++i
)
370 if (iscntrl (SCM_STRING_CHARS (string
)[i
]))
371 SCM_STRING_CHARS (string
)[i
] = ' ';
373 if (indentation
+ n
> SCM_BACKTRACE_WIDTH
)
375 n
= SCM_BACKTRACE_WIDTH
- indentation
;
376 SCM_STRING_CHARS (string
)[n
- 1] = '$';
379 scm_lfwrite (SCM_STRING_CHARS (string
), n
, port
);
383 display_application (SCM frame
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
385 SCM proc
= SCM_FRAME_PROC (frame
);
386 SCM name
= (!SCM_FALSEP (scm_procedure_p (proc
))
387 ? scm_procedure_name (proc
)
389 display_frame_expr ("[",
390 scm_cons (!SCM_FALSEP (name
) ? name
: proc
,
391 SCM_FRAME_ARGS (frame
)),
392 SCM_FRAME_EVAL_ARGS_P (frame
) ? " ..." : "]",
399 SCM_DEFINE (scm_display_application
, "display-application", 1, 2, 0,
400 (SCM frame
, SCM port
, SCM indent
),
401 "Display a procedure application @var{frame} to the output port\n"
402 "@var{port}. @var{indent} specifies the indentation of the\n"
404 #define FUNC_NAME s_scm_display_application
406 SCM_VALIDATE_FRAME (1,frame
);
407 if (SCM_UNBNDP (port
))
410 SCM_VALIDATE_OPOUTPORT (2,port
);
411 if (SCM_UNBNDP (indent
))
414 SCM_VALIDATE_INUM (3,indent
);
416 if (SCM_FRAME_PROC_P (frame
))
417 /* Display an application. */
419 SCM sport
, print_state
;
420 scm_print_state
*pstate
;
422 /* Create a string port used for adaptation of printing parameters. */
423 sport
= scm_mkstrport (SCM_INUM0
,
424 scm_make_string (SCM_MAKINUM (240),
429 /* Create a print state for printing of frames. */
430 print_state
= scm_make_print_state ();
431 pstate
= SCM_PRINT_STATE (print_state
);
432 pstate
->writingp
= 1;
435 display_application (frame
, SCM_INUM (indent
), sport
, port
, pstate
);
443 SCM_SYMBOL (sym_base
, "base");
446 display_backtrace_get_file_line (SCM frame
, SCM
*file
, SCM
*line
)
448 SCM source
= SCM_FRAME_SOURCE (frame
);
449 *file
= SCM_MEMOIZEDP (source
) ? scm_source_property (source
, scm_sym_filename
) : SCM_BOOL_F
;
450 *line
= (SCM_MEMOIZEDP (source
)) ? scm_source_property (source
, scm_sym_line
) : SCM_BOOL_F
;
454 display_backtrace_file (frame
, last_file
, port
, pstate
)
458 scm_print_state
*pstate
;
462 display_backtrace_get_file_line (frame
, &file
, &line
);
464 if (SCM_EQ_P (file
, *last_file
))
469 scm_puts ("In ", port
);
470 if (SCM_FALSEP (file
))
471 if (SCM_FALSEP (line
))
472 scm_puts ("unknown file", port
);
474 scm_puts ("current input", port
);
477 pstate
->writingp
= 0;
478 scm_iprin1 (file
, port
, pstate
);
479 pstate
->writingp
= 1;
481 scm_puts (":\n", port
);
485 display_backtrace_file_and_line (SCM frame
, SCM port
, scm_print_state
*pstate
)
489 display_backtrace_get_file_line (frame
, &file
, &line
);
491 if (SCM_EQ_P (SCM_SHOW_FILE_NAME
, sym_base
))
493 if (SCM_FALSEP (file
))
495 if (SCM_FALSEP (line
))
496 scm_putc ('?', port
);
498 scm_puts ("<stdin>", port
);
502 pstate
-> writingp
= 0;
504 scm_iprin1 (SCM_STRINGP (file
) ? scm_basename (file
, SCM_UNDEFINED
) : file
,
507 scm_iprin1 (file
, port
, pstate
);
509 pstate
-> writingp
= 1;
512 scm_putc (':', port
);
514 else if (!SCM_FALSEP (line
))
517 for (i
= SCM_INUM (line
)+1; i
> 0; i
= i
/10, j
++)
522 if (SCM_FALSEP (line
))
523 scm_puts (" ?", port
);
525 scm_intprint (SCM_INUM (line
) + 1, 10, port
);
526 scm_puts (": ", port
);
530 display_frame (SCM frame
,int nfield
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
534 /* Announce missing frames? */
535 if (!SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
537 indent (nfield
+ 1 + indentation
, port
);
538 scm_puts ("...\n", port
);
541 /* display file name and line number */
542 if (!SCM_FALSEP (SCM_SHOW_FILE_NAME
))
543 display_backtrace_file_and_line (frame
, port
, pstate
);
545 /* Check size of frame number. */
546 n
= SCM_FRAME_NUMBER (frame
);
547 for (i
= 0, j
= n
; j
> 0; ++i
) j
/= 10;
549 /* Number indentation. */
550 indent (nfield
- (i
? i
: 1), port
);
553 scm_iprin1 (SCM_MAKINUM (n
), port
, pstate
);
555 /* Real frame marker */
556 scm_putc (SCM_FRAME_REAL_P (frame
) ? '*' : ' ', port
);
559 indent (indentation
, port
);
561 if (SCM_FRAME_PROC_P (frame
))
562 /* Display an application. */
563 display_application (frame
, nfield
+ 1 + indentation
, sport
, port
, pstate
);
565 /* Display a special form. */
567 SCM source
= SCM_FRAME_SOURCE (frame
);
568 SCM copy
= (SCM_CONSP (source
)
569 ? scm_source_property (source
, scm_sym_copy
)
571 SCM umcopy
= (SCM_MEMOIZEDP (source
)
572 ? scm_unmemoize (source
)
574 display_frame_expr ("(",
575 SCM_CONSP (copy
) ? copy
: umcopy
,
577 nfield
+ 1 + indentation
,
582 scm_putc ('\n', port
);
584 /* Announce missing frames? */
585 if (SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
587 indent (nfield
+ 1 + indentation
, port
);
588 scm_puts ("...\n", port
);
592 struct display_backtrace_args
{
600 display_backtrace_body (struct display_backtrace_args
*a
)
601 #define FUNC_NAME "display_backtrace_body"
603 int n_frames
, beg
, end
, n
, i
, j
;
604 int nfield
, indent_p
, indentation
;
605 SCM frame
, sport
, print_state
;
607 scm_print_state
*pstate
;
609 a
->port
= SCM_COERCE_OUTPORT (a
->port
);
611 /* Argument checking and extraction. */
612 SCM_VALIDATE_STACK (1, a
->stack
);
613 SCM_VALIDATE_OPOUTPORT (2, a
->port
);
614 n_frames
= SCM_INUM (scm_stack_length (a
->stack
));
615 n
= SCM_INUMP (a
->depth
) ? SCM_INUM (a
->depth
) : SCM_BACKTRACE_DEPTH
;
618 beg
= SCM_INUMP (a
->first
) ? SCM_INUM (a
->first
) : 0;
626 if (SCM_INUMP (a
->first
))
628 beg
= SCM_INUM (a
->first
);
642 SCM_ASSERT (beg
>= 0 && beg
< n_frames
, a
->first
, SCM_ARG3
, s_display_backtrace
);
643 SCM_ASSERT (n
> 0, a
->depth
, SCM_ARG4
, s_display_backtrace
);
645 /* Create a string port used for adaptation of printing parameters. */
646 sport
= scm_mkstrport (SCM_INUM0
,
647 scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED
),
651 /* Create a print state for printing of frames. */
652 print_state
= scm_make_print_state ();
653 pstate
= SCM_PRINT_STATE (print_state
);
654 pstate
->writingp
= 1;
657 /* First find out if it's reasonable to do indentation. */
665 frame
= scm_stack_ref (a
->stack
, SCM_MAKINUM (beg
));
666 for (i
= 0, j
= 0; i
< n
; ++i
)
668 if (SCM_FRAME_REAL_P (frame
))
670 if (j
> SCM_BACKTRACE_INDENT
)
675 frame
= (SCM_BACKWARDS_P
676 ? SCM_FRAME_PREV (frame
)
677 : SCM_FRAME_NEXT (frame
));
681 /* Determine size of frame number field. */
682 j
= SCM_FRAME_NUMBER (scm_stack_ref (a
->stack
, SCM_MAKINUM (end
)));
683 for (i
= 0; j
> 0; ++i
) j
/= 10;
687 frame
= scm_stack_ref (a
->stack
, SCM_MAKINUM (beg
));
689 last_file
= SCM_UNDEFINED
;
690 for (i
= 0; i
< n
; ++i
)
692 if (!SCM_EQ_P (SCM_SHOW_FILE_NAME
, sym_base
))
693 display_backtrace_file (frame
, &last_file
, a
->port
, pstate
);
695 display_frame (frame
, nfield
, indentation
, sport
, a
->port
, pstate
);
696 if (indent_p
&& SCM_FRAME_EVAL_ARGS_P (frame
))
698 frame
= (SCM_BACKWARDS_P
?
699 SCM_FRAME_PREV (frame
) : SCM_FRAME_NEXT (frame
));
702 scm_remember_upto_here_1 (print_state
);
704 return SCM_UNSPECIFIED
;
708 SCM_DEFINE (scm_display_backtrace
, "display-backtrace", 2, 2, 0,
709 (SCM stack
, SCM port
, SCM first
, SCM depth
),
710 "Display a backtrace to the output port @var{port}. @var{stack}\n"
711 "is the stack to take the backtrace from, @var{first} specifies\n"
712 "where in the stack to start and @var{depth} how much frames\n"
713 "to display. Both @var{first} and @var{depth} can be @code{#f},\n"
714 "which means that default values will be used.")
715 #define FUNC_NAME s_scm_display_backtrace
717 struct display_backtrace_args a
;
718 struct display_error_handler_data data
;
723 data
.mode
= "backtrace";
725 scm_internal_catch (SCM_BOOL_T
,
726 (scm_t_catch_body
) display_backtrace_body
, &a
,
727 (scm_t_catch_handler
) display_error_handler
, &data
);
728 return SCM_UNSPECIFIED
;
732 SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var
, "has-shown-backtrace-hint?");
734 SCM_DEFINE (scm_backtrace
, "backtrace", 0, 0, 0,
736 "Display a backtrace of the stack saved by the last error\n"
737 "to the current output port.")
738 #define FUNC_NAME s_scm_backtrace
741 scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
));
742 if (!SCM_FALSEP (the_last_stack
))
744 scm_newline (scm_cur_outp
);
745 scm_puts ("Backtrace:\n", scm_cur_outp
);
746 scm_display_backtrace (the_last_stack
,
750 scm_newline (scm_cur_outp
);
751 if (SCM_FALSEP (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var
))
754 scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
756 "automatically if an error occurs in the future.\n",
758 SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var
, SCM_BOOL_T
);
763 scm_puts ("No backtrace available.\n", scm_cur_outp
);
765 return SCM_UNSPECIFIED
;
772 scm_init_backtrace ()
774 SCM f
= scm_make_fluid ();
775 scm_the_last_stack_fluid_var
= scm_c_define ("the-last-stack", f
);
777 #ifndef SCM_MAGIC_SNARFER
778 #include "libguile/backtrace.x"