20 #define tc_closure_traced tc_sys_1
22 static LISP sym_traced = NIL;
23 static LISP sym_quote = NIL;
24 static LISP sym_begin = NIL;
26 LISP ltrace_fcn_name(LISP body);
27 LISP ltrace_1(LISP fcn_name,LISP env);
28 LISP ltrace(LISP fcn_names,LISP env);
29 LISP luntrace_1(LISP fcn);
30 LISP luntrace(LISP fcns);
31 static void ct_gc_scan(LISP ptr);
32 static LISP ct_gc_mark(LISP ptr);
33 void ct_prin1(LISP ptr,FILE *f);
34 LISP ct_eval(LISP ct,LISP *px,LISP *penv);
36 LISP ltrace_fcn_name(LISP body)
38 if NCONSP(body) return(NIL);
39 if NEQ(CAR(body),sym_begin) return(NIL);
41 if NCONSP(tmp) return(NIL);
43 if NCONSP(tmp) return(NIL);
44 if NEQ(CAR(tmp),sym_quote) return(NIL);
46 if NCONSP(tmp) return(NIL);
49 LISP ltrace_1(LISP fcn_name,LISP env)
51 fcn = leval(fcn_name,env);
54 code = fcn->storage_as.closure.code;
55 if NULLP(ltrace_fcn_name(cdr(code)))
56 setcdr(code,cons(sym_begin,
57 cons(cons(sym_quote,cons(fcn_name,NIL)),
58 cons(cdr(code),NIL))));
59 fcn->type = tc_closure_traced;
61 case tc_closure_traced:
64 err("not a closure, cannot trace",fcn);}
67 LISP ltrace(LISP fcn_names,LISP env)
69 for(l=fcn_names;NNULLP(l);l=cdr(l))
73 LISP luntrace_1(LISP fcn)
77 case tc_closure_traced:
78 fcn->type = tc_closure;
81 err(
"not a closure, cannot untrace",fcn);}
84 LISP luntrace(LISP fcns)
86 for(l=fcns;NNULLP(l);l=cdr(l))
90 static void ct_gc_scan(LISP ptr)
91 {CAR(ptr) = gc_relocate(CAR(ptr));
92 CDR(ptr) = gc_relocate(CDR(ptr));}
94 static LISP ct_gc_mark(LISP ptr)
95 {gc_mark(ptr->storage_as.closure.code);
96 return(ptr->storage_as.closure.env);}
98 void ct_prin1(LISP ptr,FILE *f)
99 {fput_st(f,
"#<CLOSURE(TRACED) ");
100 lprin1f(car(ptr->storage_as.closure.code),f);
102 lprin1f(cdr(ptr->storage_as.closure.code),f);
105 LISP ct_eval(LISP ct,LISP *px,LISP *penv)
106 {LISP fcn_name,args,env,result,l;
107 fcn_name = ltrace_fcn_name(cdr(ct->storage_as.closure.code));
108 args = leval_args(CDR(*px),*penv);
109 fput_st(stdout,
"->");
110 lprin1f(fcn_name,stdout);
111 for(l=args;NNULLP(l);l=cdr(l))
112 {fput_st(stdout,
" ");
113 lprin1f(car(l),stdout);}
114 fput_st(stdout,
"\n");
115 env = extend_env(args,
116 car(ct->storage_as.closure.code),
117 ct->storage_as.closure.env);
118 result = leval(cdr(ct->storage_as.closure.code),env);
119 fput_st(stdout,
"<-");
120 lprin1f(fcn_name,stdout);
122 lprin1f(result,stdout);
123 fput_st(stdout,
"\n");
127 void init_trace(
void)
129 set_gc_hooks(tc_closure_traced,
137 gc_protect_sym(&sym_traced,
"*traced*");
138 setvar(sym_traced,NIL,NIL);
139 gc_protect_sym(&sym_begin,
"begin");
140 gc_protect_sym(&sym_quote,
"quote");
141 set_print_hooks(tc_closure_traced,ct_prin1,NULL);
142 set_eval_hooks(tc_closure_traced,ct_eval);
143 init_fsubr(
"trace",ltrace,
144 "(trace FUNCS ENV)\n\
146 init_lsubr(
"untrace",luntrace,