[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);
}


void
scm_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)
      && SCM_STACK_LENGTH (stack) > 0)
    {
      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);
  scm_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
f3acc5c1 JB	91
	92	void
	93	scm_display_error_message (message, args, port)
ab4f3efb MD	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;
841076ac MD	186	if (SCM_DEBUGGINGP
	187	&& SCM_NIMP (stack)
	188	&& SCM_STACKP (stack)
	189	&& SCM_STACK_LENGTH (stack) > 0)
ab4f3efb MD	190	{
	191	current_frame = scm_stack_ref (stack, SCM_INUM0);
	192	source = SCM_FRAME_SOURCE (current_frame);
	193	if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
	194	source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
	195	if (SCM_FRAME_PROC_P (current_frame)
	196	&& scm_procedure_p (SCM_FRAME_PROC (current_frame)))
	197	pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
	198	}
	199	if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
	200	pname = subr;
	201	if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
	202	\|\| (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
	203	{
	204	display_header (source, port);
	205	display_expression (current_frame, pname, source, port);
	206	}
	207	display_header (source, port);
f3acc5c1	208	scm_display_error_message (message, args, port);
ab4f3efb MD	209	return SCM_UNSPECIFIED;
	210	}
	211
	212	static void indent SCM_P ((int n, SCM port));
	213	static void
	214	indent (n, port)
	215	int n;
	216	SCM port;
	217	{
	218	int i;
	219	for (i = 0; i < n; ++i)
	220	scm_gen_putc (' ', port);
	221	}
	222
	223	static void display_frame_expr SCM_P ((char hdr, SCM exp, char tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
	224	static void
	225	display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
	226	char *hdr;
	227	SCM exp;
	228	char *tlr;
	229	int indentation;
	230	SCM sport;
	231	SCM port;
	232	scm_print_state *pstate;
	233	{
	234	pstate->level = 2;
	235	pstate->length = 3;
	236	if (SCM_NIMP (exp) && SCM_CONSP (exp))
	237	{
	238	scm_iprlist (hdr, exp, tlr[0], port, pstate);
	239	scm_gen_puts (scm_regular_string, &tlr[1], port);
	240	}
	241	else
	242	scm_iprin1 (exp, port, pstate);
	243	scm_gen_putc ('\n', port);
	244	}
	245
	246	static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
	247	static void
	248	display_frame (frame, nfield, indentation, sport, port, pstate)
	249	SCM frame;
	250	int nfield;
	251	int indentation;
	252	SCM sport;
	253	SCM port;
	254	scm_print_state *pstate;
	255	{
	256	int n, i, j;
	257
	258	/* Announce missing frames? */
	259	if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
	260	{
	261	indent (nfield + 1 + indentation, port);
	262	scm_gen_puts (scm_regular_string, "...\n", port);
	263	}
	264
	265	/* Check size of frame number. */
	266	n = SCM_FRAME_NUMBER (frame);
	267	for (i = 0, j = n; j > 0; ++i) j /= 10;
	268
	269	/* Number indentation. */
	270	indent (nfield - (i ? i : 1), port);
	271
	272	/* Frame number. */
273	scm_iprin1 (SCM_MAKINUM (n), port, pstate);
274
275	/* Real frame marker */
276	scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
277
278	/* Indentation. */
279	indent (indentation, port);
280
281	if (SCM_FRAME_PROC_P (frame))
282	/* Display an application. */
283	{
284	SCM proc = SCM_FRAME_PROC (frame);
285	SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
286	? scm_procedure_name (proc)
287	: SCM_BOOL_F);
288	display_frame_expr ("[",
289	scm_cons (SCM_NFALSEP (name) ? name : proc,
290	SCM_FRAME_ARGS (frame)),
291	SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
292	nfield + 1 + indentation,
293	sport,
294	port,
295	pstate);
296	}
297	else
298	/* Display a special form. */
299	{
300	SCM source = SCM_FRAME_SOURCE (frame);
301	SCM copy = scm_source_property (source, scm_i_copy);
302	display_frame_expr ("(",
303	SCM_NIMP (copy) && SCM_CONSP (copy)
304	? copy
305	: scm_unmemoize (source),
306	")",
307	nfield + 1 + indentation,
308	sport,
309	port,
310	pstate);
311	}
312
313	/* Announce missing frames? */
314	if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
315	{
316	indent (nfield + 1 + indentation, port);
317	scm_gen_puts (scm_regular_string, "...\n", port);
318	}
319	}
320
321	SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
322	SCM
323	scm_display_backtrace (stack, port, first, depth)
324	SCM stack;
325	SCM port;
326	SCM first;
327	SCM depth;
328	{
329	int n_frames, beg, end, n, i, j;
330	int nfield, indent_p, indentation;
331	SCM frame, sport, print_state;
332	scm_print_state *pstate;
333
334	/* Argument checking and extraction. */
335	SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
336	stack,
337	SCM_ARG1,
338	s_display_backtrace);
339	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
340	port,
341	SCM_ARG2,
342	s_display_backtrace);
343	n_frames = SCM_INUM (scm_stack_length (stack));
344	n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
345	if (SCM_BACKWARDS_P)
346	{
347	beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
348	end = beg + n - 1;
349	if (end >= n_frames)
350	end = n_frames - 1;
351	n = end - beg + 1;
352	}
353	else
354	{
355	if (SCM_INUMP (first))
356	{
357	beg = SCM_INUM (first);
358	end = beg - n + 1;
359	if (end < 0)
360	end = 0;
361	}
362	else
363	{
364	beg = n - 1;
365	end = 0;
366	if (beg >= n_frames)
367	beg = n_frames - 1;
368	}
369	n = beg - end + 1;
370	}
371	SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
372	SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
373
374	/* Create a string port used for adaptation of printing parameters. */
375	sport = scm_mkstrport (SCM_INUM0,
376	scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
377	SCM_OPN \| SCM_WRTNG,
378	s_display_backtrace);
379
380	/* Create a print state for printing of frames. */
381	print_state = scm_make_print_state ();
382	pstate = SCM_PRINT_STATE (print_state);
383	pstate->writingp = 1;
384	pstate->fancyp = 1;
385
386	/* First find out if it's reasonable to do indentation. */
387	if (SCM_BACKWARDS_P)
388	indent_p = 0;
389	else
390	{
391	indent_p = 1;
392	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
393	for (i = 0, j = 0; i < n; ++i)
394	{
395	if (SCM_FRAME_REAL_P (frame))
396	++j;
397	if (j > SCM_BACKTRACE_INDENT)
398	{
399	indent_p = 0;
400	break;
401	}
402	frame = (SCM_BACKWARDS_P
403	? SCM_FRAME_PREV (frame)
404	: SCM_FRAME_NEXT (frame));
405	}
406	}
407
408	/* Determine size of frame number field. */
409	j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
410	for (i = 0; j > 0; ++i) j /= 10;
411	nfield = i ? i : 1;
412
413	scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
414
415	/* Print frames. */
416	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
417	indentation = 1;
418	display_frame (frame, nfield, indentation, sport, port, pstate);
419	for (i = 1; i < n; ++i)
420	{
421	if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
422	++indentation;
423	frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
424	display_frame (frame, nfield, indentation, sport, port, pstate);
425	}
426
427	return SCM_UNSPECIFIED;
428	}
429
430	\f
431
432	void
433	scm_init_backtrace ()
434	{
435	#include "backtrace.x"
436	}