![[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] / 43BSD / ucb / lisp / lisplib|
Return to trace.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-trace-
2: "$Header: /usr/lib/lisp/RCS/trace.l,v 1.2 83/08/15 22:30:36 jkf Exp $")
3:
4: ;---- The Joseph Lister Trace Package, v1
5: ; John Foderaro, Sept 1979
6: ;------------------------------------------------------------------;
7: ; Copyright (c) 1979 The Regents of the University of California ;
8: ; All rights reserved. ;
9: ;------------------------------------------------------------------;
10: (eval-when (eval)
11: (setq old-read-table-trace readtable)
12: (setq readtable (makereadtable t))
13: (setq old-uctolc-value (status uctolc))
14: (sstatus uctolc nil) ; turn off case conversion
15: (load 'charmac)
16: (setsyntax '\; 'macro 'zapline)
17: )
18:
19:
20:
21: ;----
22: ; trace uses these properties on the property list:
23: ; trace-orig-fcn: original occupant of the function cell
24: ; trace-trace-fcn: the value trace puts in the function cell
25: ; (used to check if the trace function has be overwritten).
26: ; trace-trace-args: the arguments when function was traced.
27: ; trace-printargs: function to print argument to function
28: ; trace-printres: function to print result of function
29:
30: (declare (nlambda T-status T-sstatus)
31: (special piport
32: if ifnot evalin evalout
33: printargs printres evfcn
34: traceenter traceexit
35: prinlevel prinlength
36: $$traced-functions$$ ; all functions being traced
37: $$functions-in-trace$$ ; active functions
38: $$funcargs-in-trace$$ ; arguments to active functions.
39: $tracemute ; if t, then enters and exits
40: ; are quiet, but info is still
41: ; kept so (tracedump) will work
42: trace-prinlevel ; default values
43: trace-prinlength
44: trace-printer ; function trace uses to print
45: ))
46:
47:
48:
49: (cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
50: (cond ((null (boundp '$$functions-in-trace$$)) (setq $$functions-in-trace$$ nil)))
51: (cond ((null (boundp '$$funcargs-in-trace$$)) (setq $$funcargs-in-trace$$ nil)))
52: (cond ((null (boundp '$tracemute)) (setq $tracemute nil)))
53: (cond ((null (boundp 'trace-prinlevel)) (setq trace-prinlevel 4)))
54: (cond ((null (boundp 'trace-prinlength)) (setq trace-prinlength 5)))
55: (cond ((null (boundp 'trace-printer)) (setq trace-printer 'Trace-print)))
56:
57: ;----> It is important that the trace package not use traced functions
58: ; thus we give the functions the trace package uses different
59: ; names and make them equivalent at this time to their
60: ; traceable counterparts.
61: (defun trace-startup-func nil
62: (do ((i '( (add1 T-add1)(append T-append)
63: (and T-and) (apply T-apply)
64: (cond T-cond) (cons T-cons) (delq T-delq)
65: (def T-def) (do T-do) (drain T-drain)
66: (dtpr T-dtpr) (eval T-eval)(funcall T-funcall)
67: (get T-get) (getd T-getd)(getdisc T-getdisc)
68: (greaterp T-greaterp)(lessp T-lessp)
69: (mapc T-mapc) (not T-not)(nreverse T-nreverse)
70: (patom T-patom) (print T-print) (prog T-prog)
71: (patom T-patom)(putd T-putd)
72: (putprop T-putprop)
73: (read T-read)(remprop T-remprop) (reverse T-reverse)
74: (return T-return)
75: (set T-set) (setq T-setq)
76: (status T-status) (sstatus T-sstatus)
77: (sub1 T-sub1) (terpr T-terpr)
78: (zerop T-zerop))
79: (cdr i)))
80: ((null i))
81: (putd (cadar i) (getd (caar i)))
82: (putprop (cadar i) t 'Untraceable)))
83:
84: (trace-startup-func)
85:
86:
87: (putprop 'quote t 'Untraceable) ; this prevents the common error
88: ; of (trace 'foo) from causing big
89: ; problems.
90:
91: ;--- trace - arg1,arg2, ... names of functions to trace
92: ; This is the main user callable trace routine.
93: ; work in progress, documentation incomplete since im not sure exactly
94: ; where this is going.
95: ;
96: (def trace
97: (nlambda (argl)
98: (prog (if ifnot evalin evalout funnm typ
99: funcd did break printargs printres evfcn traceenter traceexit
100: traceargs)
101:
102: ; turn off transfer table linkages if they are on
103: (cond ((T-status translink) (T-sstatus translink nil)))
104:
105: ; process each argument
106:
107: (do ((ll argl (cdr ll))
108: (funnm)
109: (funcd))
110: ((null ll))
111: (setq funnm (car ll)
112: if t
113: break nil
114: ifnot nil
115: evalin nil
116: evalout nil
117: printargs nil
118: printres nil
119: evfcn nil
120: traceenter 'T-traceenter
121: traceexit 'T-traceexit
122: traceargs nil)
123:
124: ; a list as an argument means that the user is specifying
125: ; conditions on the trace
126: (cond ((not (atom funnm))
127: (cond ((not (atom (setq funnm (car funnm))))
128: (T-print (car funnm))
129: (T-patom '" is non an function name")
130: (go botloop)))
131: ; remember the arguments in case a retrace is requested
132: (setq traceargs (cdar ll))
133: ; scan the arguments
134: (do ((rr (cdar ll) (cdr rr)))
135: ((null rr))
136: (cond ((memq (car rr) '(if ifnot evalin evalout
137: printargs printres evfcn
138: traceenter traceexit))
139: (T-set (car rr) (cadr rr))
140: (setq rr (cdr rr)))
141: ((eq (car rr) 'evalinout)
142: (setq evalin (setq evalout (cadr rr))
143: rr (cdr rr)))
144: ((eq (car rr) 'break)
145: (setq break t))
146: ((eq (car rr) 'lprint)
147: (setq printargs 'T-levprint
148: printres 'T-levprint))
149: (t (T-patom '"bad request: ")
150: (T-print (car rr))
151: (T-terpr)))))
152: (t (setq traceargs nil) ;no args given
153: ))
154:
155: ; if function is untraceable, print error message and skip
156: (cond ((get funnm 'Untraceable)
157: (setq did (cons `(,funnm untraceable) did))
158: (go botloop)))
159:
160:
161: ; Untrace before tracing
162: (let ((res (funcall 'untrace (list funnm))))
163: (cond (res (setq did (cons `(,funnm untraced) did)))))
164:
165: ; store the names of the arg printing routines if they are
166: ; different than print
167:
168: (cond (printargs (T-putprop funnm printargs 'trace-printargs)))
169: (cond (printres (T-putprop funnm printres 'trace-printres)))
170: (T-putprop funnm traceargs 'trace-trace-args)
171:
172: ; we must determine the type of function being traced
173: ; in order to create the correct replacement function
174:
175: (cond ((setq funcd (T-getd funnm))
176: (cond ((bcdp funcd) ; machine code
177: (cond ((or (eq 'lambda (T-getdisc funcd))
178: (eq 'nlambda (T-getdisc funcd))
179: (eq 'macro (T-getdisc funcd)))
180: (setq typ (T-getdisc funcd)))
181: ((stringp (T-getdisc funcd)) ; foreign func
182: (setq typ 'lambda)) ; close enough
183: (t (T-patom '"Unknown type of compiled function")
184: (T-print funnm)
185: (setq typ nil))))
186:
187: ((dtpr funcd) ; lisp coded
188: (cond ((or (eq 'lambda (car funcd))
189: (eq 'lexpr (car funcd)))
190: (setq typ 'lambda))
191: ((or (eq 'nlambda (car funcd))
192: (eq 'macro (car funcd)))
193: (setq typ (car funcd)))
194: (t (T-patom '"Bad function definition: ")
195: (T-print funnm)
196: (setq typ nil))))
197: ((arrayp funcd) ; array
198: (setq typ 'lambda))
199: (t (T-patom '"Bad function defintion: ")
200: (T-print funnm)))
201:
202: ; now that the arguments have been examined for this
203: ; function, do the tracing stuff.
204: ; First save the old function on the property list
205:
206: (T-putprop funnm funcd 'trace-orig-fcn)
207:
208: ; now build a replacement
209:
210: (cond
211: ((eq typ 'lambda)
212: (T-eval
213: `(T-def
214: ,funnm
215: (lexpr (T-nargs)
216: ((lambda (T-arglst T-res T-rslt
217: $$functions-in-trace$$
218: $$funcargs-in-trace$$)
219: (T-do ((i T-nargs (T-sub1 i)))
220: ((T-zerop i))
221: (T-setq T-arglst
222: (T-cons (arg i) T-arglst)))
223: (T-setq $$funcargs-in-trace$$
224: (T-cons T-arglst
225: $$funcargs-in-trace$$))
226: (T-cond ((T-setq T-res
227: (T-and ,if
228: (T-not ,ifnot)))
229: (,traceenter ',funnm T-arglst)
230: ,@(cond (evalin
231: `((T-patom ,'":in: ")
232: ,evalin
233: (T-terpr))))
234: (T-cond (,break
235: (trace-break)))))
236: (T-setq T-rslt
237: ,(cond
238: (evfcn)
239: (t `(T-apply
240: ',funcd
241: T-arglst))))
242: (T-cond (T-res
243: ,@(cond (evalout
244: `((T-patom ,'":out: ")
245: ,evalout
246: (T-terpr))))
247: (,traceexit ',funnm T-rslt)))
248: T-rslt)
249: nil nil nil
250: (T-cons ',funnm $$functions-in-trace$$)
251: $$funcargs-in-trace$$))))
252: (T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
253: (setq did (cons funnm did)
254: $$traced-functions$$ (cons funnm
255: $$traced-functions$$)))
256:
257: ((or (eq typ 'nlambda)
258: (eq typ 'macro))
259: (T-eval
260: `(T-def ,funnm
261: (,typ (T-arglst)
262: ((lambda (T-res T-rslt
263: $$functions-in-trace$$
264: $$funcargs-in-trace$$)
265: (T-setq $$funcargs-in-trace$$
266: (T-cons
267: T-arglst
268: $$funcargs-in-trace$$))
269: (T-cond ((T-setq
270: T-res
271: (T-and ,if
272: (not ,ifnot)))
273: (,traceenter
274: ',funnm
275: T-arglst)
276: ,evalin
277: (T-cond (,break
278: (trace-break)))))
279: (T-setq T-rslt
280: ,(cond
281: (evfcn `(,evfcn
282: ',funcd
283: T-arglst))
284: (t `(T-apply ',funcd
285: T-arglst))))
286: (T-cond (T-res
287: ,evalout
288: (,traceexit ',funnm T-rslt)))
289: T-rslt)
290: nil nil
291: (cons ',funnm $$functions-in-trace$$)
292: $$funcargs-in-trace$$))))
293: (T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
294: (setq did (cons funnm did)
295: $$traced-functions$$ (cons funnm
296: $$traced-functions$$)))
297:
298: (t (T-patom '"No such function as: ")
299: (T-print funnm)
300: (T-terpr)))))
301: botloop )
302: ; if given no args, just return the function currently being traced
303: (return (cond ((null argl) $$traced-functions$$)
304: (t (T-nreverse did)))))))
305:
306: ;--- untrace
307: ; (untrace foo bar baz)
308: ; untraces foo, bar and baz.
309: ; (untrace)
310: ; untraces all functions being traced.
311: ;
312:
313: (def untrace
314: (nlambda (argl)
315: (cond ((null argl) (setq argl $$traced-functions$$)))
316:
317: (do ((i argl (cdr i))
318: (tmp)
319: (curf)
320: (res))
321: ((null i)
322: (cond ((null $$traced-functions$$)
323: (setq $$functions-in-trace$$ nil)
324: (setq $$funcargs-in-trace$$ nil)))
325: res)
326: (cond ((and (T-getd (setq curf (car i)))
327: (eq (T-getd (car i))
328: (get (car i) 'trace-trace-fcn)))
329: ; we only want to restore the original definition
330: ; if this function has not been redefined!
331: ; we test this by checking to be sure that the
332: ; trace-trace-property is the same as the function
333: ; definition.
334: (T-putd curf (get curf 'trace-orig-fcn))
335: (T-remprop curf 'trace-orig-fcn)
336: (T-remprop curf 'trace-trace-fcn)
337: (T-remprop curf 'trace-trace-args)
338: (T-remprop curf 'entercount)
339: (setq $$traced-functions$$
340: (T-delq curf $$traced-functions$$))
341: (setq res (cons curf res)))))))
342:
343:
344: ;--- retrace :: trace again all function thought to be traced.
345: ;
346: (def retrace
347: (nlambda (args)
348: (cond ((null args) (setq args $$traced-functions$$)))
349: (mapcan '(lambda (fcn)
350: (cond ((and (symbolp fcn)
351: (not (eq (T-getd fcn)
352: (get fcn 'trace-trace-fcn))))
353:
354: (funcall 'trace
355: `((,fcn ,@(get fcn 'trace-trace-args)))))))
356: args)))
357:
358: ;--- tracedump :: dump the currently active trace frames
359: ;
360: (def tracedump
361: (lambda nil
362: (let (($tracemute nil))
363: (T-tracedump-recursive $$functions-in-trace$$
364: $$funcargs-in-trace$$))))
365:
366:
367: ;--- traceargs :: return list of args to currently entered traced functions
368: ; call is:
369: ; (traceargs foo) returns first call to foo starting at most current
370: ; (traceargs foo 3) returns args to third call to foo, starting at
371: ; most current
372: ;
373: (def traceargs
374: (nlambda (args)
375: (cond ((and args $$functions-in-trace$$)
376: (let ((name (car args))
377: (amt (cond ((numberp (cadr args)) (cadr args))
378: (t 1))))
379: (do ((fit $$functions-in-trace$$ (cdr fit))
380: (fat $$funcargs-in-trace$$ (cdr fat)))
381: ((null fit))
382: (cond ((eq name (car fit))
383: (cond ((zerop (setq amt (1- amt)))
384: (return (car fat))))))))))))
385:
386: ;--- T-tracedump-recursive
387: ; since the lists of functions being traced and arguments are in the reverse
388: ; of the order we want to print them, we recurse down the lists and on the
389: ; way back we print the information.
390: ;
391: (def T-tracedump-recursive
392: (lambda ($$functions-in-trace$$ $$funcargs-in-trace$$)
393: (cond ((null $$functions-in-trace$$))
394: (t (T-tracedump-recursive (cdr $$functions-in-trace$$)
395: (cdr $$funcargs-in-trace$$))
396: (T-traceenter (car $$functions-in-trace$$)
397: (car $$funcargs-in-trace$$))))))
398:
399:
400:
401: ;--- T-traceenter - funnm : name of function just entered
402: ; - count : count to print out
403: ; This routine is called to print the entry banner for a
404: ; traced function.
405: ;
406: (def T-traceenter
407: (lambda (name args)
408: (prog (count indent)
409: (cond ((not $tracemute)
410: (setq count 0 indent 0)
411: (do ((ll $$functions-in-trace$$ (cdr ll)))
412: ((null ll))
413: (cond ((eq (car ll) name) (setq count (1+ count))))
414: (setq indent (1+ indent)))
415:
416: (T-traceindent indent)
417: (T-print count)
418: (T-patom '" <Enter> ")
419: (T-print name)
420: (T-patom '" ")
421: (cond ((setq count (T-get name 'trace-printargs))
422: (funcall count args))
423: (t (funcall trace-printer args)))
424: (T-terpr))))))
425:
426: (def T-traceexit
427: (lambda (name res)
428: (prog (count indent)
429: (cond ((not $tracemute)
430: (setq count 0 indent 0)
431: (do ((ll $$functions-in-trace$$ (cdr ll)))
432: ((null ll))
433: (cond ((eq (car ll) name) (setq count (1+ count))))
434: (setq indent (1+ indent)))
435:
436:
437: (T-traceindent indent)
438: (T-print count)
439: (T-patom " <EXIT> ")
440: (T-print name)
441: (T-patom " ")
442:
443: (cond ((setq count (T-get name 'trace-printres))
444: (funcall count res))
445: (t (funcall trace-printer res)))
446:
447: (T-terpr))))))
448:
449:
450: ;--- Trace-printer
451: ; this is the default value of trace-printer. It prints a form after
452: ; binding prinlevel and prinlength.
453: ;
454: (def Trace-print
455: (lambda (form)
456: (let ((prinlevel trace-prinlevel)
457: (prinlength trace-prinlength))
458: (T-print form))))
459:
460: ; T-traceindent
461: ; - n : indent to column n
462:
463: (def T-traceindent
464: (lambda (col)
465: (do ((i col (1- i))
466: (char '| |))
467: ((< i 2))
468: (T-patom (cond ((eq char '| |) (setq char '\|))
469: (t (setq char '| |)))))))
470: ; from toplevel.l:
471: ;
472: ;--- read and print functions are user-selectable by just
473: ; assigning another value to top-level-print and top-level-read
474: ;
475: (declare (special top-level-read top-level-print))
476:
477: (defmacro top-print (&rest args)
478: `(cond (top-level-print (funcall top-level-print ,@args))
479: (t (T-print ,@args))))
480:
481: (defmacro top-read (&rest args)
482: `(cond ((and top-level-read
483: (T-getd top-level-read))
484: (funcall top-level-read ,@args))
485: (t (T-read ,@args))))
486:
487:
488: ; trace-break - this is the trace break loop
489: (def trace-break
490: (lambda nil
491: (prog (tracevalread piport)
492: (T-terpr) (T-patom '"[tracebreak]")
493: loop (T-terpr)
494: (T-patom '"T>")
495: (T-drain)
496: (cond ((or (eq nil (setq tracevalread
497: (car
498: (errset (top-read nil nil)))))
499: (and (dtpr tracevalread)
500: (eq 'tracereturn (car tracevalread))))
501: (T-terpr)
502: (return nil)))
503: (top-print (car (errset (T-eval tracevalread))))
504: (go loop))))
505:
506:
507: (def T-levprint
508: (lambda (x)
509: ((lambda (prinlevel prinlength)
510: (T-print x))
511: 3 10)))
512:
513:
514: (eval-when (eval)
515: (apply 'sstatus `(uctolc ,old-uctolc-value))
516: (setq readtable old-read-table-trace)
517: )
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.