149 lines
3.6 KiB
C++
149 lines
3.6 KiB
C++
/* 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 <cstdio>
|
|
#include <setjmp.h>
|
|
#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,"#<CLOSURE(TRACED) ");
|
|
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,
|
|
0,
|
|
NULL,
|
|
ct_gc_mark,
|
|
ct_gc_scan,
|
|
NULL,
|
|
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,NULL);
|
|
set_eval_hooks(tc_closure_traced,ct_eval);
|
|
init_fsubr("trace",ltrace,
|
|
"(trace FUNCS ENV)\n\
|
|
Trace FUNCS.");
|
|
init_lsubr("untrace",luntrace,
|
|
"(untrace FUNCS)\n\
|
|
Untrace FUNCS.");}
|