| /* 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 <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 = (short) tc_closure_traced;} |
| else if (TYPE(fcn) == tc_closure_traced) |
| ; |
| else |
| 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 |
| 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 __stdcall 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();} |