4.3BSD/usr/lib/lisp/trace.l
(setq rcs-trace-
"$Header: /usr/lib/lisp/RCS/trace.l,v 1.2 83/08/15 22:30:36 jkf Exp $")
;---- The Joseph Lister Trace Package, v1
; John Foderaro, Sept 1979
;------------------------------------------------------------------;
; Copyright (c) 1979 The Regents of the University of California ;
; All rights reserved. ;
;------------------------------------------------------------------;
(eval-when (eval)
(setq old-read-table-trace readtable)
(setq readtable (makereadtable t))
(setq old-uctolc-value (status uctolc))
(sstatus uctolc nil) ; turn off case conversion
(load 'charmac)
(setsyntax '\; 'macro 'zapline)
)
;----
; trace uses these properties on the property list:
; trace-orig-fcn: original occupant of the function cell
; trace-trace-fcn: the value trace puts in the function cell
; (used to check if the trace function has be overwritten).
; trace-trace-args: the arguments when function was traced.
; trace-printargs: function to print argument to function
; trace-printres: function to print result of function
(declare (nlambda T-status T-sstatus)
(special piport
if ifnot evalin evalout
printargs printres evfcn
traceenter traceexit
prinlevel prinlength
$$traced-functions$$ ; all functions being traced
$$functions-in-trace$$ ; active functions
$$funcargs-in-trace$$ ; arguments to active functions.
$tracemute ; if t, then enters and exits
; are quiet, but info is still
; kept so (tracedump) will work
trace-prinlevel ; default values
trace-prinlength
trace-printer ; function trace uses to print
))
(cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
(cond ((null (boundp '$$functions-in-trace$$)) (setq $$functions-in-trace$$ nil)))
(cond ((null (boundp '$$funcargs-in-trace$$)) (setq $$funcargs-in-trace$$ nil)))
(cond ((null (boundp '$tracemute)) (setq $tracemute nil)))
(cond ((null (boundp 'trace-prinlevel)) (setq trace-prinlevel 4)))
(cond ((null (boundp 'trace-prinlength)) (setq trace-prinlength 5)))
(cond ((null (boundp 'trace-printer)) (setq trace-printer 'Trace-print)))
;----> It is important that the trace package not use traced functions
; thus we give the functions the trace package uses different
; names and make them equivalent at this time to their
; traceable counterparts.
(defun trace-startup-func nil
(do ((i '( (add1 T-add1)(append T-append)
(and T-and) (apply T-apply)
(cond T-cond) (cons T-cons) (delq T-delq)
(def T-def) (do T-do) (drain T-drain)
(dtpr T-dtpr) (eval T-eval)(funcall T-funcall)
(get T-get) (getd T-getd)(getdisc T-getdisc)
(greaterp T-greaterp)(lessp T-lessp)
(mapc T-mapc) (not T-not)(nreverse T-nreverse)
(patom T-patom) (print T-print) (prog T-prog)
(patom T-patom)(putd T-putd)
(putprop T-putprop)
(read T-read)(remprop T-remprop) (reverse T-reverse)
(return T-return)
(set T-set) (setq T-setq)
(status T-status) (sstatus T-sstatus)
(sub1 T-sub1) (terpr T-terpr)
(zerop T-zerop))
(cdr i)))
((null i))
(putd (cadar i) (getd (caar i)))
(putprop (cadar i) t 'Untraceable)))
(trace-startup-func)
(putprop 'quote t 'Untraceable) ; this prevents the common error
; of (trace 'foo) from causing big
; problems.
;--- trace - arg1,arg2, ... names of functions to trace
; This is the main user callable trace routine.
; work in progress, documentation incomplete since im not sure exactly
; where this is going.
;
(def trace
(nlambda (argl)
(prog (if ifnot evalin evalout funnm typ
funcd did break printargs printres evfcn traceenter traceexit
traceargs)
; turn off transfer table linkages if they are on
(cond ((T-status translink) (T-sstatus translink nil)))
; process each argument
(do ((ll argl (cdr ll))
(funnm)
(funcd))
((null ll))
(setq funnm (car ll)
if t
break nil
ifnot nil
evalin nil
evalout nil
printargs nil
printres nil
evfcn nil
traceenter 'T-traceenter
traceexit 'T-traceexit
traceargs nil)
; a list as an argument means that the user is specifying
; conditions on the trace
(cond ((not (atom funnm))
(cond ((not (atom (setq funnm (car funnm))))
(T-print (car funnm))
(T-patom '" is non an function name")
(go botloop)))
; remember the arguments in case a retrace is requested
(setq traceargs (cdar ll))
; scan the arguments
(do ((rr (cdar ll) (cdr rr)))
((null rr))
(cond ((memq (car rr) '(if ifnot evalin evalout
printargs printres evfcn
traceenter traceexit))
(T-set (car rr) (cadr rr))
(setq rr (cdr rr)))
((eq (car rr) 'evalinout)
(setq evalin (setq evalout (cadr rr))
rr (cdr rr)))
((eq (car rr) 'break)
(setq break t))
((eq (car rr) 'lprint)
(setq printargs 'T-levprint
printres 'T-levprint))
(t (T-patom '"bad request: ")
(T-print (car rr))
(T-terpr)))))
(t (setq traceargs nil) ;no args given
))
; if function is untraceable, print error message and skip
(cond ((get funnm 'Untraceable)
(setq did (cons `(,funnm untraceable) did))
(go botloop)))
; Untrace before tracing
(let ((res (funcall 'untrace (list funnm))))
(cond (res (setq did (cons `(,funnm untraced) did)))))
; store the names of the arg printing routines if they are
; different than print
(cond (printargs (T-putprop funnm printargs 'trace-printargs)))
(cond (printres (T-putprop funnm printres 'trace-printres)))
(T-putprop funnm traceargs 'trace-trace-args)
; we must determine the type of function being traced
; in order to create the correct replacement function
(cond ((setq funcd (T-getd funnm))
(cond ((bcdp funcd) ; machine code
(cond ((or (eq 'lambda (T-getdisc funcd))
(eq 'nlambda (T-getdisc funcd))
(eq 'macro (T-getdisc funcd)))
(setq typ (T-getdisc funcd)))
((stringp (T-getdisc funcd)) ; foreign func
(setq typ 'lambda)) ; close enough
(t (T-patom '"Unknown type of compiled function")
(T-print funnm)
(setq typ nil))))
((dtpr funcd) ; lisp coded
(cond ((or (eq 'lambda (car funcd))
(eq 'lexpr (car funcd)))
(setq typ 'lambda))
((or (eq 'nlambda (car funcd))
(eq 'macro (car funcd)))
(setq typ (car funcd)))
(t (T-patom '"Bad function definition: ")
(T-print funnm)
(setq typ nil))))
((arrayp funcd) ; array
(setq typ 'lambda))
(t (T-patom '"Bad function defintion: ")
(T-print funnm)))
; now that the arguments have been examined for this
; function, do the tracing stuff.
; First save the old function on the property list
(T-putprop funnm funcd 'trace-orig-fcn)
; now build a replacement
(cond
((eq typ 'lambda)
(T-eval
`(T-def
,funnm
(lexpr (T-nargs)
((lambda (T-arglst T-res T-rslt
$$functions-in-trace$$
$$funcargs-in-trace$$)
(T-do ((i T-nargs (T-sub1 i)))
((T-zerop i))
(T-setq T-arglst
(T-cons (arg i) T-arglst)))
(T-setq $$funcargs-in-trace$$
(T-cons T-arglst
$$funcargs-in-trace$$))
(T-cond ((T-setq T-res
(T-and ,if
(T-not ,ifnot)))
(,traceenter ',funnm T-arglst)
,@(cond (evalin
`((T-patom ,'":in: ")
,evalin
(T-terpr))))
(T-cond (,break
(trace-break)))))
(T-setq T-rslt
,(cond
(evfcn)
(t `(T-apply
',funcd
T-arglst))))
(T-cond (T-res
,@(cond (evalout
`((T-patom ,'":out: ")
,evalout
(T-terpr))))
(,traceexit ',funnm T-rslt)))
T-rslt)
nil nil nil
(T-cons ',funnm $$functions-in-trace$$)
$$funcargs-in-trace$$))))
(T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
(setq did (cons funnm did)
$$traced-functions$$ (cons funnm
$$traced-functions$$)))
((or (eq typ 'nlambda)
(eq typ 'macro))
(T-eval
`(T-def ,funnm
(,typ (T-arglst)
((lambda (T-res T-rslt
$$functions-in-trace$$
$$funcargs-in-trace$$)
(T-setq $$funcargs-in-trace$$
(T-cons
T-arglst
$$funcargs-in-trace$$))
(T-cond ((T-setq
T-res
(T-and ,if
(not ,ifnot)))
(,traceenter
',funnm
T-arglst)
,evalin
(T-cond (,break
(trace-break)))))
(T-setq T-rslt
,(cond
(evfcn `(,evfcn
',funcd
T-arglst))
(t `(T-apply ',funcd
T-arglst))))
(T-cond (T-res
,evalout
(,traceexit ',funnm T-rslt)))
T-rslt)
nil nil
(cons ',funnm $$functions-in-trace$$)
$$funcargs-in-trace$$))))
(T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
(setq did (cons funnm did)
$$traced-functions$$ (cons funnm
$$traced-functions$$)))
(t (T-patom '"No such function as: ")
(T-print funnm)
(T-terpr)))))
botloop )
; if given no args, just return the function currently being traced
(return (cond ((null argl) $$traced-functions$$)
(t (T-nreverse did)))))))
;--- untrace
; (untrace foo bar baz)
; untraces foo, bar and baz.
; (untrace)
; untraces all functions being traced.
;
(def untrace
(nlambda (argl)
(cond ((null argl) (setq argl $$traced-functions$$)))
(do ((i argl (cdr i))
(tmp)
(curf)
(res))
((null i)
(cond ((null $$traced-functions$$)
(setq $$functions-in-trace$$ nil)
(setq $$funcargs-in-trace$$ nil)))
res)
(cond ((and (T-getd (setq curf (car i)))
(eq (T-getd (car i))
(get (car i) 'trace-trace-fcn)))
; we only want to restore the original definition
; if this function has not been redefined!
; we test this by checking to be sure that the
; trace-trace-property is the same as the function
; definition.
(T-putd curf (get curf 'trace-orig-fcn))
(T-remprop curf 'trace-orig-fcn)
(T-remprop curf 'trace-trace-fcn)
(T-remprop curf 'trace-trace-args)
(T-remprop curf 'entercount)
(setq $$traced-functions$$
(T-delq curf $$traced-functions$$))
(setq res (cons curf res)))))))
;--- retrace :: trace again all function thought to be traced.
;
(def retrace
(nlambda (args)
(cond ((null args) (setq args $$traced-functions$$)))
(mapcan '(lambda (fcn)
(cond ((and (symbolp fcn)
(not (eq (T-getd fcn)
(get fcn 'trace-trace-fcn))))
(funcall 'trace
`((,fcn ,@(get fcn 'trace-trace-args)))))))
args)))
;--- tracedump :: dump the currently active trace frames
;
(def tracedump
(lambda nil
(let (($tracemute nil))
(T-tracedump-recursive $$functions-in-trace$$
$$funcargs-in-trace$$))))
;--- traceargs :: return list of args to currently entered traced functions
; call is:
; (traceargs foo) returns first call to foo starting at most current
; (traceargs foo 3) returns args to third call to foo, starting at
; most current
;
(def traceargs
(nlambda (args)
(cond ((and args $$functions-in-trace$$)
(let ((name (car args))
(amt (cond ((numberp (cadr args)) (cadr args))
(t 1))))
(do ((fit $$functions-in-trace$$ (cdr fit))
(fat $$funcargs-in-trace$$ (cdr fat)))
((null fit))
(cond ((eq name (car fit))
(cond ((zerop (setq amt (1- amt)))
(return (car fat))))))))))))
;--- T-tracedump-recursive
; since the lists of functions being traced and arguments are in the reverse
; of the order we want to print them, we recurse down the lists and on the
; way back we print the information.
;
(def T-tracedump-recursive
(lambda ($$functions-in-trace$$ $$funcargs-in-trace$$)
(cond ((null $$functions-in-trace$$))
(t (T-tracedump-recursive (cdr $$functions-in-trace$$)
(cdr $$funcargs-in-trace$$))
(T-traceenter (car $$functions-in-trace$$)
(car $$funcargs-in-trace$$))))))
;--- T-traceenter - funnm : name of function just entered
; - count : count to print out
; This routine is called to print the entry banner for a
; traced function.
;
(def T-traceenter
(lambda (name args)
(prog (count indent)
(cond ((not $tracemute)
(setq count 0 indent 0)
(do ((ll $$functions-in-trace$$ (cdr ll)))
((null ll))
(cond ((eq (car ll) name) (setq count (1+ count))))
(setq indent (1+ indent)))
(T-traceindent indent)
(T-print count)
(T-patom '" <Enter> ")
(T-print name)
(T-patom '" ")
(cond ((setq count (T-get name 'trace-printargs))
(funcall count args))
(t (funcall trace-printer args)))
(T-terpr))))))
(def T-traceexit
(lambda (name res)
(prog (count indent)
(cond ((not $tracemute)
(setq count 0 indent 0)
(do ((ll $$functions-in-trace$$ (cdr ll)))
((null ll))
(cond ((eq (car ll) name) (setq count (1+ count))))
(setq indent (1+ indent)))
(T-traceindent indent)
(T-print count)
(T-patom " <EXIT> ")
(T-print name)
(T-patom " ")
(cond ((setq count (T-get name 'trace-printres))
(funcall count res))
(t (funcall trace-printer res)))
(T-terpr))))))
;--- Trace-printer
; this is the default value of trace-printer. It prints a form after
; binding prinlevel and prinlength.
;
(def Trace-print
(lambda (form)
(let ((prinlevel trace-prinlevel)
(prinlength trace-prinlength))
(T-print form))))
; T-traceindent
; - n : indent to column n
(def T-traceindent
(lambda (col)
(do ((i col (1- i))
(char '| |))
((< i 2))
(T-patom (cond ((eq char '| |) (setq char '\|))
(t (setq char '| |)))))))
; from toplevel.l:
;
;--- read and print functions are user-selectable by just
; assigning another value to top-level-print and top-level-read
;
(declare (special top-level-read top-level-print))
(defmacro top-print (&rest args)
`(cond (top-level-print (funcall top-level-print ,@args))
(t (T-print ,@args))))
(defmacro top-read (&rest args)
`(cond ((and top-level-read
(T-getd top-level-read))
(funcall top-level-read ,@args))
(t (T-read ,@args))))
; trace-break - this is the trace break loop
(def trace-break
(lambda nil
(prog (tracevalread piport)
(T-terpr) (T-patom '"[tracebreak]")
loop (T-terpr)
(T-patom '"T>")
(T-drain)
(cond ((or (eq nil (setq tracevalread
(car
(errset (top-read nil nil)))))
(and (dtpr tracevalread)
(eq 'tracereturn (car tracevalread))))
(T-terpr)
(return nil)))
(top-print (car (errset (T-eval tracevalread))))
(go loop))))
(def T-levprint
(lambda (x)
((lambda (prinlevel prinlength)
(T-print x))
3 10)))
(eval-when (eval)
(apply 'sstatus `(uctolc ,old-uctolc-value))
(setq readtable old-read-table-trace)
)