1 /* Printing of backtraces and error messages
2 * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library 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 GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
26 #include "libguile/_scm.h"
35 #include "libguile/stacks.h"
36 #include "libguile/srcprop.h"
37 #include "libguile/struct.h"
38 #include "libguile/strports.h"
39 #include "libguile/throw.h"
40 #include "libguile/fluids.h"
41 #include "libguile/ports.h"
42 #include "libguile/strings.h"
43 #include "libguile/dynwind.h"
45 #include "libguile/validate.h"
46 #include "libguile/lang.h"
47 #include "libguile/backtrace.h"
48 #include "libguile/filesys.h"
50 /* {Error reporting and backtraces}
52 * Note that these functions shouldn't generate errors themselves.
55 /* Print parameters for error messages. */
57 #define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7
58 #define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10
60 /* Print parameters for failing expressions in error messages.
61 * (See also `print_params' below for backtrace print parameters.)
64 #define DISPLAY_EXPRESSION_MAX_LEVEL 2
65 #define DISPLAY_EXPRESSION_MAX_LENGTH 3
68 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
72 SCM scm_the_last_stack_fluid_var
;
75 display_header (SCM source
, SCM port
)
77 if (SCM_MEMOIZEDP (source
))
79 SCM fname
= scm_source_property (source
, scm_sym_filename
);
80 SCM line
= scm_source_property (source
, scm_sym_line
);
81 SCM col
= scm_source_property (source
, scm_sym_column
);
83 /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
84 * filename with the source properties? Then we could in case of
85 * non-file ports give at least some more details than just
86 * "<unnamed port>". */
87 if (SCM_STRINGP (fname
))
88 scm_prin1 (fname
, port
, 0);
90 scm_puts ("<unnamed port>", port
);
92 if (scm_is_true (line
) && scm_is_true (col
))
95 scm_intprint (scm_to_long (line
) + 1, 10, port
);
97 scm_intprint (scm_to_long (col
) + 1, 10, port
);
101 scm_puts ("ERROR", port
);
102 scm_puts (": ", port
);
106 struct display_error_message_data
{
110 scm_print_state
*pstate
;
117 display_error_message (struct display_error_message_data
*d
)
119 if (SCM_STRINGP (d
->message
) && scm_is_true (scm_list_p (d
->args
)))
120 scm_simple_format (d
->port
, d
->message
, d
->args
);
122 scm_display (d
->message
, d
->port
);
123 scm_newline (d
->port
);
124 return SCM_UNSPECIFIED
;
128 before_display_error_message (struct display_error_message_data
*d
)
130 scm_print_state
*pstate
= d
->pstate
;
131 d
->old_fancyp
= pstate
->fancyp
;
132 d
->old_level
= pstate
->level
;
133 d
->old_length
= pstate
->length
;
135 pstate
->level
= DISPLAY_ERROR_MESSAGE_MAX_LEVEL
;
136 pstate
->length
= DISPLAY_ERROR_MESSAGE_MAX_LENGTH
;
140 after_display_error_message (struct display_error_message_data
*d
)
142 scm_print_state
*pstate
= d
->pstate
;
143 pstate
->fancyp
= d
->old_fancyp
;
144 pstate
->level
= d
->old_level
;
145 pstate
->length
= d
->old_length
;
149 scm_display_error_message (SCM message
, SCM args
, SCM port
)
151 struct display_error_message_data d
;
153 scm_print_state
*pstate
;
155 port
= scm_i_port_with_print_state (port
, SCM_UNDEFINED
);
156 print_state
= SCM_PORT_WITH_PS_PS (port
);
157 pstate
= SCM_PRINT_STATE (print_state
);
163 scm_internal_dynamic_wind ((scm_t_guard
) before_display_error_message
,
164 (scm_t_inner
) display_error_message
,
165 (scm_t_guard
) after_display_error_message
,
171 display_expression (SCM frame
, SCM pname
, SCM source
, SCM port
)
173 SCM print_state
= scm_make_print_state ();
174 scm_print_state
*pstate
= SCM_PRINT_STATE (print_state
);
175 pstate
->writingp
= 0;
177 pstate
->level
= DISPLAY_EXPRESSION_MAX_LEVEL
;
178 pstate
->length
= DISPLAY_EXPRESSION_MAX_LENGTH
;
179 if (SCM_SYMBOLP (pname
) || SCM_STRINGP (pname
))
181 if (SCM_FRAMEP (frame
)
182 && SCM_FRAME_EVAL_ARGS_P (frame
))
183 scm_puts ("While evaluating arguments to ", port
);
185 scm_puts ("In procedure ", port
);
186 scm_iprin1 (pname
, port
, pstate
);
187 if (SCM_MEMOIZEDP (source
))
189 scm_puts (" in expression ", port
);
190 pstate
->writingp
= 1;
191 scm_iprin1 (scm_i_unmemoize_expr (source
), port
, pstate
);
194 else if (SCM_MEMOIZEDP (source
))
196 scm_puts ("In expression ", port
);
197 pstate
->writingp
= 1;
198 scm_iprin1 (scm_i_unmemoize_expr (source
), port
, pstate
);
200 scm_puts (":\n", port
);
201 scm_free_print_state (print_state
);
204 struct display_error_args
{
214 display_error_body (struct display_error_args
*a
)
216 SCM current_frame
= SCM_BOOL_F
;
217 SCM source
= SCM_BOOL_F
;
218 SCM prev_frame
= SCM_BOOL_F
;
222 && SCM_STACKP (a
->stack
)
223 && SCM_STACK_LENGTH (a
->stack
) > 0)
225 current_frame
= scm_stack_ref (a
->stack
, SCM_INUM0
);
226 source
= SCM_FRAME_SOURCE (current_frame
);
227 prev_frame
= SCM_FRAME_PREV (current_frame
);
228 if (!SCM_MEMOIZEDP (source
) && scm_is_true (prev_frame
))
229 source
= SCM_FRAME_SOURCE (prev_frame
);
230 if (!SCM_SYMBOLP (pname
) && !SCM_STRINGP (pname
) && SCM_FRAME_PROC_P (current_frame
)
231 && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame
))))
232 pname
= scm_procedure_name (SCM_FRAME_PROC (current_frame
));
234 if (SCM_SYMBOLP (pname
) || SCM_STRINGP (pname
) || SCM_MEMOIZEDP (source
))
236 display_header (source
, a
->port
);
237 display_expression (current_frame
, pname
, source
, a
->port
);
239 display_header (source
, a
->port
);
240 scm_display_error_message (a
->message
, a
->args
, a
->port
);
241 return SCM_UNSPECIFIED
;
244 struct display_error_handler_data
{
249 /* This is the exception handler for error reporting routines.
250 Note that it is very important that this handler *doesn't* try to
251 print more than the error tag, since the error very probably is
252 caused by an erroneous print call-back routine. If we would
253 try to print all objects, we would enter an infinite loop. */
255 display_error_handler (struct display_error_handler_data
*data
,
256 SCM tag
, SCM args SCM_UNUSED
)
258 SCM print_state
= scm_make_print_state ();
259 scm_puts ("\nException during displaying of ", data
->port
);
260 scm_puts (data
->mode
, data
->port
);
261 scm_puts (": ", data
->port
);
262 scm_iprin1 (tag
, data
->port
, SCM_PRINT_STATE (print_state
));
263 scm_putc ('\n', data
->port
);
264 return SCM_UNSPECIFIED
;
268 /* The function scm_i_display_error prints out a detailed error message. This
269 * function will be called directly within libguile to signal error messages.
270 * No parameter checks will be performed by scm_i_display_error. Thus, User
271 * code should rather use the function scm_display_error.
274 scm_i_display_error (SCM stack
, SCM port
, SCM subr
, SCM message
, SCM args
, SCM rest
)
276 struct display_error_args a
;
277 struct display_error_handler_data data
;
286 scm_internal_catch (SCM_BOOL_T
,
287 (scm_t_catch_body
) display_error_body
, &a
,
288 (scm_t_catch_handler
) display_error_handler
, &data
);
292 SCM_DEFINE (scm_display_error
, "display-error", 6, 0, 0,
293 (SCM stack
, SCM port
, SCM subr
, SCM message
, SCM args
, SCM rest
),
294 "Display an error message to the output port @var{port}.\n"
295 "@var{stack} is the saved stack for the error, @var{subr} is\n"
296 "the name of the procedure in which the error occurred and\n"
297 "@var{message} is the actual error message, which may contain\n"
298 "formatting instructions. These will format the arguments in\n"
299 "the list @var{args} accordingly. @var{rest} is currently\n"
301 #define FUNC_NAME s_scm_display_error
303 SCM_VALIDATE_OUTPUT_PORT (2, port
);
305 scm_i_display_error (stack
, port
, subr
, message
, args
, rest
);
307 return SCM_UNSPECIFIED
;
317 static int n_print_params
= 9;
318 static print_params_t default_print_params
[] = {
322 { 1, 4 }, { 1, 3 }, { 1, 2 }
324 static print_params_t
*print_params
= default_print_params
;
327 SCM_DEFINE (scm_set_print_params_x
, "set-print-params!", 1, 0, 0,
329 "Set the print parameters to the values from @var{params}.\n"
330 "@var{params} must be a list of two-element lists which must\n"
331 "hold two integer values.")
332 #define FUNC_NAME s_scm_set_print_params_x
337 print_params_t
*new_params
;
339 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params
, n
);
340 for (ls
= params
; !SCM_NULL_OR_NIL_P (ls
); ls
= SCM_CDR (ls
))
341 SCM_ASSERT (scm_ilength (SCM_CAR (params
)) == 2
342 && scm_is_unsigned_integer (SCM_CAAR (ls
), 0, INT_MAX
)
343 && scm_is_unsigned_integer (SCM_CADAR (ls
), 0, INT_MAX
),
346 s_scm_set_print_params_x
);
347 new_params
= scm_malloc (n
* sizeof (print_params_t
));
348 if (print_params
!= default_print_params
)
350 print_params
= new_params
;
351 for (i
= 0; i
< n
; ++i
)
353 print_params
[i
].level
= scm_to_int (SCM_CAAR (params
));
354 print_params
[i
].length
= scm_to_int (SCM_CADAR (params
));
355 params
= SCM_CDR (params
);
358 return SCM_UNSPECIFIED
;
364 indent (int n
, SCM port
)
367 for (i
= 0; i
< n
; ++i
)
368 scm_putc (' ', port
);
372 display_frame_expr (char *hdr
, SCM exp
, char *tlr
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
)
376 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (sport
);
379 pstate
->length
= print_params
[i
].length
;
380 ptob
->seek (sport
, 0, SEEK_SET
);
383 pstate
->level
= print_params
[i
].level
- 1;
384 scm_iprlist (hdr
, exp
, tlr
[0], sport
, pstate
);
385 scm_puts (&tlr
[1], sport
);
389 pstate
->level
= print_params
[i
].level
;
390 scm_iprin1 (exp
, sport
, pstate
);
393 n
= ptob
->seek (sport
, 0, SEEK_CUR
);
396 while (indentation
+ n
> SCM_BACKTRACE_WIDTH
&& i
< n_print_params
);
397 ptob
->truncate (sport
, n
);
398 string
= scm_strport_to_string (sport
);
399 /* Remove control characters */
400 for (i
= 0; i
< n
; ++i
)
401 if (iscntrl ((int) (unsigned char) SCM_STRING_CHARS (string
)[i
]))
402 SCM_STRING_CHARS (string
)[i
] = ' ';
404 if (indentation
+ n
> SCM_BACKTRACE_WIDTH
)
406 n
= SCM_BACKTRACE_WIDTH
- indentation
;
407 SCM_STRING_CHARS (string
)[n
- 1] = '$';
410 scm_lfwrite (SCM_STRING_CHARS (string
), n
, port
);
414 display_application (SCM frame
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
)
416 SCM proc
= SCM_FRAME_PROC (frame
);
417 SCM name
= (scm_is_true (scm_procedure_p (proc
))
418 ? scm_procedure_name (proc
)
420 display_frame_expr ("[",
421 scm_cons (scm_is_true (name
) ? name
: proc
,
422 SCM_FRAME_ARGS (frame
)),
423 SCM_FRAME_EVAL_ARGS_P (frame
) ? " ..." : "]",
430 SCM_DEFINE (scm_display_application
, "display-application", 1, 2, 0,
431 (SCM frame
, SCM port
, SCM indent
),
432 "Display a procedure application @var{frame} to the output port\n"
433 "@var{port}. @var{indent} specifies the indentation of the\n"
435 #define FUNC_NAME s_scm_display_application
437 SCM_VALIDATE_FRAME (1, frame
);
438 if (SCM_UNBNDP (port
))
441 SCM_VALIDATE_OPOUTPORT (2, port
);
442 if (SCM_UNBNDP (indent
))
445 if (SCM_FRAME_PROC_P (frame
))
446 /* Display an application. */
448 SCM sport
, print_state
;
449 scm_print_state
*pstate
;
451 /* Create a string port used for adaptation of printing parameters. */
452 sport
= scm_mkstrport (SCM_INUM0
,
453 scm_make_string (scm_from_int (240),
458 /* Create a print state for printing of frames. */
459 print_state
= scm_make_print_state ();
460 pstate
= SCM_PRINT_STATE (print_state
);
461 pstate
->writingp
= 1;
464 display_application (frame
, scm_to_int (indent
), sport
, port
, pstate
);
472 SCM_SYMBOL (sym_base
, "base");
475 display_backtrace_get_file_line (SCM frame
, SCM
*file
, SCM
*line
)
477 SCM source
= SCM_FRAME_SOURCE (frame
);
478 *file
= SCM_MEMOIZEDP (source
) ? scm_source_property (source
, scm_sym_filename
) : SCM_BOOL_F
;
479 *line
= (SCM_MEMOIZEDP (source
)) ? scm_source_property (source
, scm_sym_line
) : SCM_BOOL_F
;
483 display_backtrace_file (frame
, last_file
, port
, pstate
)
487 scm_print_state
*pstate
;
491 display_backtrace_get_file_line (frame
, &file
, &line
);
493 if (scm_is_eq (file
, *last_file
))
498 scm_puts ("In ", port
);
499 if (scm_is_false (file
))
500 if (scm_is_false (line
))
501 scm_puts ("unknown file", port
);
503 scm_puts ("current input", port
);
506 pstate
->writingp
= 0;
507 scm_iprin1 (file
, port
, pstate
);
508 pstate
->writingp
= 1;
510 scm_puts (":\n", port
);
514 display_backtrace_file_and_line (SCM frame
, SCM port
, scm_print_state
*pstate
)
518 display_backtrace_get_file_line (frame
, &file
, &line
);
520 if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME
), sym_base
))
522 if (scm_is_false (file
))
524 if (scm_is_false (line
))
525 scm_putc ('?', port
);
527 scm_puts ("<stdin>", port
);
531 pstate
-> writingp
= 0;
533 scm_iprin1 (SCM_STRINGP (file
) ? scm_basename (file
, SCM_UNDEFINED
) : file
,
536 scm_iprin1 (file
, port
, pstate
);
538 pstate
-> writingp
= 1;
541 scm_putc (':', port
);
543 else if (scm_is_true (line
))
546 for (i
= scm_to_int (line
)+1; i
> 0; i
= i
/10, j
++)
551 if (scm_is_false (line
))
552 scm_puts (" ?", port
);
554 scm_intprint (scm_to_int (line
) + 1, 10, port
);
555 scm_puts (": ", port
);
559 display_frame (SCM frame
, int nfield
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
)
563 /* Announce missing frames? */
564 if (!SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
566 indent (nfield
+ 1 + indentation
, port
);
567 scm_puts ("...\n", port
);
570 /* display file name and line number */
571 if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME
)))
572 display_backtrace_file_and_line (frame
, port
, pstate
);
574 /* Check size of frame number. */
575 n
= SCM_FRAME_NUMBER (frame
);
576 for (i
= 0, j
= n
; j
> 0; ++i
) j
/= 10;
578 /* Number indentation. */
579 indent (nfield
- (i
? i
: 1), port
);
582 scm_iprin1 (scm_from_int (n
), port
, pstate
);
584 /* Real frame marker */
585 scm_putc (SCM_FRAME_REAL_P (frame
) ? '*' : ' ', port
);
588 indent (indentation
, port
);
590 if (SCM_FRAME_PROC_P (frame
))
591 /* Display an application. */
592 display_application (frame
, nfield
+ 1 + indentation
, sport
, port
, pstate
);
594 /* Display a special form. */
596 SCM source
= SCM_FRAME_SOURCE (frame
);
597 SCM copy
= (SCM_CONSP (source
)
598 ? scm_source_property (source
, scm_sym_copy
)
600 SCM umcopy
= (SCM_MEMOIZEDP (source
)
601 ? scm_i_unmemoize_expr (source
)
603 display_frame_expr ("(",
604 SCM_CONSP (copy
) ? copy
: umcopy
,
606 nfield
+ 1 + indentation
,
611 scm_putc ('\n', port
);
613 /* Announce missing frames? */
614 if (SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
616 indent (nfield
+ 1 + indentation
, port
);
617 scm_puts ("...\n", port
);
621 struct display_backtrace_args
{
629 display_backtrace_body (struct display_backtrace_args
*a
)
630 #define FUNC_NAME "display_backtrace_body"
632 int n_frames
, beg
, end
, n
, i
, j
;
633 int nfield
, indent_p
, indentation
;
634 SCM frame
, sport
, print_state
;
636 scm_print_state
*pstate
;
638 a
->port
= SCM_COERCE_OUTPORT (a
->port
);
640 /* Argument checking and extraction. */
641 SCM_VALIDATE_STACK (1, a
->stack
);
642 SCM_VALIDATE_OPOUTPORT (2, a
->port
);
643 n_frames
= scm_to_int (scm_stack_length (a
->stack
));
644 n
= scm_is_integer (a
->depth
) ? scm_to_int (a
->depth
) : SCM_BACKTRACE_DEPTH
;
647 beg
= scm_is_integer (a
->first
) ? scm_to_int (a
->first
) : 0;
655 if (scm_is_integer (a
->first
))
657 beg
= scm_to_int (a
->first
);
671 SCM_ASSERT (beg
>= 0 && beg
< n_frames
, a
->first
, SCM_ARG3
, s_display_backtrace
);
672 SCM_ASSERT (n
> 0, a
->depth
, SCM_ARG4
, s_display_backtrace
);
674 /* Create a string port used for adaptation of printing parameters. */
675 sport
= scm_mkstrport (SCM_INUM0
,
676 scm_make_string (scm_from_int (240), SCM_UNDEFINED
),
680 /* Create a print state for printing of frames. */
681 print_state
= scm_make_print_state ();
682 pstate
= SCM_PRINT_STATE (print_state
);
683 pstate
->writingp
= 1;
686 /* First find out if it's reasonable to do indentation. */
694 frame
= scm_stack_ref (a
->stack
, scm_from_int (beg
));
695 for (i
= 0, j
= 0; i
< n
; ++i
)
697 if (SCM_FRAME_REAL_P (frame
))
699 if (j
> SCM_BACKTRACE_INDENT
)
704 frame
= (SCM_BACKWARDS_P
705 ? SCM_FRAME_PREV (frame
)
706 : SCM_FRAME_NEXT (frame
));
710 /* Determine size of frame number field. */
711 j
= SCM_FRAME_NUMBER (scm_stack_ref (a
->stack
, scm_from_int (end
)));
712 for (i
= 0; j
> 0; ++i
) j
/= 10;
716 frame
= scm_stack_ref (a
->stack
, scm_from_int (beg
));
718 last_file
= SCM_UNDEFINED
;
719 for (i
= 0; i
< n
; ++i
)
721 if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME
), sym_base
))
722 display_backtrace_file (frame
, &last_file
, a
->port
, pstate
);
724 display_frame (frame
, nfield
, indentation
, sport
, a
->port
, pstate
);
725 if (indent_p
&& SCM_FRAME_EVAL_ARGS_P (frame
))
727 frame
= (SCM_BACKWARDS_P
?
728 SCM_FRAME_PREV (frame
) : SCM_FRAME_NEXT (frame
));
731 scm_remember_upto_here_1 (print_state
);
733 return SCM_UNSPECIFIED
;
737 SCM_DEFINE (scm_display_backtrace
, "display-backtrace", 2, 2, 0,
738 (SCM stack
, SCM port
, SCM first
, SCM depth
),
739 "Display a backtrace to the output port @var{port}. @var{stack}\n"
740 "is the stack to take the backtrace from, @var{first} specifies\n"
741 "where in the stack to start and @var{depth} how much frames\n"
742 "to display. Both @var{first} and @var{depth} can be @code{#f},\n"
743 "which means that default values will be used.")
744 #define FUNC_NAME s_scm_display_backtrace
746 struct display_backtrace_args a
;
747 struct display_error_handler_data data
;
752 data
.mode
= "backtrace";
754 scm_internal_catch (SCM_BOOL_T
,
755 (scm_t_catch_body
) display_backtrace_body
, &a
,
756 (scm_t_catch_handler
) display_error_handler
, &data
);
757 return SCM_UNSPECIFIED
;
761 SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var
, "has-shown-backtrace-hint?");
763 SCM_DEFINE (scm_backtrace
, "backtrace", 0, 0, 0,
765 "Display a backtrace of the stack saved by the last error\n"
766 "to the current output port.")
767 #define FUNC_NAME s_scm_backtrace
770 scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
));
771 if (scm_is_true (the_last_stack
))
773 scm_newline (scm_cur_outp
);
774 scm_puts ("Backtrace:\n", scm_cur_outp
);
775 scm_display_backtrace (the_last_stack
,
779 scm_newline (scm_cur_outp
);
780 if (scm_is_false (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var
))
783 scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
785 "automatically if an error occurs in the future.\n",
787 SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var
, SCM_BOOL_T
);
792 scm_puts ("No backtrace available.\n", scm_cur_outp
);
794 return SCM_UNSPECIFIED
;
801 scm_init_backtrace ()
803 SCM f
= scm_make_fluid ();
804 scm_the_last_stack_fluid_var
= scm_c_define ("the-last-stack", f
);
806 #include "libguile/backtrace.x"