[bpt/guile.git] / libguile / backtrace.c

/* 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;
}

\f

void
scm_init_backtrace ()
{
#include "backtrace.x"
}
Commit	Line	Data
ab4f3efb MD	1	/* Printing of backtraces and error messages
	2	* Copyright (C) 1996 Mikael Djurfeldt
	3	*
	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)
	7	* any later version.
	8	*
	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.
	13	*
	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.
	17	*
	18	* As a special exception, the Free Software Foundation gives permission
	19	* for additional uses of the text contained in its release of GUILE.
	20	*
	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.
	26	*
	27	* This exception does not however invalidate any other reasons why
	28	* the executable file might be covered by the GNU General Public License.
	29	*
	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.
	37	*
	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.
	41	*
	42	* The author can be reached at djurfeldt@nada.kth.se
	43	* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
	44	*/
	45
	46	#include <stdio.h>
	47	#include "_scm.h"
	48	#include "stacks.h"
	49	#include "srcprop.h"
	50	#include "genio.h"
	51	#include "struct.h"
	52	#include "strports.h"
	53
	54	#include "backtrace.h"
	55
	56	/* {Error reporting and backtraces}
	57	* (A first approximation.)
	58	*
	59	* Note that these functions shouldn't generate errors themselves.
	60	*/
	61
	62	#ifndef SCM_RECKLESS
	63	#undef SCM_ASSERT
	64	#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
65	if (!(_cond)) \
66	return SCM_BOOL_F;
67	#endif
68
69	static void display_header SCM_P ((SCM source, SCM port));
70	static void
71	display_header (source, port)
72	SCM source;
73	SCM port;
74	{
75	SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
76	? scm_source_property (source, scm_i_filename)
77	: SCM_BOOL_F);
78	if (SCM_NIMP (fname) && SCM_STRINGP (fname))
79	{
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);
85	}
86	else
87	scm_gen_puts (scm_regular_string, "ERROR", port);
88	scm_gen_puts (scm_regular_string, ": ", port);
89	}
90
91	static void display_error_message SCM_P ((SCM message, SCM args, SCM port));
92	static void
93	display_error_message (message, args, port)
94	SCM message;
95	SCM args;
96	SCM port;
97	{
98	int writingp;
99	char *start;
100	char *p;
101
102	if (!SCM_STRINGP (message) \|\| SCM_IMP (args) \|\| !scm_list_p (args))
103	{
104	scm_prin1 (message, port, 0);
105	scm_gen_putc ('\n', port);
106	return;
107	}
108
109	start = SCM_CHARS (message);
110	for (p = start; *p != '\0'; ++p)
111	if (*p == '%')
112	{
113	if (SCM_IMP (args) \|\| SCM_NCONSP (args))
114	continue;
115
116	++p;
117	if (*p == 's')
118	writingp = 0;
119	else if (*p == 'S')
120	writingp = 1;
121	else
122	continue;
123
124	scm_gen_write (scm_regular_string, start, p - start - 1, port);
125	scm_prin1 (SCM_CAR (args), port, writingp);
126	args = SCM_CDR (args);
127	start = p + 1;
128	}
129	scm_gen_write (scm_regular_string, start, p - start, port);
130	scm_gen_putc ('\n', port);
131	}
132
133	static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
134	static void
135	display_expression (frame, pname, source, port)
136	SCM frame;
137	SCM pname;
138	SCM source;
139	SCM port;
140	{
141	SCM print_state = scm_make_print_state ();
142	scm_print_state *pstate = SCM_PRINT_STATE (print_state);
143	pstate->writingp = 0;
144	pstate->fancyp = 1;
145	pstate->level = 2;
146	pstate->length = 3;
147	if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
148	{
149	if (SCM_NIMP (frame)
150	&& SCM_FRAMEP (frame)
151	&& SCM_FRAME_EVAL_ARGS_P (frame))
152	scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
153	else
154	scm_gen_puts (scm_regular_string, "In procedure ", port);
155	scm_iprin1 (pname, port, pstate);
156	if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
157	{
158	scm_gen_puts (scm_regular_string, " in expression ", port);
159	pstate->writingp = 1;
160	scm_iprin1 (scm_unmemoize (source), port, pstate);
161	}
162	}
163	else if (SCM_NIMP (source))
164	{
165	scm_gen_puts (scm_regular_string, "In expression ", port);
166	pstate->writingp = 1;
167	scm_iprin1 (scm_unmemoize (source), port, pstate);
168	}
169	scm_gen_puts (scm_regular_string, ":\n", port);
170	scm_free_print_state (print_state);
171	}
172
173	SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
174	SCM
175	scm_display_error (stack, port, subr, message, args, rest)
176	SCM stack;
177	SCM port;
178	SCM subr;
179	SCM message;
180	SCM args;
181	SCM rest;
182	{
183	SCM current_frame = SCM_BOOL_F;
184	SCM source = SCM_BOOL_F;
185	SCM pname = SCM_BOOL_F;
186	if (SCM_DEBUGGINGP && SCM_NIMP (stack) && SCM_STACKP (stack))
187	{
188	current_frame = scm_stack_ref (stack, SCM_INUM0);
189	source = SCM_FRAME_SOURCE (current_frame);
190	if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
191	source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
192	if (SCM_FRAME_PROC_P (current_frame)
193	&& scm_procedure_p (SCM_FRAME_PROC (current_frame)))
194	pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
195	}
196	if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
197	pname = subr;
198	if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
199	\|\| (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
200	{
201	display_header (source, port);
202	display_expression (current_frame, pname, source, port);
203	}
204	display_header (source, port);
205	display_error_message (message, args, port);
206	return SCM_UNSPECIFIED;
207	}
208
209	static void indent SCM_P ((int n, SCM port));
210	static void
211	indent (n, port)
212	int n;
213	SCM port;
214	{
215	int i;
216	for (i = 0; i < n; ++i)
217	scm_gen_putc (' ', port);
218	}
219
220	static void display_frame_expr SCM_P ((char hdr, SCM exp, char tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
221	static void
222	display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
223	char *hdr;
224	SCM exp;
225	char *tlr;
226	int indentation;
227	SCM sport;
228	SCM port;
229	scm_print_state *pstate;
230	{
231	pstate->level = 2;
232	pstate->length = 3;
233	if (SCM_NIMP (exp) && SCM_CONSP (exp))
234	{
235	scm_iprlist (hdr, exp, tlr[0], port, pstate);
236	scm_gen_puts (scm_regular_string, &tlr[1], port);
237	}
238	else
239	scm_iprin1 (exp, port, pstate);
240	scm_gen_putc ('\n', port);
241	}
242
243	static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
244	static void
245	display_frame (frame, nfield, indentation, sport, port, pstate)
246	SCM frame;
247	int nfield;
248	int indentation;
249	SCM sport;
250	SCM port;
251	scm_print_state *pstate;
252	{
253	int n, i, j;
254
255	/* Announce missing frames? */
256	if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
257	{
258	indent (nfield + 1 + indentation, port);
259	scm_gen_puts (scm_regular_string, "...\n", port);
260	}
261
262	/* Check size of frame number. */
263	n = SCM_FRAME_NUMBER (frame);
264	for (i = 0, j = n; j > 0; ++i) j /= 10;
265
266	/* Number indentation. */
267	indent (nfield - (i ? i : 1), port);
268
269	/* Frame number. */
270	scm_iprin1 (SCM_MAKINUM (n), port, pstate);
271
272	/* Real frame marker */
273	scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
274
275	/* Indentation. */
276	indent (indentation, port);
277
278	if (SCM_FRAME_PROC_P (frame))
279	/* Display an application. */
280	{
281	SCM proc = SCM_FRAME_PROC (frame);
282	SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
283	? scm_procedure_name (proc)
284	: SCM_BOOL_F);
285	display_frame_expr ("[",
286	scm_cons (SCM_NFALSEP (name) ? name : proc,
287	SCM_FRAME_ARGS (frame)),
288	SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
289	nfield + 1 + indentation,
290	sport,
291	port,
292	pstate);
293	}
294	else
295	/* Display a special form. */
296	{
297	SCM source = SCM_FRAME_SOURCE (frame);
298	SCM copy = scm_source_property (source, scm_i_copy);
299	display_frame_expr ("(",
300	SCM_NIMP (copy) && SCM_CONSP (copy)
301	? copy
302	: scm_unmemoize (source),
303	")",
304	nfield + 1 + indentation,
305	sport,
306	port,
307	pstate);
308	}
309
310	/* Announce missing frames? */
311	if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
312	{
313	indent (nfield + 1 + indentation, port);
314	scm_gen_puts (scm_regular_string, "...\n", port);
315	}
316	}
317
318	SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
319	SCM
320	scm_display_backtrace (stack, port, first, depth)
321	SCM stack;
322	SCM port;
323	SCM first;
324	SCM depth;
325	{
326	int n_frames, beg, end, n, i, j;
327	int nfield, indent_p, indentation;
328	SCM frame, sport, print_state;
329	scm_print_state *pstate;
330
331	/* Argument checking and extraction. */
332	SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
333	stack,
334	SCM_ARG1,
335	s_display_backtrace);
336	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
337	port,
338	SCM_ARG2,
339	s_display_backtrace);
340	n_frames = SCM_INUM (scm_stack_length (stack));
341	n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
342	if (SCM_BACKWARDS_P)
343	{
344	beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
345	end = beg + n - 1;
346	if (end >= n_frames)
347	end = n_frames - 1;
348	n = end - beg + 1;
349	}
350	else
351	{
352	if (SCM_INUMP (first))
353	{
354	beg = SCM_INUM (first);
355	end = beg - n + 1;
356	if (end < 0)
357	end = 0;
358	}
359	else
360	{
361	beg = n - 1;
362	end = 0;
363	if (beg >= n_frames)
364	beg = n_frames - 1;
365	}
366	n = beg - end + 1;
367	}
368	SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
369	SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
370
371	/* Create a string port used for adaptation of printing parameters. */
372	sport = scm_mkstrport (SCM_INUM0,
373	scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
374	SCM_OPN \| SCM_WRTNG,
375	s_display_backtrace);
376
377	/* Create a print state for printing of frames. */
378	print_state = scm_make_print_state ();
379	pstate = SCM_PRINT_STATE (print_state);
380	pstate->writingp = 1;
381	pstate->fancyp = 1;
382
383	/* First find out if it's reasonable to do indentation. */
384	if (SCM_BACKWARDS_P)
385	indent_p = 0;
386	else
387	{
388	indent_p = 1;
389	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
390	for (i = 0, j = 0; i < n; ++i)
391	{
392	if (SCM_FRAME_REAL_P (frame))
393	++j;
394	if (j > SCM_BACKTRACE_INDENT)
395	{
396	indent_p = 0;
397	break;
398	}
399	frame = (SCM_BACKWARDS_P
400	? SCM_FRAME_PREV (frame)
401	: SCM_FRAME_NEXT (frame));
402	}
403	}
404
405	/* Determine size of frame number field. */
406	j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
407	for (i = 0; j > 0; ++i) j /= 10;
408	nfield = i ? i : 1;
409
410	scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
411
412	/* Print frames. */
413	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
414	indentation = 1;
415	display_frame (frame, nfield, indentation, sport, port, pstate);
416	for (i = 1; i < n; ++i)
417	{
418	if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
419	++indentation;
420	frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
421	display_frame (frame, nfield, indentation, sport, port, pstate);
422	}
423
424	return SCM_UNSPECIFIED;
425	}
426
427	\f
428
429	void
430	scm_init_backtrace ()
431	{
432	#include "backtrace.x"
433	}