1 /* Printing of backtraces and error messages
2 * Copyright (C) 1996 Mikael Djurfeldt
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, 675 Mass Ave, Cambridge, MA 02139, USA.
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice.
42 * The author can be reached at djurfeldt@nada.kth.se
43 * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
54 #include "backtrace.h"
56 /* {Error reporting and backtraces}
57 * (A first approximation.)
59 * Note that these functions shouldn't generate errors themselves.
64 #define SCM_ASSERT(_cond, _arg, _pos, _subr) \
69 static void display_header
SCM_P ((SCM source
, SCM port
));
71 display_header (source
, port
)
75 SCM fname
= (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
)
76 ? scm_source_property (source
, scm_i_filename
)
78 if (SCM_NIMP (fname
) && SCM_STRINGP (fname
))
80 scm_prin1 (fname
, port
, 0);
81 scm_gen_putc (':', port
);
82 scm_prin1 (scm_source_property (source
, scm_i_line
), port
, 0);
83 scm_gen_putc (':', port
);
84 scm_prin1 (scm_source_property (source
, scm_i_column
), port
, 0);
87 scm_gen_puts (scm_regular_string
, "ERROR", port
);
88 scm_gen_puts (scm_regular_string
, ": ", port
);
93 scm_display_error_message (message
, args
, port
)
102 if (SCM_IMP (message
) || !SCM_STRINGP (message
) || SCM_IMP (args
)
103 || !scm_list_p (args
))
105 scm_prin1 (message
, port
, 0);
106 scm_gen_putc ('\n', port
);
110 start
= SCM_CHARS (message
);
111 for (p
= start
; *p
!= '\0'; ++p
)
114 if (SCM_IMP (args
) || SCM_NCONSP (args
))
125 scm_gen_write (scm_regular_string
, start
, p
- start
- 1, port
);
126 scm_prin1 (SCM_CAR (args
), port
, writingp
);
127 args
= SCM_CDR (args
);
130 scm_gen_write (scm_regular_string
, start
, p
- start
, port
);
131 scm_gen_putc ('\n', port
);
134 static void display_expression
SCM_P ((SCM frame
, SCM pname
, SCM source
, SCM port
));
136 display_expression (frame
, pname
, source
, port
)
142 SCM print_state
= scm_make_print_state ();
143 scm_print_state
*pstate
= SCM_PRINT_STATE (print_state
);
144 pstate
->writingp
= 0;
148 if (SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
))
151 && SCM_FRAMEP (frame
)
152 && SCM_FRAME_EVAL_ARGS_P (frame
))
153 scm_gen_puts (scm_regular_string
, "While evaluating arguments to ", port
);
155 scm_gen_puts (scm_regular_string
, "In procedure ", port
);
156 scm_iprin1 (pname
, port
, pstate
);
157 if (SCM_NIMP (source
) && SCM_MEMOIZEDP (source
))
159 scm_gen_puts (scm_regular_string
, " in expression ", port
);
160 pstate
->writingp
= 1;
161 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
164 else if (SCM_NIMP (source
))
166 scm_gen_puts (scm_regular_string
, "In expression ", port
);
167 pstate
->writingp
= 1;
168 scm_iprin1 (scm_unmemoize (source
), port
, pstate
);
170 scm_gen_puts (scm_regular_string
, ":\n", port
);
171 scm_free_print_state (print_state
);
174 SCM_PROC(s_display_error
, "display-error", 6, 0, 0, scm_display_error
);
176 scm_display_error (stack
, port
, subr
, message
, args
, rest
)
184 SCM current_frame
= SCM_BOOL_F
;
185 SCM source
= SCM_BOOL_F
;
186 SCM pname
= SCM_BOOL_F
;
189 && SCM_STACKP (stack
)
190 && SCM_STACK_LENGTH (stack
) > 0)
192 current_frame
= scm_stack_ref (stack
, SCM_INUM0
);
193 source
= SCM_FRAME_SOURCE (current_frame
);
194 if (!(SCM_NIMP (source
) && SCM_MEMOIZEDP (source
)))
195 source
= SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame
));
196 if (SCM_FRAME_PROC_P (current_frame
)
197 && scm_procedure_p (SCM_FRAME_PROC (current_frame
)) == SCM_BOOL_T
)
198 pname
= scm_procedure_name (SCM_FRAME_PROC (current_frame
));
200 if (!(SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
)))
202 if ((SCM_NIMP (source
) && SCM_MEMOIZEDP (source
))
203 || (SCM_NIMP (pname
) && SCM_ROSTRINGP (pname
)))
205 display_header (source
, port
);
206 display_expression (current_frame
, pname
, source
, port
);
208 display_header (source
, port
);
209 scm_display_error_message (message
, args
, port
);
210 return SCM_UNSPECIFIED
;
213 static void indent
SCM_P ((int n
, SCM port
));
220 for (i
= 0; i
< n
; ++i
)
221 scm_gen_putc (' ', port
);
224 static void display_frame_expr
SCM_P ((char *hdr
, SCM exp
, char *tlr
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
));
226 display_frame_expr (hdr
, exp
, tlr
, indentation
, sport
, port
, pstate
)
233 scm_print_state
*pstate
;
235 if (SCM_NIMP (exp
) && SCM_CONSP (exp
))
237 scm_iprlist (hdr
, exp
, tlr
[0], port
, pstate
);
238 scm_gen_puts (scm_regular_string
, &tlr
[1], port
);
241 scm_iprin1 (exp
, port
, pstate
);
242 scm_gen_putc ('\n', port
);
245 static void display_application
SCM_P ((SCM frame
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
));
247 display_application (frame
, indentation
, sport
, port
, pstate
)
252 scm_print_state
*pstate
;
254 SCM proc
= SCM_FRAME_PROC (frame
);
255 SCM name
= (SCM_NFALSEP (scm_procedure_p (proc
))
256 ? scm_procedure_name (proc
)
258 display_frame_expr ("[",
259 scm_cons (SCM_NFALSEP (name
) ? name
: proc
,
260 SCM_FRAME_ARGS (frame
)),
261 SCM_FRAME_EVAL_ARGS_P (frame
) ? " ..." : "]",
268 SCM_PROC(s_display_application
, "display-application", 1, 1, 0, scm_display_application
);
271 scm_display_application (SCM frame
, SCM port
)
273 if (SCM_UNBNDP (port
))
275 if (SCM_FRAME_PROC_P (frame
))
276 /* Display an application. */
279 scm_print_state
*pstate
;
281 /* Create a print state for printing of frames. */
282 print_state
= scm_make_print_state ();
283 pstate
= SCM_PRINT_STATE (print_state
);
284 pstate
->writingp
= 1;
289 display_application (frame
, 0, SCM_BOOL_F
, port
, pstate
); /*fixme*/
296 static void display_frame
SCM_P ((SCM frame
, int nfield
, int indentation
, SCM sport
, SCM port
, scm_print_state
*pstate
));
298 display_frame (frame
, nfield
, indentation
, sport
, port
, pstate
)
304 scm_print_state
*pstate
;
308 /* Announce missing frames? */
309 if (!SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
311 indent (nfield
+ 1 + indentation
, port
);
312 scm_gen_puts (scm_regular_string
, "...\n", port
);
315 /* Check size of frame number. */
316 n
= SCM_FRAME_NUMBER (frame
);
317 for (i
= 0, j
= n
; j
> 0; ++i
) j
/= 10;
319 /* Number indentation. */
320 indent (nfield
- (i
? i
: 1), port
);
323 scm_iprin1 (SCM_MAKINUM (n
), port
, pstate
);
325 /* Real frame marker */
326 scm_gen_putc (SCM_FRAME_REAL_P (frame
) ? '*' : ' ', port
);
329 indent (indentation
, port
);
331 if (SCM_FRAME_PROC_P (frame
))
332 /* Display an application. */
333 display_application (frame
, nfield
+ 1 + indentation
, sport
, port
, pstate
);
335 /* Display a special form. */
337 SCM source
= SCM_FRAME_SOURCE (frame
);
338 SCM copy
= scm_source_property (source
, scm_i_copy
);
339 display_frame_expr ("(",
340 SCM_NIMP (copy
) && SCM_CONSP (copy
)
342 : scm_unmemoize (source
),
344 nfield
+ 1 + indentation
,
350 /* Announce missing frames? */
351 if (SCM_BACKWARDS_P
&& SCM_FRAME_OVERFLOW_P (frame
))
353 indent (nfield
+ 1 + indentation
, port
);
354 scm_gen_puts (scm_regular_string
, "...\n", port
);
358 SCM_PROC(s_display_backtrace
, "display-backtrace", 2, 2, 0, scm_display_backtrace
);
360 scm_display_backtrace (stack
, port
, first
, depth
)
366 int n_frames
, beg
, end
, n
, i
, j
;
367 int nfield
, indent_p
, indentation
;
368 SCM frame
, sport
, print_state
;
369 scm_print_state
*pstate
;
371 /* Argument checking and extraction. */
372 SCM_ASSERT (SCM_NIMP (stack
) && SCM_STACKP (stack
),
375 s_display_backtrace
);
376 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
),
379 s_display_backtrace
);
380 n_frames
= SCM_INUM (scm_stack_length (stack
));
381 n
= SCM_INUMP (depth
) ? SCM_INUM (depth
) : SCM_BACKTRACE_DEPTH
;
384 beg
= SCM_INUMP (first
) ? SCM_INUM (first
) : 0;
392 if (SCM_INUMP (first
))
394 beg
= SCM_INUM (first
);
408 SCM_ASSERT (beg
>= 0 && beg
< n_frames
, first
, SCM_ARG3
, s_display_backtrace
);
409 SCM_ASSERT (n
> 0, depth
, SCM_ARG4
, s_display_backtrace
);
411 /* Create a string port used for adaptation of printing parameters. */
412 sport
= scm_mkstrport (SCM_INUM0
,
413 scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED
),
415 s_display_backtrace
);
417 /* Create a print state for printing of frames. */
418 print_state
= scm_make_print_state ();
419 pstate
= SCM_PRINT_STATE (print_state
);
420 pstate
->writingp
= 1;
425 /* First find out if it's reasonable to do indentation. */
431 frame
= scm_stack_ref (stack
, SCM_MAKINUM (beg
));
432 for (i
= 0, j
= 0; i
< n
; ++i
)
434 if (SCM_FRAME_REAL_P (frame
))
436 if (j
> SCM_BACKTRACE_INDENT
)
441 frame
= (SCM_BACKWARDS_P
442 ? SCM_FRAME_PREV (frame
)
443 : SCM_FRAME_NEXT (frame
));
447 /* Determine size of frame number field. */
448 j
= SCM_FRAME_NUMBER (scm_stack_ref (stack
, SCM_MAKINUM (end
)));
449 for (i
= 0; j
> 0; ++i
) j
/= 10;
452 scm_gen_puts (scm_regular_string
, "Backtrace:\n", port
);
455 frame
= scm_stack_ref (stack
, SCM_MAKINUM (beg
));
457 display_frame (frame
, nfield
, indentation
, sport
, port
, pstate
);
458 for (i
= 1; i
< n
; ++i
)
460 if (indent_p
&& SCM_FRAME_EVAL_ARGS_P (frame
))
462 frame
= SCM_BACKWARDS_P
? SCM_FRAME_PREV (frame
) : SCM_FRAME_NEXT (frame
);
463 display_frame (frame
, nfield
, indentation
, sport
, port
, pstate
);
466 return SCM_UNSPECIFIED
;
469 SCM_VCELL (scm_has_shown_backtrace_hint_p_var
, "has-shown-backtrace-hint?");
471 SCM_PROC(s_backtrace
, "backtrace", 0, 0, 0, scm_backtrace
);
475 if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var
)))
477 scm_newline (scm_cur_outp
);
478 scm_display_backtrace (SCM_CDR (scm_the_last_stack_var
),
482 scm_newline (scm_cur_outp
);
483 if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var
))
486 scm_gen_puts (scm_regular_string
,
487 "Type \"(debug-enable 'backtrace)\" if you would like a backtrace
488 automatically if an error occurs in the future.\n",
490 SCM_SETCDR (scm_has_shown_backtrace_hint_p_var
, SCM_BOOL_T
);
495 scm_gen_puts (scm_regular_string
,
496 "No backtrace available.\n",
499 return SCM_UNSPECIFIED
;
505 scm_init_backtrace ()
507 scm_the_last_stack_var
= scm_sysintern ("the-last-stack", SCM_BOOL_F
);
509 #include "backtrace.x"