Category : C Source Code
Archive   : SIOD30.ZIP
Filename : TRACE.C

 
Output of file : TRACE.C contained in archive : SIOD30.ZIP

/* 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
#include
#include "siod.h"
#include "siodp.h"

#define tc_closure_traced tc_sys_1

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,FILE *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);
switch TYPE(fcn)
{case 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;
break;
case tc_closure_traced:
break;
default:
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)
{switch TYPE(fcn)
{case tc_closure:
break;
case tc_closure_traced:
fcn->type = tc_closure;
break;
default:
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,FILE *f)
{fput_st(f,"# lprin1f(car(ptr->storage_as.closure.code),f);
fput_st(f," ");
lprin1f(cdr(ptr->storage_as.closure.code),f);
fput_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;
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);}