/* -*-C-*-

$Id: debug.c,v 9.53 2001/07/31 03:11:17 cph Exp $

Copyright (c) 1987-2001 Massachusetts Institute of Technology

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 of the License, 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 program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/

/* Utilities to help with debugging */

#include "scheme.h"
#include "prims.h"
#include "trap.h"
#include "lookup.h"

static void EXFUN (do_printing, (outf_channel, SCHEME_OBJECT, Boolean));
static Boolean EXFUN (print_primitive_name, (outf_channel, SCHEME_OBJECT));
static void EXFUN (print_expression, (outf_channel, SCHEME_OBJECT, char *));

/* Compiled Code Debugging */

static SCHEME_OBJECT
DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block)
{
  extern SCHEME_OBJECT EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT));
  SCHEME_OBJECT info;

  info = (compiled_block_debugging_info (block));
  return
    (((STRING_P (info)) ||
      ((PAIR_P (info)) &&
       (STRING_P (PAIR_CAR (info))) &&
       (FIXNUM_P (PAIR_CDR (info)))))
     ? info
     : SHARP_F);
}

extern void
  EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));

extern long
  EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)),
  EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT));

extern SCHEME_OBJECT
  * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)),
  EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));

#define COMPILED_ENTRY_TO_BLOCK(entry)					\
(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK,				\
		      (compiled_entry_to_block_address (entry))))

static SCHEME_OBJECT
DEFUN (compiled_entry_debug_filename, (entry), SCHEME_OBJECT entry)
{
  long results [3];

  compiled_entry_type (entry, (& (results [0])));
  if (((results [0]) == 0) && (compiled_entry_closure_p (entry)))
    entry = (compiled_closure_to_entry (entry));
  return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry)));
}

char *
DEFUN (compiled_entry_filename, (entry), SCHEME_OBJECT entry)
{
  SCHEME_OBJECT result;

  result = (compiled_entry_debug_filename (entry));
  if (STRING_P (result))
    return ((char *) (STRING_LOC ((result), 0)));
  else if (PAIR_P (result))
    return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0)));
  else
    return ("**** filename not known ****");
}

void
DEFUN_VOID (Show_Pure)
{
  SCHEME_OBJECT *Obj_Address;
  long Pure_Size, Total_Size;

  Obj_Address = Constant_Space;
  while (true)
  {
    if (Obj_Address > Free_Constant)
    {
      outf_console ("Past end of area.\n");
      return;
    }
    if (Obj_Address == Free_Constant)
    {
      outf_console ("Done.\n");
      return;
    }
    Pure_Size = OBJECT_DATUM (*Obj_Address);
    Total_Size = OBJECT_DATUM (Obj_Address[1]);
    outf_console ("0x%lx: pure=0x%lx, total=0x%lx\n",
	    ((long) Obj_Address), ((long) Pure_Size), ((long) Total_Size));
    if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
    {
      outf_console ("Missing initial SNMV.\n");
      return;
    }
    if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART)
    {
      outf_console ("Missing subsequent pure header.\n");
    }
    if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) !=
        TC_MANIFEST_SPECIAL_NM_VECTOR)
    {
      outf_console ("Missing internal SNMV.\n");
      return;
    }
    if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART)
    {
      outf_console ("Missing constant header.\n");
      return;
    }
    if (((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))) != Pure_Size)
    {
      outf_console ("Pure size mismatch 0x%lx.\n",
	      ((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))));
    }
    if (OBJECT_TYPE (Obj_Address[Total_Size-1]) !=
        TC_MANIFEST_SPECIAL_NM_VECTOR)
    {
      outf_console ("Missing ending SNMV.\n");
      return;
    }
    if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK)
    {
      outf_console ("Missing ending header.\n");
      return;
    }
    if (((long) (OBJECT_DATUM (Obj_Address[Total_Size]))) != Total_Size)
    {
      outf_console ("Total size mismatch 0x%lx.\n",
	      ((long) (OBJECT_DATUM (Obj_Address[Total_Size]))));
    }
    Obj_Address += Total_Size+1;
#ifdef FLOATING_ALIGNMENT
    while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))
    {
      Obj_Address += 1;
    }
#endif
  }
}

void
DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env)
{
  SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension;
  long count, i;

  procedure = MEMORY_REF (The_Env, ENVIRONMENT_FUNCTION);
  value_ptr = MEMORY_LOC (The_Env, ENVIRONMENT_FIRST_ARG);

  if (FRAME_EXTENSION_P (procedure))
  {
    extension = procedure;
    procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
  }
  else
    extension = SHARP_F;

  if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) &&
      (OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE))
  {
    outf_console ("Not created by a procedure");
    return;
  }
  name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR);
  name_ptr = MEMORY_LOC (*name_ptr, LAMBDA_FORMALS);
  count = VECTOR_LENGTH (*name_ptr) - 1;

  name_ptr = MEMORY_LOC (*name_ptr, 2);
  for (i = 0; i < count; i++)
  {
    Print_Expression (*name_ptr++, "Name ");
    Print_Expression (*value_ptr++, " Value ");
    outf_console ("\n");
  }
  if (extension != SHARP_F)
  {
    outf_console ("Auxiliary Variables\n");
    count = (GET_FRAME_EXTENSION_LENGTH (extension));
    for (i = 0, name_ptr = (GET_FRAME_EXTENSION_BINDINGS (extension));
	 i < count;
	 i++, name_ptr++)
    {
      Print_Expression ((PAIR_CAR (*name_ptr)), "Name ");
      Print_Expression ((PAIR_CDR (*name_ptr)), " Value ");
      outf_console ("\n");
    }
  }
}

static void
DEFUN (print_list, (stream, pair), outf_channel stream AND SCHEME_OBJECT pair)
{
  int count;

  outf (stream, "(");
  count = 0;
  while (((PAIR_P (pair)) || (WEAK_PAIR_P (pair))) && (count < MAX_LIST_PRINT))
    {
      if (count > 0)
	outf (stream, " ");
      print_expression (stream,
			(PAIR_CAR (pair)),
			((WEAK_PAIR_P (pair)) ? "{weak}" : ""));
      pair = (PAIR_CDR (pair));
      count += 1;
    }
  if (pair != EMPTY_LIST)
    {
      if (count == MAX_LIST_PRINT)
	outf (stream, " ...");
      else
	{
	  outf (stream, " . ");
	  print_expression (stream, pair, "");
	}
    }
  outf (stream, ")");
  return;
}

static void
DEFUN (print_return_name, (stream, Ptr), outf_channel stream AND SCHEME_OBJECT Ptr)
{
  long index;
  char * name;

  index = (OBJECT_DATUM (Ptr));
  if (index <= MAX_RETURN)
    {
      name = (Return_Names [index]);
      if ((name != ((char *) 0)) &&
	  ((name [0]) != '\0'))
	{
	  outf (stream, "%s", name);
	  return;
	}
    }
  outf (stream, "[0x%lx]", index);
  return;
}

void
DEFUN (Print_Return, (String), char * String)
{
  outf_console ("%s: ", String);
  print_return_name (console_output, Fetch_Return ());
  outf_console ("\n");
}

static void
DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT string)
{
  long length;
  long i;
  char * next;
  char this;

  outf (stream, "\"");
  length = (STRING_LENGTH (string));
  next = ((char *) (STRING_LOC (string, 0)));
  for (i = 0; (i < length); i += 1)
    {
      this = (*next++);
      switch (this)
	{
	case '\\':
	  outf (stream, "\\\\");
	  break;
	case '"':
	  outf (stream, "\\\"");
	  break;
	case '\t':
	  outf (stream, "\\t");
	  break;
	case '\n':
	  outf (stream, "\\n");
	  break;
	case '\f':
	  outf (stream, "\\f");
	  break;
	default:
	  if ((this >= ' ') && (this <= '~'))
	    outf (stream, "%c", this);
	  else
	    outf (stream, "\\%03o", this);
	  break;
	}
    }
  outf (stream, "\"");
  return;
}

static void
DEFUN (print_symbol, (stream, symbol), outf_channel stream AND SCHEME_OBJECT symbol)
{
  SCHEME_OBJECT string;
  long length;
  long i;
  char * next;

  string = (MEMORY_REF (symbol, SYMBOL_NAME));
  length = (STRING_LENGTH (string));
  next = ((char *) (STRING_LOC (string, 0)));
  for (i = 0; (i < length); i += 1)
    outf(stream, "%c", *next++);  /*should use %s? */
  return;
}

static void
DEFUN (print_filename, (stream, filename),
       outf_channel stream AND SCHEME_OBJECT filename)
{
  long length;
  char * scan;
  char * end;
  char * slash;

  length = (STRING_LENGTH (filename));
  scan = ((char *) (STRING_LOC (filename, 0)));
  end = (scan + length);
  slash = scan;
  while (scan < end)
    if ((*scan++) == '/')
      slash = scan;
  outf (stream, "\"%s\"", slash);
  return;
}

static void
DEFUN (print_object, (object), SCHEME_OBJECT object)
{
  do_printing (console_output, object, true);
  outf_console ("\n");
  outf_flush_console();
  return;
}

DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1,
  "A cheap, built-in printer intended for debugging the interpreter.")
{
  PRIMITIVE_HEADER (1);

  print_object (ARG_REF (1));
  return (SHARP_F);
}

static void
DEFUN (print_objects, (objects, n),
       SCHEME_OBJECT * objects AND int n)
{
  SCHEME_OBJECT * scan;
  SCHEME_OBJECT * end;

  scan = objects;
  end = (objects + n);
  while (scan < end)
    {
      outf_console ("%4x: ", (((char *) scan) - ((char *) objects)));
      do_printing (console_output, (*scan++), true);
      outf_console ("\n");
    }
  outf_flush_console();
  return;
}

/* This is useful because `do_printing' doesn't print the contents of
   vectors.  The reason that it doesn't is because vectors are used to
   represent named structures, and most named structures don't want to
   be printed out explicitly.  */

void
DEFUN (Print_Vector, (vector), SCHEME_OBJECT vector)
{
  print_objects
    ((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector))));
}

static void
DEFUN (print_expression, (stream, expression, string),
       outf_channel stream AND SCHEME_OBJECT expression AND char * string)
{
  if ((string [0]) != 0)
    outf (stream, "%s: ", string);
  do_printing (stream, expression, true);
  return;
}

void
DEFUN (Print_Expression, (expression, string),
       SCHEME_OBJECT expression AND char * string)
{
  print_expression (console_output, expression, string);
  return;
}

extern char * Type_Names [];

static void
DEFUN (do_printing, (stream, Expr, Detailed),
       outf_channel stream AND SCHEME_OBJECT Expr AND Boolean Detailed)
{
  long Temp_Address;
  Boolean handled_p;

  Temp_Address = (OBJECT_DATUM (Expr));
  handled_p = false;

  if (Expr == EMPTY_LIST)	{ outf (stream, "()");	return; }
  else if (Expr == SHARP_F)	{ outf (stream, "#F");	return; }
  else if (Expr == SHARP_T)	{ outf (stream, "#T");	return; }
  else if (Expr == UNSPECIFIC)	{ outf (stream, "[UNSPECIFIC]"); return; }

  switch (OBJECT_TYPE (Expr))
    {
    case TC_ACCESS:
      {
	outf (stream, "[ACCESS (");
	Expr = (MEMORY_REF (Expr, ACCESS_NAME));
      SPrint:
	print_symbol (stream, Expr);
	handled_p = true;
	outf (stream, ")");
	break;
      }

    case TC_ASSIGNMENT:
      outf (stream, "[SET! (");
      Expr = (MEMORY_REF ((MEMORY_REF (Expr, ASSIGN_NAME)), VARIABLE_SYMBOL));
      goto SPrint;

    case TC_CHARACTER_STRING:
      print_string (stream, Expr);
      return;

    case TC_DEFINITION:
      outf (stream, "[DEFINE (");
      Expr = (MEMORY_REF (Expr, DEFINE_NAME));
      goto SPrint;

    case_TC_FIXNUMs:
      outf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr))));
      return;

    case TC_BIG_FLONUM:
      outf (stream, "%lf", (FLONUM_TO_DOUBLE (Expr)));
      return;

    case TC_WEAK_CONS:
    case TC_LIST:
      print_list (stream, Expr);
      return;

    case TC_NULL:
      break;

    case TC_UNINTERNED_SYMBOL:
      outf (stream, "[UNINTERNED_SYMBOL (");
      goto SPrint;

    case TC_INTERNED_SYMBOL:
      print_symbol (stream, Expr);
      return;

    case TC_VARIABLE:
      Expr = (MEMORY_REF (Expr, VARIABLE_SYMBOL));
      if (Detailed)
	{
	  outf (stream, "[VARIABLE (");
	  goto SPrint;
	}
      print_symbol (stream, Expr);
      return;

    case TC_COMBINATION:
      outf (stream, "[COMBINATION (%ld args) 0x%lx]",
	      ((long) ((VECTOR_LENGTH (Expr)) - 1)),
	      ((long) Temp_Address));
      if (Detailed)
	{
	  outf (stream, " (");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_FN_SLOT)), false);
	  outf (stream, " ...)");
	}
      return;

    case TC_COMBINATION_1:
      outf (stream, "[COMBINATION_1 0x%lx]", ((long) Temp_Address));
      if (Detailed)
	{
	  outf (stream, " (");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_1_FN)), false);
	  outf (stream, ", ");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_1_ARG_1)), false);
	  outf (stream, ")");
	}
      return;

    case TC_COMBINATION_2:
      outf (stream, "[COMBINATION_2 0x%lx]", ((long) Temp_Address));
      if (Detailed)
	{
	  outf (stream, " (");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_2_FN)), false);
	  outf (stream, ", ");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_1)), false);
	  outf (stream, ", ");
	  do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_2)), false);
	  outf (stream, ")");
	}
      return;

    case TC_ENVIRONMENT:
      {
	SCHEME_OBJECT procedure;

	outf (stream, "[ENVIRONMENT 0x%lx]", ((long) Temp_Address));
	outf (stream, " (from ");
	procedure = (MEMORY_REF (Expr, ENVIRONMENT_FUNCTION));
	if ((OBJECT_TYPE (procedure)) == TC_QUAD)
	  procedure = (MEMORY_REF (procedure, ENV_EXTENSION_PROCEDURE));
	do_printing (stream, procedure, false);
	outf (stream, ")");
	return;
      }

    case TC_EXTENDED_LAMBDA:
      if (Detailed)
	outf (stream, "[EXTENDED_LAMBDA (");
      do_printing (stream,
		   (MEMORY_REF ((MEMORY_REF (Expr, ELAMBDA_NAMES)), 1)),
		   false);
      if (Detailed)
	outf (stream, ") 0x%lx", ((long) Temp_Address));
      return;

    case TC_EXTENDED_PROCEDURE:
      if (Detailed)
	outf (stream, "[EXTENDED_PROCEDURE (");
      do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
      if (Detailed)
	outf (stream, ") 0x%lx]", ((long) Temp_Address));
      break;

    case TC_LAMBDA:
      if (Detailed)
	outf (stream, "[LAMBDA (");
      do_printing (stream,
		   (MEMORY_REF ((MEMORY_REF (Expr, LAMBDA_FORMALS)), 1)),
		  false);
      if (Detailed)
	outf (stream, ") 0x%lx]", ((long) Temp_Address));
      return;

    case TC_PRIMITIVE:
      outf (stream, "[PRIMITIVE ");
      print_primitive_name (stream, Expr);
      outf (stream, "]");
      return;

    case TC_PROCEDURE:
      if (Detailed)
	outf (stream, "[PROCEDURE (");
      do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
      if (Detailed)
	outf (stream, ") 0x%lx]", ((long) Temp_Address));
      return;

    case TC_REFERENCE_TRAP:
      {
	if ((OBJECT_DATUM (Expr)) <= TRAP_MAX_IMMEDIATE)
	  break;
	outf (stream, "[REFERENCE-TRAP");
	print_expression (stream, (MEMORY_REF (Expr, TRAP_TAG)), " tag");
	print_expression (stream, (MEMORY_REF (Expr, TRAP_EXTRA)), " extra");
	outf (stream, "]");
	return;
      }

    case TC_RETURN_CODE:
      outf (stream, "[RETURN_CODE ");
      print_return_name (stream, Expr);
      outf (stream, "]");
      return;

    case TC_CONSTANT:
      break;

    case TC_COMPILED_ENTRY:
      {
	long results [3];
	char * type_string;
	SCHEME_OBJECT filename;
	SCHEME_OBJECT entry;
	Boolean closure_p;

	entry = Expr;
	closure_p = false;
	compiled_entry_type (entry, (& (results [0])));
	switch (results [0])
	  {
	  case 0:
	    if (compiled_entry_closure_p (entry))
	      {
		type_string = "COMPILED_CLOSURE";
		entry = (compiled_closure_to_entry (entry));
		closure_p = true;
	      }
	    else
	      type_string = "COMPILED_PROCEDURE";
	    break;
	  case 1:
	    type_string = "COMPILED_RETURN_ADDRESS";
	    break;
	  case 2:
	    type_string = "COMPILED_EXPRESSION";
	    break;
	  default:
	    type_string = "COMPILED_ENTRY";
	    break;
	  }

	outf (stream, "[%s offset: 0x%lx entry: 0x%lx",
		 type_string,
		 ((long) (compiled_entry_to_block_offset (entry))),
		 ((long) (OBJECT_DATUM (entry))));
	if (closure_p)
	  outf (stream, " address: 0x%lx", ((long) Temp_Address));

	filename = (compiled_entry_debug_filename (entry));
	if (STRING_P (filename))
	  {
	    outf (stream, " file: ");
	    print_filename (stream, filename);
	  }
	else if (PAIR_P (filename))
	  {
	    outf (stream, " file: ");
	    print_filename (stream, (PAIR_CAR (filename)));
	    outf (stream, " block: %ld",
		    ((long) (FIXNUM_TO_LONG (PAIR_CDR (filename)))));
	  }
	outf (stream, "]");
	return;
      }

    default:
      break;
    }
  if (! handled_p)
    {
      if ((OBJECT_TYPE (Expr)) <= LAST_TYPE_CODE)
	outf (stream, "[%s", (Type_Names [OBJECT_TYPE (Expr)]));
      else
	outf (stream, "[0x%02x", (OBJECT_TYPE (Expr)));
    }
  outf (stream, " 0x%lx]", ((long) Temp_Address));
  return;
}

extern void
DEFUN (Debug_Print, (Expr, Detailed),
       SCHEME_OBJECT Expr AND Boolean Detailed)
{
  do_printing(console_output, Expr, Detailed);
  outf_flush_console ();
  return;
}

static Boolean
DEFUN (print_one_continuation_frame, (stream, Temp),
       outf_channel stream AND SCHEME_OBJECT Temp)
{
  SCHEME_OBJECT Expr;

  print_expression (stream, Temp, "Return code");
  outf (stream, "\n");
  Expr = (STACK_POP ());
  print_expression (stream, Expr, "Expression");
  outf (stream, "\n");
  if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) ||
      ((OBJECT_DATUM (Temp)) == RC_HALT))
    return (true);
  if ((OBJECT_DATUM (Temp)) == RC_JOIN_STACKLETS)
    Stack_Pointer = (Previous_Stack_Pointer (Expr));
  return (false);
}

extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT));

Boolean
DEFUN (Print_One_Continuation_Frame, (Temp), SCHEME_OBJECT Temp)
{
  return (print_one_continuation_frame (console_output, Temp));
}

/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
   stack; (b) Save_Cont pushes the expression first.
 */

void
DEFUN (Back_Trace, (stream), outf_channel stream)
{
  SCHEME_OBJECT Temp, * Old_Stack;

  Back_Trace_Entry_Hook();
  Old_Stack = Stack_Pointer;
  while (true)
  {
    if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0)
    {
      if ((STACK_LOC (0)) == Old_Stack)
	outf (stream, "\n[Invalid stack pointer.]\n");
      else
	outf (stream, "\n[Stack ends abruptly.]\n");
      break;
    }
    if (Return_Hook_Address == (STACK_LOC (0)))
    {
      Temp = (STACK_POP ());
      if (Temp != (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT)))
      {
        outf (stream, "\n--> Return trap is missing here <--\n");
      }
      else
      {
	outf (stream, "\n[Return trap found here as expected]\n");
        Temp = Old_Return_Code;
      }
    }
    else
    {
      Temp = (STACK_POP ());
    }
    if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE)
    {
      outf (stream, "{0x%x}", STACK_LOC(0));
      if (print_one_continuation_frame (stream, Temp))
	break;
    }
    else
    {
      outf (stream, "{0x%x}", STACK_LOC(0));
      print_expression (stream, Temp, "  ...");
      if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
      {
	Stack_Pointer = (STACK_LOC (- ((long) (OBJECT_DATUM (Temp)))));
        outf (stream, " (skipping)");
      }
      outf (stream, "\n");
    }
  }
  Stack_Pointer = Old_Stack;
  Back_Trace_Exit_Hook();
  outf_flush (stream);
  return;
}

void
DEFUN (print_stack, (sp), SCHEME_OBJECT * sp)
{
  SCHEME_OBJECT * saved_sp;

  saved_sp = Stack_Pointer;
  Stack_Pointer = sp;
  Back_Trace (console_output);
  Stack_Pointer = saved_sp;
  return;
}

extern void
DEFUN_VOID(Debug_Stack_Trace)
{
  print_stack(STACK_LOC(0));
}

static Boolean
DEFUN (print_primitive_name, (stream, primitive),
       outf_channel stream AND SCHEME_OBJECT primitive)
{
  CONST char * name = (PRIMITIVE_NAME (primitive));
  if (name == 0)
  {
    outf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive));
    return false;
  }
  else
  {
    outf (stream, "%s", name);
    return true;
  }
}

void
DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive)
{
  char buffer[40];
  int NArgs, i;

  outf_console ("Primitive: ");
  if (print_primitive_name (console_output, primitive))
    NArgs = (PRIMITIVE_ARITY (primitive));
  else
    NArgs = 3;	        /* Unknown primitive */

  outf_console ("\n");

  for (i = 0; i < NArgs; i++)
  {
    sprintf (buffer, "...Arg %ld", ((long) (i + 1)));
    print_expression (console_output, (STACK_REF (i)), buffer);
    outf_console ("\n");
  }
  return;
}

/* Code for interactively setting and clearing the interpreter
   debugging flags.  Invoked via the "D" command to the ^C
   handler or during each FASLOAD. */

#ifdef ENABLE_DEBUGGING_FLAGS

#ifndef MORE_DEBUG_FLAG_CASES
#define MORE_DEBUG_FLAG_CASES()
#endif

#ifndef MORE_DEBUG_FLAG_NAMES
#define MORE_DEBUG_FLAG_NAMES()
#endif

#ifndef SET_FLAG_HOOK
#define SET_FLAG_HOOK(hook)
#endif

#ifndef DEBUG_GETDEC
#define DEBUG_GETDEC debug_getdec
#endif

#define D_EVAL			0
#define D_HEX_INPUT		1
#define D_FILE_LOAD		2
#define D_RELOC			3
#define D_INTERN		4
#define D_CONT			5
#define D_PRIMITIVE		6
#define D_LOOKUP		7
#define D_DEFINE		8
#define D_GC			9
#define D_UPGRADE		10
#define D_DUMP			11
#define D_TRACE_ON_ERROR	12
#define D_PER_FILE		13
#define D_BIGNUM		14
#define D_FLUIDS		15

#ifndef LAST_SWITCH
#define LAST_SWITCH D_FLUIDS
#endif

static Boolean *
DEFUN (find_flag, (flag_number), int flag_number)
{
  switch (flag_number)
    {
    case D_EVAL:		return (&Eval_Debug);
    case D_HEX_INPUT:		return (&Hex_Input_Debug);
    case D_FILE_LOAD:		return (&File_Load_Debug);
    case D_RELOC:		return (&Reloc_Debug);
    case D_INTERN:		return (&Intern_Debug);
    case D_CONT:		return (&Cont_Debug);
    case D_PRIMITIVE:		return (&Primitive_Debug);
    case D_LOOKUP:		return (&Lookup_Debug) ;
    case D_DEFINE:		return (&Define_Debug);
    case D_GC:			return (&GC_Debug);
    case D_UPGRADE:		return (&Upgrade_Debug);
    case D_DUMP:		return (&Dump_Debug);
    case D_TRACE_ON_ERROR:	return (&Trace_On_Error);
    case D_PER_FILE:		return (&Per_File);
    case D_BIGNUM:		return (&Bignum_Debug);
    case D_FLUIDS:		return (&Fluids_Debug);
    MORE_DEBUG_FLAG_CASES ();
    default:			return (0);
    }
}

static char *
DEFUN (flag_name, (flag_number), int flag_number)
{
  switch (flag_number)
    {
    case D_EVAL:		return ("Eval_Debug");
    case D_HEX_INPUT:		return ("Hex_Input_Debug");
    case D_FILE_LOAD:		return ("File_Load_Debug");
    case D_RELOC:		return ("Reloc_Debug");
    case D_INTERN:		return ("Intern_Debug");
    case D_CONT:		return ("Cont_Debug");
    case D_PRIMITIVE:		return ("Primitive_Debug");
    case D_LOOKUP:		return ("Lookup_Debug");
    case D_DEFINE:		return ("Define_Debug");
    case D_GC:			return ("GC_Debug");
    case D_UPGRADE:		return ("Upgrade_Debug");
    case D_DUMP:		return ("Dump_Debug");
    case D_TRACE_ON_ERROR:	return ("Trace_On_Error");
    case D_PER_FILE:		return ("Per_File");
    case D_BIGNUM:		return ("Bignum_Debug");
    case D_FLUIDS:		return ("Fluids_Debug");
    MORE_DEBUG_FLAG_NAMES ();
    default:			return ("Unknown Debug Flag");
    }
}

static void
DEFUN (show_flags, (all), int all)
{
  int i;
  for (i = 0; (i <= LAST_SWITCH); i += 1)
    {
      int value = (* (find_flag (i)));
      if (all || value)
	outf (console_output, "Flag %ld (%s) is %s.\n",
		 ((long) i), (flag_name (i)), (value ? "set" : "clear"));
    }
  outf_flush_console();
  return;
}

static int
DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
{
  Boolean * flag = (find_flag (flag_number));
  if (flag == 0)
    show_flags (1);
  else
    {
      (*flag) = value;
      SET_FLAG_HOOK (flag);
    }
  return (0);
}

static int
DEFUN (debug_getdec, (string), CONST char * string)
{
  int result;

  sscanf (string, "%ld", (&result));
  return (result);
}

void
DEFUN_VOID (debug_edit_flags)
{
  char input_line [256];
  show_flags (0);
  while (1)
    {
      outf_console("Clear<number>, Set<number>, Done, ?, or Halt: ");
      outf_flush_console();
      {
	fgets (input_line, (sizeof (input_line)), stdin);
	switch (input_line[0])
	  {
	   case 'c':
	   case 'C':
	     set_flag ((DEBUG_GETDEC (input_line)), 0);
	     break;
	   case 's':
	   case 'S':
	     set_flag ((DEBUG_GETDEC (input_line)), 1);
	     break;
	   case 'd':
	   case 'D':
	     return;
	   case 'h':
	   case 'H':
	     termination_normal (0);
	   case '?':
	   default:
	     show_flags (1);
	     break;
	   }
      }
    }
}

#else /* not ENABLE_DEBUGGING_FLAGS */

void
DEFUN_VOID (debug_edit_flags)
{
  outf_error ("Not a debugging version.  No flags to handle.\n");
  outf_flush_error();
  return;
}

static int
DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
{
  signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
  /*NOTREACHED*/
  return (0);
}

#endif /* not ENABLE_DEBUGGING_FLAGS */

DEFINE_PRIMITIVE("SET-DEBUG-FLAGS!", Prim_set_debug_flags, 2, 2,
  "(SET-DEBUG-FLAGS! flag_number boolean)")
{
  PRIMITIVE_HEADER (2);
  set_flag ((arg_integer (1)), (BOOLEAN_ARG (2)));
  PRIMITIVE_RETURN (UNSPECIFIC);
}