[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_IMP (message) || !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)) == SCM_BOOL_T)
	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;
{
  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_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_application (frame, indentation, sport, port, pstate)
     SCM frame;
     int indentation;
     SCM sport;
     SCM port;
     scm_print_state *pstate;
{
  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) ? " ..." : "]",
		      indentation,
		      sport,
		      port,
		      pstate);
}

SCM_PROC(s_display_application, "display-application", 1, 1, 0, scm_display_application);

SCM
scm_display_application (SCM frame, SCM port)
{
  if (SCM_UNBNDP (port))
    port = scm_cur_outp;
  if (SCM_FRAME_PROC_P (frame))
    /* Display an application. */
    {
      SCM print_state;
      scm_print_state *pstate;
      
      /* 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;
      pstate->level = 2;
      pstate->length = 9;
      
      display_application (frame, 0, SCM_BOOL_F, port, pstate); /*fixme*/
      return SCM_BOOL_T;
    }
  else
    return SCM_BOOL_F;
}

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. */
    display_application (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;
  pstate->level = 2;
  pstate->length = 3;

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

SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");

SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
SCM
scm_backtrace ()
{
  if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
    {
      scm_newline (scm_cur_outp);
      scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
			     scm_cur_outp,
			     SCM_UNDEFINED,
			     SCM_UNDEFINED);
      scm_newline (scm_cur_outp);
      if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
	  && !SCM_BACKTRACE_P)
	{
	  scm_gen_puts (scm_regular_string,
			"Type \"(debug-enable 'backtrace)\" if you would like "
			"a backtrace\n"
			"automatically if an error occurs in the future.\n",
			scm_cur_outp);
	  SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
	}
    }
  else
    {
      scm_gen_puts (scm_regular_string,
		    "No backtrace available.\n",
		    scm_cur_outp);
    }
  return SCM_UNSPECIFIED;
}

\f

void
scm_init_backtrace ()
{
  scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);

#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
c37e0e55 GH	102	if (SCM_IMP (message) \|\| !SCM_STRINGP (message) \|\| SCM_IMP (args)
c37e0e55 GH	103	\|\| !scm_list_p (args))
ab4f3efb MD	104	{
	105	scm_prin1 (message, port, 0);
	106	scm_gen_putc ('\n', port);
	107	return;
	108	}
	109
	110	start = SCM_CHARS (message);
	111	for (p = start; *p != '\0'; ++p)
	112	if (*p == '%')
	113	{
	114	if (SCM_IMP (args) \|\| SCM_NCONSP (args))
	115	continue;
	116
	117	++p;
	118	if (*p == 's')
	119	writingp = 0;
	120	else if (*p == 'S')
	121	writingp = 1;
	122	else
	123	continue;
	124
	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);
	128	start = p + 1;
	129	}
	130	scm_gen_write (scm_regular_string, start, p - start, port);
	131	scm_gen_putc ('\n', port);
	132	}
	133
	134	static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
	135	static void
	136	display_expression (frame, pname, source, port)
	137	SCM frame;
	138	SCM pname;
	139	SCM source;
	140	SCM port;
	141	{
	142	SCM print_state = scm_make_print_state ();
	143	scm_print_state *pstate = SCM_PRINT_STATE (print_state);
	144	pstate->writingp = 0;
	145	pstate->fancyp = 1;
	146	pstate->level = 2;
	147	pstate->length = 3;
	148	if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
	149	{
	150	if (SCM_NIMP (frame)
	151	&& SCM_FRAMEP (frame)
	152	&& SCM_FRAME_EVAL_ARGS_P (frame))
	153	scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
	154	else
	155	scm_gen_puts (scm_regular_string, "In procedure ", port);
	156	scm_iprin1 (pname, port, pstate);
	157	if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
	158	{
	159	scm_gen_puts (scm_regular_string, " in expression ", port);
	160	pstate->writingp = 1;
	161	scm_iprin1 (scm_unmemoize (source), port, pstate);
	162	}
	163	}
	164	else if (SCM_NIMP (source))
	165	{
	166	scm_gen_puts (scm_regular_string, "In expression ", port);
	167	pstate->writingp = 1;
168	scm_iprin1 (scm_unmemoize (source), port, pstate);
169	}
170	scm_gen_puts (scm_regular_string, ":\n", port);
171	scm_free_print_state (print_state);
172	}
173
174	SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
175	SCM
176	scm_display_error (stack, port, subr, message, args, rest)
177	SCM stack;
178	SCM port;
179	SCM subr;
180	SCM message;
181	SCM args;
182	SCM rest;
183	{
184	SCM current_frame = SCM_BOOL_F;
185	SCM source = SCM_BOOL_F;
186	SCM pname = SCM_BOOL_F;
841076ac MD	187	if (SCM_DEBUGGINGP
	188	&& SCM_NIMP (stack)
	189	&& SCM_STACKP (stack)
	190	&& SCM_STACK_LENGTH (stack) > 0)
ab4f3efb MD	191	{
	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)
016e2ce1	197	&& scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
ab4f3efb MD	198	pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
	199	}
	200	if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
	201	pname = subr;
	202	if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
	203	\|\| (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
	204	{
	205	display_header (source, port);
	206	display_expression (current_frame, pname, source, port);
	207	}
	208	display_header (source, port);
f3acc5c1	209	scm_display_error_message (message, args, port);
ab4f3efb MD	210	return SCM_UNSPECIFIED;
	211	}
	212
	213	static void indent SCM_P ((int n, SCM port));
	214	static void
	215	indent (n, port)
	216	int n;
	217	SCM port;
	218	{
	219	int i;
	220	for (i = 0; i < n; ++i)
	221	scm_gen_putc (' ', port);
	222	}
	223
	224	static void display_frame_expr SCM_P ((char hdr, SCM exp, char tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
	225	static void
	226	display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
	227	char *hdr;
	228	SCM exp;
	229	char *tlr;
	230	int indentation;
	231	SCM sport;
	232	SCM port;
	233	scm_print_state *pstate;
	234	{
ab4f3efb MD	235	if (SCM_NIMP (exp) && SCM_CONSP (exp))
	236	{
	237	scm_iprlist (hdr, exp, tlr[0], port, pstate);
	238	scm_gen_puts (scm_regular_string, &tlr[1], port);
	239	}
	240	else
	241	scm_iprin1 (exp, port, pstate);
	242	scm_gen_putc ('\n', port);
	243	}
	244
e3c37929 MD	245	static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
	246	static void
	247	display_application (frame, indentation, sport, port, pstate)
	248	SCM frame;
	249	int indentation;
	250	SCM sport;
	251	SCM port;
	252	scm_print_state *pstate;
	253	{
	254	SCM proc = SCM_FRAME_PROC (frame);
	255	SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
	256	? scm_procedure_name (proc)
	257	: SCM_BOOL_F);
	258	display_frame_expr ("[",
	259	scm_cons (SCM_NFALSEP (name) ? name : proc,
	260	SCM_FRAME_ARGS (frame)),
	261	SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
	262	indentation,
	263	sport,
	264	port,
	265	pstate);
	266	}
	267
	268	SCM_PROC(s_display_application, "display-application", 1, 1, 0, scm_display_application);
	269
	270	SCM
	271	scm_display_application (SCM frame, SCM port)
	272	{
	273	if (SCM_UNBNDP (port))
	274	port = scm_cur_outp;
	275	if (SCM_FRAME_PROC_P (frame))
	276	/* Display an application. */
	277	{
	278	SCM print_state;
	279	scm_print_state *pstate;
	280
	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;
	285	pstate->fancyp = 1;
	286	pstate->level = 2;
	287	pstate->length = 9;
	288
	289	display_application (frame, 0, SCM_BOOL_F, port, pstate); /fixme/
	290	return SCM_BOOL_T;
	291	}
	292	else
	293	return SCM_BOOL_F;
	294	}
	295
ab4f3efb MD	296	static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
	297	static void
	298	display_frame (frame, nfield, indentation, sport, port, pstate)
	299	SCM frame;
	300	int nfield;
	301	int indentation;
	302	SCM sport;
	303	SCM port;
	304	scm_print_state *pstate;
	305	{
	306	int n, i, j;
	307
	308	/* Announce missing frames? */
	309	if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
	310	{
	311	indent (nfield + 1 + indentation, port);
	312	scm_gen_puts (scm_regular_string, "...\n", port);
	313	}
	314
	315	/* Check size of frame number. */
	316	n = SCM_FRAME_NUMBER (frame);
	317	for (i = 0, j = n; j > 0; ++i) j /= 10;
	318
	319	/* Number indentation. */
	320	indent (nfield - (i ? i : 1), port);
	321
	322	/* Frame number. */
	323	scm_iprin1 (SCM_MAKINUM (n), port, pstate);
	324
	325	/* Real frame marker */
	326	scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
	327
	328	/* Indentation. */
	329	indent (indentation, port);
	330
	331	if (SCM_FRAME_PROC_P (frame))
	332	/* Display an application. */
e3c37929	333	display_application (frame, nfield + 1 + indentation, sport, port, pstate);
ab4f3efb MD	334	else
	335	/* Display a special form. */
	336	{
	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)
	341	? copy
	342	: scm_unmemoize (source),
	343	")",
	344	nfield + 1 + indentation,
	345	sport,
	346	port,
	347	pstate);
	348	}
	349
	350	/* Announce missing frames? */
	351	if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
	352	{
	353	indent (nfield + 1 + indentation, port);
	354	scm_gen_puts (scm_regular_string, "...\n", port);
	355	}
	356	}
	357
	358	SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
	359	SCM
	360	scm_display_backtrace (stack, port, first, depth)
	361	SCM stack;
	362	SCM port;
	363	SCM first;
	364	SCM depth;
	365	{
	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;
	370
	371	/* Argument checking and extraction. */
	372	SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
	373	stack,
	374	SCM_ARG1,
	375	s_display_backtrace);
	376	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
	377	port,
	378	SCM_ARG2,
	379	s_display_backtrace);
	380	n_frames = SCM_INUM (scm_stack_length (stack));
	381	n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
	382	if (SCM_BACKWARDS_P)
	383	{
	384	beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
	385	end = beg + n - 1;
	386	if (end >= n_frames)
	387	end = n_frames - 1;
	388	n = end - beg + 1;
	389	}
	390	else
	391	{
	392	if (SCM_INUMP (first))
	393	{
	394	beg = SCM_INUM (first);
	395	end = beg - n + 1;
	396	if (end < 0)
	397	end = 0;
398	}
399	else
400	{
401	beg = n - 1;
402	end = 0;
403	if (beg >= n_frames)
404	beg = n_frames - 1;
405	}
406	n = beg - end + 1;
407	}
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);
410
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),
414	SCM_OPN \| SCM_WRTNG,
415	s_display_backtrace);
416
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;
421	pstate->fancyp = 1;
e3c37929 MD	422	pstate->level = 2;
e3c37929 MD	423	pstate->length = 3;
ab4f3efb MD	424
	425	/* First find out if it's reasonable to do indentation. */
	426	if (SCM_BACKWARDS_P)
	427	indent_p = 0;
	428	else
	429	{
	430	indent_p = 1;
	431	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
	432	for (i = 0, j = 0; i < n; ++i)
	433	{
	434	if (SCM_FRAME_REAL_P (frame))
	435	++j;
	436	if (j > SCM_BACKTRACE_INDENT)
	437	{
	438	indent_p = 0;
	439	break;
	440	}
	441	frame = (SCM_BACKWARDS_P
	442	? SCM_FRAME_PREV (frame)
	443	: SCM_FRAME_NEXT (frame));
	444	}
	445	}
	446
	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;
	450	nfield = i ? i : 1;
	451
	452	scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
	453
	454	/* Print frames. */
	455	frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
	456	indentation = 1;
	457	display_frame (frame, nfield, indentation, sport, port, pstate);
	458	for (i = 1; i < n; ++i)
	459	{
	460	if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
	461	++indentation;
	462	frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
	463	display_frame (frame, nfield, indentation, sport, port, pstate);
	464	}
	465
	466	return SCM_UNSPECIFIED;
	467	}
	468
78f9f47b	469	SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
5aab5d96 MD	470
	471	SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
	472	SCM
	473	scm_backtrace ()
	474	{
	475	if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
	476	{
	477	scm_newline (scm_cur_outp);
	478	scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
	479	scm_cur_outp,
	480	SCM_UNDEFINED,
	481	SCM_UNDEFINED);
	482	scm_newline (scm_cur_outp);
	483	if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
	484	&& !SCM_BACKTRACE_P)
	485	{
	486	scm_gen_puts (scm_regular_string,
23f53cd3 JB	487	"Type \"(debug-enable 'backtrace)\" if you would like "
	488	"a backtrace\n"
	489	"automatically if an error occurs in the future.\n",
5aab5d96 MD	490	scm_cur_outp);
	491	SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
	492	}
	493	}
	494	else
	495	{
	496	scm_gen_puts (scm_regular_string,
	497	"No backtrace available.\n",
	498	scm_cur_outp);
	499	}
	500	return SCM_UNSPECIFIED;
	501	}
	502
ab4f3efb MD	503	\f
	504
	505	void
	506	scm_init_backtrace ()
	507	{
5aab5d96 MD	508	scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);
5aab5d96 MD	509
ab4f3efb MD	510	#include "backtrace.x"
ab4f3efb MD	511	}