Edinburgh Speech Tools  2.4-release
 All Classes Functions Variables Typedefs Enumerations Enumerator Friends Pages
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 
8 Currently only user-defined procedures can be traced.
9 Fancy printing features such as indentation based on
10 recursion 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 
22 static LISP sym_traced = NIL;
23 static LISP sym_quote = NIL;
24 static LISP sym_begin = NIL;
25 
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);
35 
36 LISP 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 
49 LISP 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 
67 LISP 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 
73 LISP 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 
84 LISP luntrace(LISP fcns)
85 {LISP l;
86  for(l=fcns;NNULLP(l);l=cdr(l))
87  luntrace_1(car(l));
88  return(NIL);}
89 
90 static void ct_gc_scan(LISP ptr)
91 {CAR(ptr) = gc_relocate(CAR(ptr));
92  CDR(ptr) = gc_relocate(CDR(ptr));}
93 
94 static LISP ct_gc_mark(LISP ptr)
95 {gc_mark(ptr->storage_as.closure.code);
96  return(ptr->storage_as.closure.env);}
97 
98 void 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 
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);
121  fput_st(stdout," ");
122  lprin1f(result,stdout);
123  fput_st(stdout,"\n");
124  *px = result;
125  return(NIL);}
126 
127 void 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.");}