1 /* Printing of backtraces and error messages
2 * Copyright (C) 1996, 1997, 1998, 1999 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 */
46 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
47 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
67 #include "backtrace.h"
69 /* {Error reporting and backtraces}
70 * (A first approximation.)
72 * Note that these functions shouldn't generate errors themselves.
77 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
82 SCM scm_the_last_stack_fluid
;
85 display_header (SCM source
, SCM port
)
87 SCM fname
= (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
)
88 ? scm_source_property (source
, scm_sym_filename
)
90 if (SCM_NIMP (fname
) && SCM_STRINGP (fname
))
92 scm_prin1 (fname
, port
, 0);
94 scm_intprint (SCM_INUM (scm_source_property (source
, scm_sym_line
)) + 1,
98 scm_intprint (SCM_INUM (scm_source_property (source
, scm_sym_column
)) + 1,
103 scm_puts ("ERROR", port
);
104 scm_puts (": ", port
);
109 scm_display_error_message (SCM message
, SCM args
, SCM port
)
115 if (SCM_IMP (message
) || !SCM_ROSTRINGP (message
) || SCM_IMP (args
)
116 || !scm_list_p (args
))
118 scm_prin1 (message
, port
, 0);
119 scm_putc ('\n', port
);
123 SCM_COERCE_SUBSTR (message
);
124 start
= SCM_ROCHARS (message
);
125 for (p
= start
; *p
!= '\0'; ++p
)
128 if (SCM_IMP (args
) || SCM_NCONSP (args
))
139 scm_lfwrite (start
, p
- start
- 1, port
);
140 scm_prin1 (SCM_CAR (args
), port
, writingp
);
141 args
= SCM_CDR (args
);
144 scm_lfwrite (start
, p
- start
, port
);
145 scm_putc ('\n', port
);
149 display_expression (SCM frame
,SCM pname
,SCM source
,SCM port
)
151 SCM print_state
= scm_make_print_state ();
152 scm_print_state
*pstate
= SCM_PRINT_STATE (print_state
);
153 pstate
->writingp
= 0;
157 if (SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
))
160 && SCM_FRAMEP (frame
)
161 && SCM_FRAME_EVAL_ARGS_P (frame
))
162 scm_puts ("While evaluating arguments to ", port
);
164 scm_puts ("In procedure ", port
);
165 scm_iprin1 (pname
, port
, pstate
);
166 if (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
))
168 scm_puts (" in expression ", port
);
169 pstate
->writingp
= 1;
170 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
173 else if (SCM_NIMP (source
))
175 scm_puts ("In expression ", port
);
176 pstate
->writingp
= 1;
177 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
179 scm_puts (":\n", port
);
180 scm_free_print_state (print_state
);
183 struct display_error_args
{
193 display_error_body (struct display_error_args
*a
)
195 SCM current_frame
= SCM_BOOL_F
;
196 SCM source
= SCM_BOOL_F
;
197 SCM pname
= SCM_BOOL_F
;
198 SCM prev_frame
= SCM_BOOL_F
;
201 && SCM_NIMP (a
->stack
)
202 && SCM_STACKP (a
->stack
)
203 && SCM_STACK_LENGTH (a
->stack
) > 0)
205 current_frame
= scm_stack_ref (a
->stack
, SCM_INUM0
);
206 source
= SCM_FRAME_SOURCE (current_frame
);
207 prev_frame
= SCM_FRAME_PREV (current_frame
);
208 if (!(SCM_NIMP (source
) && SCM_MEMOIZEDP (source
))
209 && prev_frame
!= SCM_BOOL_F
)
210 source
= SCM_FRAME_SOURCE (prev_frame
);
211 if (SCM_FRAME_PROC_P (current_frame
)
212 && scm_procedure_p (SCM_FRAME_PROC (current_frame
)) == SCM_BOOL_T
)
213 pname
= scm_procedure_name (SCM_FRAME_PROC (current_frame
));
215 if (!(SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
)))
217 if ((SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
))
218 || (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
)))
220 display_header (source
, a
->port
);
221 display_expression (current_frame
, pname
, source
, a
->port
);
223 display_header (source
, a
->port
);
224 scm_display_error_message (a
->message
, a
->args
, a
->port
);
225 return SCM_UNSPECIFIED
;
228 struct display_error_handler_data
{
233 /* This is the exception handler for error reporting routines.
234 Note that it is very important that this handler *doesn't* try to
235 print more than the error tag, since the error very probably is
236 caused by an erroneous print call-back routine. If we would
237 tru to print all objects, we would enter an infinite loop. */
239 display_error_handler (struct display_error_handler_data
*data
,
242 SCM print_state
= scm_make_print_state ();
243 scm_puts ("\nException during displaying of ", data
->port
);
244 scm_puts (data
->mode
, data
->port
);
245 scm_puts (": ", data
->port
);
246 scm_iprin1 (tag
, data
->port
, SCM_PRINT_STATE (print_state
));
247 scm_putc ('\n', data
->port
);
248 return SCM_UNSPECIFIED
;
251 GUILE_PROC(scm_display_error
, "display-error", 6, 0, 0,
252 (SCM stack
, SCM port
, SCM subr
, SCM message
, SCM args
, SCM rest
),
254 #define FUNC_NAME s_scm_display_error
256 struct display_error_args a
;
257 struct display_error_handler_data data
;
266 scm_internal_catch (SCM_BOOL_T
,
267 (scm_catch_body_t
) display_error_body
, &a
,
268 (scm_catch_handler_t
) display_error_handler
, &data
);
269 return SCM_UNSPECIFIED
;
278 static int n_print_params
= 9;
279 static print_params_t default_print_params
[] = {
283 { 1, 4 }, { 1, 3 }, { 1, 2 }
285 static print_params_t
*print_params
= default_print_params
;
288 GUILE_PROC(scm_set_print_params_x
, "set-print-params!", 1, 0, 0,
291 #define FUNC_NAME s_scm_set_print_params_x
293 int i
, n
= scm_ilength (params
);
295 print_params_t
*new_params
;
296 SCM_ASSERT (n
>= 1, params
, SCM_ARG2
, FUNC_NAME
);
297 for (ls
= params
; SCM_NIMP (ls
); ls
= SCM_CDR (ls
))
298 SCM_ASSERT (scm_ilength (SCM_CAR (params
)) == 2
299 && SCM_INUMP (SCM_CAAR (ls
))
300 && SCM_INUM (SCM_CAAR (ls
)) >= 0
301 && SCM_INUMP (SCM_CADAR (ls
))
302 && SCM_INUM (SCM_CADAR (ls
)) >= 0,
305 s_scm_set_print_params_x
);
306 new_params
= scm_must_malloc (n
* sizeof (print_params_t
),
308 if (print_params
!= default_print_params
)
309 scm_must_free (print_params
);
310 print_params
= new_params
;
311 for (i
= 0; i
< n
; ++i
)
313 print_params
[i
].level
= SCM_INUM (SCM_CAAR (params
));
314 print_params
[i
].length
= SCM_INUM (SCM_CADAR (params
));
315 params
= SCM_CDR (params
);
318 return SCM_UNSPECIFIED
;
324 indent (int n
, SCM port
)
327 for (i
= 0; i
< n
; ++i
)
328 scm_putc (' ', port
);
332 display_frame_expr (char *hdr
,SCM exp
,char *tlr
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
336 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (sport
);
339 pstate
->length
= print_params
[i
].length
;
340 ptob
->seek (sport
, 0, SEEK_SET
);
341 if (SCM_NIMP (exp
) && SCM_CONSP (exp
))
343 pstate
->level
= print_params
[i
].level
- 1;
344 scm_iprlist (hdr
, exp
, tlr
[0], sport
, pstate
);
345 scm_puts (&tlr
[1], sport
);
349 pstate
->level
= print_params
[i
].level
;
350 scm_iprin1 (exp
, sport
, pstate
);
353 n
= ptob
->seek (sport
, 0, SEEK_CUR
);
356 while (indentation
+ n
> SCM_BACKTRACE_WIDTH
&& i
< n_print_params
);
357 ptob
->truncate (sport
, n
);
358 string
= scm_strport_to_string (sport
);
359 /* Remove control characters */
360 for (i
= 0; i
< n
; ++i
)
361 if (iscntrl (SCM_CHARS (string
)[i
]))
362 SCM_CHARS (string
)[i
] = ' ';
364 if (indentation
+ n
> SCM_BACKTRACE_WIDTH
)
366 n
= SCM_BACKTRACE_WIDTH
- indentation
;
367 SCM_CHARS (string
)[n
- 1] = '$';
370 scm_lfwrite (SCM_CHARS (string
), n
, port
);
374 display_application (SCM frame
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
376 SCM proc
= SCM_FRAME_PROC (frame
);
377 SCM name
= (SCM_NFALSEP (scm_procedure_p (proc
))
378 ? scm_procedure_name (proc
)
380 display_frame_expr ("[",
381 scm_cons (SCM_NFALSEP (name
) ? name
: proc
,
382 SCM_FRAME_ARGS (frame
)),
383 SCM_FRAME_EVAL_ARGS_P (frame
) ? " ..." : "]",
390 GUILE_PROC(scm_display_application
, "display-application", 1, 2, 0,
391 (SCM frame
, SCM port
, SCM indent
),
393 #define FUNC_NAME s_scm_display_application
395 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
396 frame
, SCM_ARG1
, s_display_application
);
397 if (SCM_UNBNDP (port
))
400 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
),
401 port
, SCM_ARG2
, s_display_application
);
402 if (SCM_UNBNDP (indent
))
405 SCM_ASSERT (SCM_INUMP (indent
), indent
, SCM_ARG3
, s_display_application
);
407 if (SCM_FRAME_PROC_P (frame
))
408 /* Display an application. */
410 SCM sport
, print_state
;
411 scm_print_state
*pstate
;
413 /* Create a string port used for adaptation of printing parameters. */
414 sport
= scm_mkstrport (SCM_INUM0
,
415 scm_make_string (SCM_MAKINUM (240),
420 /* Create a print state for printing of frames. */
421 print_state
= scm_make_print_state ();
422 pstate
= SCM_PRINT_STATE (print_state
);
423 pstate
->writingp
= 1;
426 display_application (frame
, SCM_INUM (indent
), sport
, port
, pstate
);
435 display_frame (SCM frame
,int nfield
,int indentation
,SCM sport
,SCM port
,scm_print_state
*pstate
)
439 /* Announce missing frames? */
440 if (!SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
442 indent (nfield
+ 1 + indentation
, port
);
443 scm_puts ("...\n", port
);
446 /* Check size of frame number. */
447 n
= SCM_FRAME_NUMBER (frame
);
448 for (i
= 0, j
= n
; j
> 0; ++i
) j
/= 10;
450 /* Number indentation. */
451 indent (nfield
- (i
? i
: 1), port
);
454 scm_iprin1 (SCM_MAKINUM (n
), port
, pstate
);
456 /* Real frame marker */
457 scm_putc (SCM_FRAME_REAL_P (frame
) ? '*' : ' ', port
);
460 indent (indentation
, port
);
462 if (SCM_FRAME_PROC_P (frame
))
463 /* Display an application. */
464 display_application (frame
, nfield
+ 1 + indentation
, sport
, port
, pstate
);
466 /* Display a special form. */
468 SCM source
= SCM_FRAME_SOURCE (frame
);
469 SCM copy
= (SCM_NIMP (source
) && SCM_CONSP (source
)
470 ? scm_source_property (source
, scm_sym_copy
)
472 SCM umcopy
= (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
)
473 ? scm_unmemoize (source
)
475 display_frame_expr ("(",
476 SCM_NIMP (copy
) && SCM_CONSP (copy
) ? copy
: umcopy
,
478 nfield
+ 1 + indentation
,
483 scm_putc ('\n', port
);
485 /* Announce missing frames? */
486 if (SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
488 indent (nfield
+ 1 + indentation
, port
);
489 scm_puts ("...\n", port
);
493 struct display_backtrace_args
{
501 display_backtrace_body(struct display_backtrace_args
*a
)
502 #define FUNC_NAME "display_backtrace_body"
504 int n_frames
, beg
, end
, n
, i
, j
;
505 int nfield
, indent_p
, indentation
;
506 SCM frame
, sport
, print_state
;
507 scm_print_state
*pstate
;
509 a
->port
= SCM_COERCE_OUTPORT (a
->port
);
511 /* Argument checking and extraction. */
512 SCM_ASSERT (SCM_NIMP (a
->stack
) && SCM_STACKP (a
->stack
),
515 s_display_backtrace
);
516 SCM_ASSERT (SCM_NIMP (a
->port
) && SCM_OPOUTPORTP (a
->port
),
519 s_display_backtrace
);
520 n_frames
= SCM_INUM (scm_stack_length (a
->stack
));
521 n
= SCM_INUMP (a
->depth
) ? SCM_INUM (a
->depth
) : SCM_BACKTRACE_DEPTH
;
524 beg
= SCM_INUMP (a
->first
) ? SCM_INUM (a
->first
) : 0;
532 if (SCM_INUMP (a
->first
))
534 beg
= SCM_INUM (a
->first
);
548 SCM_ASSERT (beg
>= 0 && beg
< n_frames
, a
->first
, SCM_ARG3
, s_display_backtrace
);
549 SCM_ASSERT (n
> 0, a
->depth
, SCM_ARG4
, s_display_backtrace
);
551 /* Create a string port used for adaptation of printing parameters. */
552 sport
= scm_mkstrport (SCM_INUM0
,
553 scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED
),
557 /* Create a print state for printing of frames. */
558 print_state
= scm_make_print_state ();
559 pstate
= SCM_PRINT_STATE (print_state
);
560 pstate
->writingp
= 1;
563 /* First find out if it's reasonable to do indentation. */
569 frame
= scm_stack_ref (a
->stack
, SCM_MAKINUM (beg
));
570 for (i
= 0, j
= 0; i
< n
; ++i
)
572 if (SCM_FRAME_REAL_P (frame
))
574 if (j
> SCM_BACKTRACE_INDENT
)
579 frame
= (SCM_BACKWARDS_P
580 ? SCM_FRAME_PREV (frame
)
581 : SCM_FRAME_NEXT (frame
));
585 /* Determine size of frame number field. */
586 j
= SCM_FRAME_NUMBER (scm_stack_ref (a
->stack
, SCM_MAKINUM (end
)));
587 for (i
= 0; j
> 0; ++i
) j
/= 10;
591 frame
= scm_stack_ref (a
->stack
, SCM_MAKINUM (beg
));
593 display_frame (frame
, nfield
, indentation
, sport
, a
->port
, pstate
);
594 for (i
= 1; i
< n
; ++i
)
596 if (indent_p
&& SCM_FRAME_EVAL_ARGS_P (frame
))
598 frame
= SCM_BACKWARDS_P
? SCM_FRAME_PREV (frame
) : SCM_FRAME_NEXT (frame
);
599 display_frame (frame
, nfield
, indentation
, sport
, a
->port
, pstate
);
602 return SCM_UNSPECIFIED
;
606 GUILE_PROC(scm_display_backtrace
, "display-backtrace", 2, 2, 0,
607 (SCM stack
, SCM port
, SCM first
, SCM depth
),
609 #define FUNC_NAME s_scm_display_backtrace
611 struct display_backtrace_args a
;
612 struct display_error_handler_data data
;
617 data
.mode
= "backtrace";
619 scm_internal_catch (SCM_BOOL_T
,
620 (scm_catch_body_t
) display_backtrace_body
, &a
,
621 (scm_catch_handler_t
) display_error_handler
, &data
);
622 return SCM_UNSPECIFIED
;
626 SCM_VCELL (scm_has_shown_backtrace_hint_p_var
, "has-shown-backtrace-hint?");
628 GUILE_PROC(scm_backtrace
, "backtrace", 0, 0, 0,
631 #define FUNC_NAME s_scm_backtrace
633 SCM the_last_stack
= scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid
));
634 if (SCM_NFALSEP (the_last_stack
))
636 scm_newline (scm_cur_outp
);
637 scm_puts ("Backtrace:\n", scm_cur_outp
);
638 scm_display_backtrace (the_last_stack
,
642 scm_newline (scm_cur_outp
);
643 if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var
))
646 scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
648 "automatically if an error occurs in the future.\n",
650 SCM_SETCDR (scm_has_shown_backtrace_hint_p_var
, SCM_BOOL_T
);
655 scm_puts ("No backtrace available.\n", scm_cur_outp
);
657 return SCM_UNSPECIFIED
;
664 scm_init_backtrace ()
666 SCM f
= scm_make_fluid ();
667 scm_the_last_stack_fluid
= scm_sysintern ("the-last-stack", f
);
669 #include "backtrace.x"