/*
 * Lisp error handler
 * Don Hopkins
 */

#include "lisp.h"

/*
 * Error handling loop. Print the error message msg, and enter a command 
 * loop. The various useful debugging commands that can be used are 
 * documented by typing 'h'. The returned object is usualy returned
 * as a result by the calling procedure that encountered the error.
 */

object error(msg)
     char *msg;
{
  int huh = 0, c;
  char name[ATOM_SIZE];
  object obj;

  Ob_Push();

/*
 * Set up the I/O to go to the terminal.
 */

  push_stream(&Input_Stack, &Input_File, make_atom("/dev/tty"), "r");
  push_stream(&Output_Stack, &Output_File, make_atom("/dev/tty"), "w");

  fprintf(Output_File, "\n<* Error: %s *>", msg);

  while(1) {

    fprintf(Output_File, "\nDebug: ");
    fflush(Output_File);
    while (is_white(c = getc(Input_File))) ;

    switch (c) {

/* 
 * Help with the debugger.
 */

    case '?':
    case 'h':
      fputs("r expr - (print (read)), e - (print (eval (read))),\n",
	    Output_File);
      fputs("R expr - return (read), E expr - return (eval (read)),\n",
	    Output_File);
      fputs("v atom - atom value, b atom - atom binding,\n",
	    Output_File);
      fputs("a # - show atom, c # - show cons, n # - show number,\n",
	    Output_File);
      fputs("q - abort to top level, Q - quit lisp, h - help,\n",
	    Output_File);
      fputs("o - show Ob_List bindings, O - print raw Ob_List,\n",
	    Output_File);
      fputs("t - print back trace, A - print all atoms.\n",
	    Output_File);
      break;

/*
 * Abort to top level.
 */

    case EOF:
    case 'q':
      abort("debug");

/*
 * Quit lisp.
 */

    case 'Q':
      quit("debug");

/*
 * (print (read))
 */

    case 'r':
      Ob_Save(obj = sread());
      printcr(obj);
      Ob_Unbind();
      break;

/*
 * (print (eval (read)))
 */

    case 'e':
      Ob_Save(obj = sread());
      Ob_Save(obj = eval(obj));
      printcr(obj);
      Ob_Unbind();
      Ob_Unbind();
      break;

/*
 * Return (read).
 */

    case 'R':
      obj = sread();
      goto return_obj;

/*
 * Return (eval (read)).
 */

    case 'E':
      Ob_Save(obj = sread());
      obj = eval(obj);
      goto return_obj;

/*
 * Atom value.
 */

    case 'v':
      if (fscanf(Input_File, "%s", name) == 1)
	show_atom(find_atom(name));
      break;

/*
 * Atom binding.
 */

    case 'b':
      if (fscanf(Input_File, "%s", name) == 1)
	printcr(*find_variable(find_atom(name)));
      break;

/*
 * Show atom.
 */

    case 'a':
      if (fscanf(Input_File, "%d", &obj) == 1)
	show_atom(obj);
      break;
/*
 * Show cons.
 */

    case 'c':
      if (fscanf(Input_File, "%d", &obj) == 1)
	show_cons(obj);
      break;

/*
 * Show number.
 */

    case 'n':
      if (fscanf(Input_File, "%d", &obj) == 1)
	show_number(obj);
      break;
/*
 * Show bindings on Ob_List.
 */

    case 'o':
      show_ob();
      break;

/*
 * Print raw Ob_List.
 */

    case 'O':
      printcr(Ob_List);
      break;

/*
 * Print all atoms.
 */

    case 'A':
      dump_atoms();
      break;

/*
 * Print back trace.
 */

    case 't':
      back_trace();
      break;

/* 
 * Otherwise moan and complain.
 */

    default:
      fputs("<Huh?> ", Output_File);
      if (huh++ >= 5) {
	fputs("<Type h for help, Captain> ", Output_File);
	huh = 0;
      }
    }
  }

/*
 * Clean up and return an object.
 */

 return_obj:

  pop_input();
  pop_output();

  Ob_Pop();
  return(obj);
}

/*
 * Abort to lisp top level. Print the abort message msg, and jump to
 * the lisp warm start code..
 */

abort(msg)
     char *msg;
{
  fprintf(Output_File, "\n<* Abort: %s *>\n", msg);
  longjmp(Top_Level, 1);
}

/*
 * Quit out of the lisp interpreter. Print the quit message and exit.
 */

quit(msg)
     char *msg;
{
  fprintf(Output_File, "\n<* Quit: %s *>\n", msg);
  exit(0);
}

/*
 * Return a pointer to the human readable name of the type of obj.
 */

char *type_name(obj)
     object obj;
{
  int type = Type_Ord(obj);

  if (type < 1 || type > TYPE_COUNT) {
    sprintf(Type_Name[0], "unknown %x", type);
    type = 0;
  }
  return(Type_Name[type]);
}     

/*
 * Show an object's type and index.
 */

show_object(obj)
     object obj;
{
  fprintf(Output_File, "<%s %d>", type_name(obj), Object_Index(obj));
}

/*
 * Show all of the atoms in the atom table.
 */

dump_atoms()
{
  int atom;
  
  for (atom = 0; atom < Atom_Free; atom++)
    show_atom(atom);
}	

/*
 * Show the back trace of calls to apply.
 */

back_trace()
{
  object bt = Back_Trace;

  while (bt != Nil) {
    sprint(Cons_Car(Cons_Car(bt)));
    printcr(Cons_Cdr(Cons_Car(bt)));
    bt = Cons_Cdr(bt);
  }
}

/*
 * Show the bindings on the Ob_List, ignoring things bound to
 * <undefined>, which were put there by Ob_Save to protect them from
 * garbage collection.
 */

show_ob()
{
  object frame, obj;

  for (frame = Ob_List;
       frame != Nil;
       frame = Cons_Cdr(frame)) {
    fputs("Frame: ", Output_File);
    for (obj = Cons_Car(frame);
	 obj != Nil;
	 obj = Cons_Cdr(obj))
      if (Cons_Car(Cons_Car(obj)) != undefined_object)
	sprint(Cons_Car(obj));
    terpri();
  }
}

/*
 * Show the index, name, value of an atom, and its value's printed 
 * representation.
 */

show_atom(obj)
     object obj;
{
  obj = Set_Type(atom_object, obj);

  fprintf(Output_File, "atom %d: name = %s value = ",
	  Object_Index(obj), Atom_Name(obj));
  show_object(Atom_Value(obj));
  putc('\n', Output_File);
  printcr(Atom_Value(obj));
}

/*
 * Show the index, car, and cdr of a cons, and its printed representation.
 */

show_cons(obj)
     object obj;
{
  obj = Set_Type(cons_object, obj);

  fprintf(Output_File, "cons %d: car = ", Object_Index(obj));
  show_object(Cons_Car(obj));
  fputs(" cdr = ", Output_File);
  show_object(Cons_Cdr(obj));
  putc('\n', Output_File);
  printcr(obj);
}

/*
 * Show the index and value of a number.
 */

show_number(obj)
     object obj;
{
  obj = Set_Type(number_object, obj);

  fprintf(Output_File, "number %d: value = ", Object_Index(obj));
  printcr(obj);
  putc('\n', Output_File);
}

/*
 * Signal an error in the arguments to a function.
 */

object bad_args(msg)
     char *msg;
{
  char buf[80];

  sprintf(buf, "Bad arguments to %s", msg);
  return(error(buf));
}