![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to trace.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib|
Return to trace.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib |
1.1 root 1: ;---- The Joseph Lister Trace Package, v1
2: ; John Foderaro, Sept 1979
3: ;------------------------------------------------------------------;
4: ; Copyright (c) 1979 The Regents of the University of California ;
5: ; All rights reserved. ;
6: ;------------------------------------------------------------------;
7: (eval-when (eval)
8: (setq old-read-table-trace readtable)
9: (setq readtable (makereadtable t))
10: (load 'backquote))
11: (cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
12: (setq $$trace-indent$$ 0)
13:
14: ;----> It is important that the trace package not use traced functions
15: ; thus we give the functions the trace package uses different
16: ; names and make them equivalent at this time to their
17: ; traceable counterparts.
18:
19: (do ((i '( (add1 T-add1)(append T-append)
20: (apply T-apply)(atom T-atom)(bcdp T-bcdp)
21: (car T-car)(cadr T-cadr)(cdr T-cdr)(cons T-cons) (delq T-delq)
22: (drain T-drain)
23: (dtpr T-dtpr) (eq T-eq) (eval T-eval)(funcall T-funcall)
24: (get T-get) (getd T-getd)(getdisc T-getdisc)
25: (greaterp T-greaterp)(memq T-memq)(not T-not)
26: (null T-null) (patom T-patom) (print T-print)
27: (prog T-prog)
28: (or T-or) (patom T-patom)(putd T-putd)
29: (putprop T-putprop)
30: (read T-read)(remprop T-remprop) (reverse T-reverse)
31: (set T-set)
32: (setq T-setq) (sub1 T-sub1) (terpr T-terpr)
33: (zerop T-zerop))
34: (cdr i)))
35: ((null i))
36: (putd (cadar i) (getd (caar i)))
37: (putprop (cadar i) t 'Untraceable))
38:
39: ;--- trace - arg1,arg2, ... names of functions to trace
40: ; This is the main user callable trace routine.
41: ; work in progress, documentation incomplete since im not sure exactly
42: ; where this is going.
43: ;
44: (def trace
45: (nlambda (argl)
46: (prog (if ifnot evalin evalout funnm funcd did break)
47:
48: ; process each argument
49:
50: (do ((ll argl (cdr ll))
51: (funnm)
52: (funcd))
53: ((T-null ll))
54: (T-setq funnm (car ll)
55: if t
56: break nil
57: ifnot nil
58: evalin nil
59: evalout nil)
60:
61: ; a list as an argument means that the user is specifying
62: ; conditions on the trace
63: (cond ((T-not (atom funnm))
64: (cond ((T-not (T-atom (T-setq funnm (car funnm))))
65: (T-print (car funnm))
66: (T-patom '" is non an function name")
67: (go botloop)))
68: (do ((rr (cdar ll) (cdr rr)))
69: ((T-null rr))
70: (cond ((T-memq (T-car rr) '(if ifnot evalin evalout))
71: (T-set (T-car rr) (T-cadr rr))
72: (T-setq rr (T-cdr rr)))
73: ((T-eq (T-car rr) 'evalinout)
74: (T-setq evalin (T-setq evalout (T-cadr rr))
75: rr (T-cdr rr)))
76: ((T-eq (T-car rr) 'break)
77: (T-setq break t))
78: (t (T-patom '"bad request ")
79: (T-print (T-car rr)))))))
80:
81:
82: ; if function is already traced, untrace it first
83: (cond ((get funnm 'T-original)
84: (apply 'untrace `(,funnm))
85: (T-setq did (T-cons `(,funnm untraced) did))))
86:
87: ; we must determine the type of function being traced
88: ; in order to create the correct replacement function
89:
90: (cond ((T-setq funcd (T-getd funnm))
91: (cond ((T-bcdp funcd) ; machine code
92: (cond ((T-eq 'lambda (T-getdisc funcd))
93: (T-setq typ 'lambda))
94: ((T-eq 'nlambda (T-getdisc funcd))
95: (T-setq typ 'nlambda))
96: (t (T-patom '"Unknown type of compiled function")
97: (T-print funnm)
98: (T-setq typ nil))))
99:
100: ((T-dtpr funcd) ; lisp coded
101: (cond ((T-or (T-eq 'lambda (T-car funcd))
102: (T-eq 'lexpr (T-car funcd)))
103: (T-setq typ 'lambda))
104: ((T-or (T-eq 'nlambda (T-car funcd))
105: (T-eq 'macro (T-car funcd)))
106: (T-setq typ 'nlambda))
107: (t (T-patom '"Bad function definition: ")
108: (T-print funnm)
109: (T-setq typ nil))))
110: (t (T-patom '"Bad function defintion: ")
111: (T-print funnm)))
112:
113: ; now that the arguments have been examined for this
114: ; function, do the tracing stuff.
115: ; First save the old function on the property list
116:
117: (T-putprop funnm funcd 'T-original)
118:
119: ; now build a replacement
120:
121: (cond ((T-eq typ 'lambda)
122: (T-eval
123: `(def ,funnm
124: (lexpr (nargs)
125: (prog (T-arglst T-res T-rslt)
126: (do ((i nargs (T-sub1 i)))
127: ((T-zerop i))
128: (T-setq T-arglst
129: (T-cons (arg i) T-arglst)))
130: (cond ((T-setq T-res
131: (and ,if
132: (not ,ifnot)))
133: (T-traceenter ,funnm)
134: (T-print T-arglst)
135: (T-terpr)
136: ,evalin
137: (cond (,break (trace-break)))))
138: (T-setq T-rslt
139: (T-apply ',funcd T-arglst))
140: (cond (T-res
141: ,evalout
142: (T-traceexit ',funnm T-rslt)
143: (T-terpr)))
144: (return T-rslt)))))
145: (T-setq did (T-cons funnm did)
146: $$traced-functions$$ (cons funnm
147: $$traced-functions$$)))
148:
149: ((T-eq typ 'nlambda)
150: (T-eval
151: `(def ,funnm
152: (nlambda (T-arglst)
153: (prog ( T-res T-rslt)
154: (cond ((T-setq T-res
155: (and ,if
156: (not ,ifnot)))
157: (T-traceenter ,funnm)
158: (T-print T-arglst)
159: (T-terpr)
160: ,evalin
161: (cond (,break (trace-break)))))
162: (T-setq T-rslt
163: (T-apply ',funcd T-arglst))
164: (cond (T-res
165: ,evalout
166: (T-traceexit ',funnm T-rslt)
167: (T-terpr)))
168: (return T-rslt)))))
169: (T-setq did (T-cons funnm did)
170: $$traced-functions$$ (T-cons funnm
171: $$traced-functions$$)))
172:
173: (t (T-patom '"No such function as: ")
174: (T-print funnm)
175: (T-terpr))))))
176: (return (nreverse did)))))
177:
178:
179:
180: (def untrace
181: (nlambda (argl)
182: (cond ((T-null argl) (T-setq argl $$traced-functions$$)))
183:
184: (do ((i argl (T-cdr i))
185: (curf)
186: (res))
187: ((T-null i)
188: (cond ((T-null $$traced-functions$$)
189: (T-setq $$trace-indent$$ 0)))
190: res)
191: (cond ((T-setq tmp (T-get (T-setq curf (T-car i)) 'T-original))
192: (T-putd curf tmp)
193: (T-remprop curf 'T-original)
194: (T-remprop curf 'entercount)
195: (T-setq $$traced-functions$$
196: (T-delq curf $$traced-functions$$))
197: (T-setq res (T-cons curf res)))
198: (t (T-setq res (T-cons `(,curf not traced) res)))))))
199:
200:
201: ;--- T-traceenter - funnm : name of function just entered
202: ; - count : count to print out
203: ; This routine is called to print the entry banner for a
204: ; traced function.
205: ;
206: (def T-traceenter
207: (nlambda (nm)
208: (T-prog (name count)
209: (T-setq name (T-car nm))
210: (cond ((T-null (T-setq count (T-get name 'entercount)))
211: (T-setq count 1)))
212: (T-putprop name (add1 count) 'entercount)
213:
214: (do ((i 1 (T-add1 i)))
215: ((T-greaterp i $$trace-indent$$))
216: (T-patom '" "))
217: (T-setq $$trace-indent$$ (T-add1 $$trace-indent$$))
218: (T-print count)
219: (T-patom '" <Enter> ")
220: (T-print name)
221: (T-patom '" "))))
222:
223: (def T-traceexit
224: (lambda (name retval)
225: (T-prog (count)
226: (T-putprop name
227: (T-setq count (T-sub1 (T-get name 'entercount)))
228: 'entercount)
229: (do ((i 1 (T-add1 i))
230: (over (T-setq $$trace-indent$$ (T-sub1 $$trace-indent$$))))
231: ((T-greaterp i over))
232: (T-patom '" "))
233:
234: (T-print count)
235: (T-patom '" <EXIT> ")
236: (T-print name)
237: (T-patom '" ")
238: (T-print retval)
239: (return retval))))
240:
241: ; trace-break - this is the trace break loop
242: (def trace-break
243: (lambda nil
244: (prog (tracevalread)
245: (T-terpr) (T-patom '"[tracebreak]")
246: loop (T-terpr)
247: (T-patom '"T>")
248: (T-drain)
249: (cond ((eq '<EOF> (T-setq tracevalread
250: (car
251: (errset (T-read nil '<EOF>)))))
252: (return nil)))
253: (T-print (car (errset (T-eval tracevalread))))
254: (go loop))))
255:
256: (eval-when (eval)
257: (setq readtable old-read-table-trace))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.