/*    COPYRIGHT (c) 1992-1994 BY
 *    MITECH CORPORATION, ACTON, MASSACHUSETTS.
 *    See the source file SLIB.C for more information.

 (trace procedure1 procedure2 ...)
 (untrace procedure1 procedure2 ...)

 Currently only user-defined procedures can be traced.
 Fancy printing features such as indentation based on
 recursion level will also have to wait for a future version.


 */

#include <stdio.h>
#include <stdlib.h>
#include <setjmp.h>
#include "siod.h"
#include "siodp.h"

static void 
init_trace_version (void)
{
  setvar (cintern ("*trace-version*"),
	  cintern ("$Id$"),
	  NIL);
}


static long tc_closure_traced = 0;

static LISP sym_traced = NIL;
static LISP sym_quote = NIL;
static LISP sym_begin = NIL;

LISP ltrace_fcn_name (LISP body);
LISP ltrace_1 (LISP fcn_name, LISP env);
LISP ltrace (LISP fcn_names, LISP env);
LISP luntrace_1 (LISP fcn);
LISP luntrace (LISP fcns);
static void ct_gc_scan (LISP ptr);
static LISP ct_gc_mark (LISP ptr);
void ct_prin1 (LISP ptr, struct gen_printio *f);
LISP ct_eval (LISP ct, LISP * px, LISP * penv);

LISP 
ltrace_fcn_name (LISP body)
{
  LISP tmp;
  if NCONSP
    (body) return (NIL);
  if NEQ
    (CAR (body), sym_begin) return (NIL);
  tmp = CDR (body);
  if NCONSP
    (tmp) return (NIL);
  tmp = CAR (tmp);
  if NCONSP
    (tmp) return (NIL);
  if NEQ
    (CAR (tmp), sym_quote) return (NIL);
  tmp = CDR (tmp);
  if NCONSP
    (tmp) return (NIL);
  return (CAR (tmp));
}

LISP 
ltrace_1 (LISP fcn_name, LISP env)
{
  LISP fcn, code;
  fcn = leval (fcn_name, env);
  if (TYPE (fcn) == tc_closure)
    {
      code = fcn->storage_as.closure.code;
      if NULLP
	(ltrace_fcn_name (cdr (code)))
	  setcdr (code, cons (sym_begin,
			      cons (cons (sym_quote, cons (fcn_name, NIL)),
				    cons (cdr (code), NIL))));
      fcn->type = tc_closure_traced;
    }
  else if (TYPE (fcn) == tc_closure_traced)
    ;
  else
    my_err ("not a closure, cannot trace", fcn);
  return (NIL);
}

LISP 
ltrace (LISP fcn_names, LISP env)
{
  LISP l;
  for (l = fcn_names; NNULLP (l); l = cdr (l))
    ltrace_1 (car (l), env);
  return (NIL);
}

LISP 
luntrace_1 (LISP fcn)
{
  if (TYPE (fcn) == tc_closure)
    ;
  else if (TYPE (fcn) == tc_closure_traced)
    fcn->type = tc_closure;
  else
    my_err ("not a closure, cannot untrace", fcn);
  return (NIL);
}

LISP 
luntrace (LISP fcns)
{
  LISP l;
  for (l = fcns; NNULLP (l); l = cdr (l))
    luntrace_1 (car (l));
  return (NIL);
}

static void 
ct_gc_scan (LISP ptr)
{
  CAR (ptr) = gc_relocate (CAR (ptr));
  CDR (ptr) = gc_relocate (CDR (ptr));
}

static LISP 
ct_gc_mark (LISP ptr)
{
  gc_mark (ptr->storage_as.closure.code);
  return (ptr->storage_as.closure.env);
}

void 
ct_prin1 (LISP ptr, struct gen_printio *f)
{
  gput_st (f, "#<CLOSURE(TRACED) ");
  lprin1g (car (ptr->storage_as.closure.code), f);
  gput_st (f, " ");
  lprin1g (cdr (ptr->storage_as.closure.code), f);
  gput_st (f, ">");
}

LISP 
ct_eval (LISP ct, LISP * px, LISP * penv)
{
  LISP fcn_name, args, env, result, l;
  fcn_name = ltrace_fcn_name (cdr (ct->storage_as.closure.code));
  args = leval_args (CDR (*px), *penv);
  fput_st (stdout, "->");
  lprin1f (fcn_name, stdout);
  for (l = args; NNULLP (l); l = cdr (l))
    {
      fput_st (stdout, " ");
      lprin1f (car (l), stdout);
    }
  fput_st (stdout, "\n");
  env = extend_env (args,
		    car (ct->storage_as.closure.code),
		    ct->storage_as.closure.env);
  result = leval (cdr (ct->storage_as.closure.code), env);
  fput_st (stdout, "<-");
  lprin1f (fcn_name, stdout);
  fput_st (stdout, " ");
  lprin1f (result, stdout);
  fput_st (stdout, "\n");
  *px = result;
  return (NIL);
}

void 
init_trace (void)
{
  long j;
  tc_closure_traced = allocate_user_tc ();
  set_gc_hooks (tc_closure_traced,
		NULL,
		ct_gc_mark,
		ct_gc_scan,
		NULL,
		&j);
  gc_protect_sym (&sym_traced, "*traced*");
  setvar (sym_traced, NIL, NIL);
  gc_protect_sym (&sym_begin, "begin");
  gc_protect_sym (&sym_quote, "quote");
  set_print_hooks (tc_closure_traced, ct_prin1);
  set_eval_hooks (tc_closure_traced, ct_eval);
  init_fsubr ("trace", ltrace);
  init_lsubr ("untrace", luntrace);
  init_trace_version ();
}