Edinburgh Speech Tools 2.4-release
trace.cc
1/* COPYRIGHT (c) 1992-1994 BY
2 * MITECH CORPORATION, ACTON, MASSACHUSETTS.
3 * See the source file SLIB.C for more information.
4
5(trace procedure1 procedure2 ...)
6(untrace procedure1 procedure2 ...)
7
8Currently only user-defined procedures can be traced.
9Fancy printing features such as indentation based on
10recursion level will also have to wait for a future version.
11
12
13 */
14
15#include <cstdio>
16#include <setjmp.h>
17#include "siod.h"
18#include "siodp.h"
19
20#define tc_closure_traced tc_sys_1
21
22static LISP sym_traced = NIL;
23static LISP sym_quote = NIL;
24static LISP sym_begin = NIL;
25
26LISP ltrace_fcn_name(LISP body);
27LISP ltrace_1(LISP fcn_name,LISP env);
28LISP ltrace(LISP fcn_names,LISP env);
29LISP luntrace_1(LISP fcn);
30LISP luntrace(LISP fcns);
31static void ct_gc_scan(LISP ptr);
32static LISP ct_gc_mark(LISP ptr);
33void ct_prin1(LISP ptr,FILE *f);
34LISP ct_eval(LISP ct,LISP *px,LISP *penv);
35
36LISP ltrace_fcn_name(LISP body)
37{LISP tmp;
38 if NCONSP(body) return(NIL);
39 if NEQ(CAR(body),sym_begin) return(NIL);
40 tmp = CDR(body);
41 if NCONSP(tmp) return(NIL);
42 tmp = CAR(tmp);
43 if NCONSP(tmp) return(NIL);
44 if NEQ(CAR(tmp),sym_quote) return(NIL);
45 tmp = CDR(tmp);
46 if NCONSP(tmp) return(NIL);
47 return(CAR(tmp));}
48
49LISP ltrace_1(LISP fcn_name,LISP env)
50{LISP fcn,code;
51 fcn = leval(fcn_name,env);
52 switch TYPE(fcn)
53 {case tc_closure:
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;
60 break;
61 case tc_closure_traced:
62 break;
63 default:
64 err("not a closure, cannot trace",fcn);}
65 return(NIL);}
66
67LISP ltrace(LISP fcn_names,LISP env)
68{LISP l;
69 for(l=fcn_names;NNULLP(l);l=cdr(l))
70 ltrace_1(car(l),env);
71 return(NIL);}
72
73LISP luntrace_1(LISP fcn)
74{switch TYPE(fcn)
75 {case tc_closure:
76 break;
77 case tc_closure_traced:
78 fcn->type = tc_closure;
79 break;
80 default:
81 err("not a closure, cannot untrace",fcn);}
82 return(NIL);}
83
84LISP luntrace(LISP fcns)
85{LISP l;
86 for(l=fcns;NNULLP(l);l=cdr(l))
87 luntrace_1(car(l));
88 return(NIL);}
89
90static void ct_gc_scan(LISP ptr)
91{CAR(ptr) = gc_relocate(CAR(ptr));
92 CDR(ptr) = gc_relocate(CDR(ptr));}
93
94static LISP ct_gc_mark(LISP ptr)
95{gc_mark(ptr->storage_as.closure.code);
96 return(ptr->storage_as.closure.env);}
97
98void ct_prin1(LISP ptr,FILE *f)
99{fput_st(f,"#<CLOSURE(TRACED) ");
100 lprin1f(car(ptr->storage_as.closure.code),f);
101 fput_st(f," ");
102 lprin1f(cdr(ptr->storage_as.closure.code),f);
103 fput_st(f,">");}
104
105LISP 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);
121 fput_st(stdout," ");
122 lprin1f(result,stdout);
123 fput_st(stdout,"\n");
124 *px = result;
125 return(NIL);}
126
127void init_trace(void)
128{long j;
129 set_gc_hooks(tc_closure_traced,
130 0,
131 NULL,
132 ct_gc_mark,
133 ct_gc_scan,
134 NULL,
135 NULL,
136 &j);
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\
145 Trace FUNCS.");
146 init_lsubr("untrace",luntrace,
147 "(untrace FUNCS)\n\
148 Untrace FUNCS.");}