3BSD/usr/lib/lisp/trace.l

;---- 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))
  (load 'backquote))
(cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
(setq $$trace-indent$$ 0)

;----> 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.  

(do ((i '( (add1 T-add1)(append T-append)
	   (apply T-apply)(atom T-atom)(bcdp T-bcdp)
	   (car T-car)(cadr T-cadr)(cdr T-cdr)(cons T-cons) (delq T-delq)
	   (drain T-drain)
	   (dtpr T-dtpr) (eq T-eq) (eval T-eval)(funcall T-funcall)
	   (get T-get) (getd T-getd)(getdisc T-getdisc)
   	   (greaterp T-greaterp)(memq T-memq)(not T-not)
	   (null T-null) (patom T-patom) (print T-print) 
	   (prog T-prog)
	   (or T-or) (patom T-patom)(putd T-putd) 
	   (putprop T-putprop)
	   (read T-read)(remprop T-remprop) (reverse T-reverse)
	   (set T-set)
	   (setq T-setq) (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 - 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 funcd did break)

    ; process each argument	 

    (do ((ll argl (cdr ll))
	 (funnm) 
	 (funcd))
	((T-null ll))
	(T-setq funnm (car ll)
		if t
		break nil
		ifnot nil
		evalin nil
		evalout nil)

	; a list as an argument means that the user is specifying
	; conditions on the trace
	(cond ((T-not (atom funnm))
	       (cond ((T-not (T-atom (T-setq funnm (car funnm))))
		      (T-print (car funnm))
		      (T-patom '" is non an function name")
		      (go botloop)))
	       (do ((rr (cdar ll) (cdr rr)))
		   ((T-null rr))
		   (cond ((T-memq (T-car rr) '(if ifnot evalin evalout))
			  (T-set (T-car rr) (T-cadr rr))
			  (T-setq rr    (T-cdr rr)))
			 ((T-eq (T-car rr) 'evalinout)
			  (T-setq evalin (T-setq evalout (T-cadr rr))
				rr (T-cdr rr)))
			 ((T-eq (T-car rr) 'break)
			  (T-setq break t))
			 (t (T-patom '"bad request ")
			    (T-print (T-car rr)))))))


	 ; if function is already traced, untrace it first
	 (cond ((get funnm 'T-original) 
		(apply 'untrace `(,funnm))
		(T-setq did (T-cons `(,funnm untraced) did))))

	 ; we must determine the type of function being traced
	 ; in order to create the correct replacement function	

	 (cond ((T-setq funcd (T-getd funnm))
	       (cond ((T-bcdp funcd)		; machine code
		      (cond ((T-eq 'lambda (T-getdisc funcd))
			     (T-setq typ 'lambda))
			    ((T-eq 'nlambda (T-getdisc funcd))
			     (T-setq typ 'nlambda))
			    (t (T-patom '"Unknown type of compiled function")
			       (T-print funnm)
			       (T-setq typ nil))))

		     ((T-dtpr funcd)		; lisp coded
		      (cond ((T-or (T-eq 'lambda (T-car funcd))
				 (T-eq 'lexpr (T-car funcd)))
			     (T-setq typ 'lambda))
			    ((T-or (T-eq 'nlambda (T-car funcd))
				   (T-eq 'macro (T-car funcd)))
			     (T-setq typ 'nlambda))
			    (t (T-patom '"Bad function definition: ")
			       (T-print funnm)
			       (T-setq typ nil))))
		     (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 'T-original)

	       ; now build a replacement

	       (cond ((T-eq typ 'lambda)
		      (T-eval 
			   `(def ,funnm
			      (lexpr (nargs)
				(prog (T-arglst T-res T-rslt)	 
				      (do ((i nargs (T-sub1 i)))
					  ((T-zerop i))
					  (T-setq T-arglst 
						  (T-cons (arg i) T-arglst)))
				      (cond ((T-setq T-res 
						   (and ,if
							(not ,ifnot)))
					     (T-traceenter ,funnm)
					     (T-print T-arglst)
					     (T-terpr)
					     ,evalin
					     (cond (,break (trace-break)))))
				      (T-setq T-rslt 
					    (T-apply ',funcd T-arglst))
				      (cond (T-res 
					     ,evalout 
					     (T-traceexit ',funnm T-rslt)
					     (T-terpr)))
				      (return T-rslt)))))
		      (T-setq did (T-cons funnm did)
			      $$traced-functions$$ (cons funnm
							 $$traced-functions$$)))

		     ((T-eq typ 'nlambda)
		      (T-eval 
		       `(def ,funnm
			    (nlambda (T-arglst)
				     (prog ( T-res T-rslt)	 
					   (cond ((T-setq T-res 
							  (and ,if
							       (not ,ifnot)))
						  (T-traceenter ,funnm)
						  (T-print T-arglst)
						  (T-terpr)
						  ,evalin
						  (cond (,break (trace-break)))))
					   (T-setq T-rslt 
						   (T-apply ',funcd T-arglst))
					   (cond (T-res 
						  ,evalout 
						  (T-traceexit ',funnm T-rslt)
						  (T-terpr)))
					   (return T-rslt)))))
		      (T-setq did (T-cons funnm did)
			      $$traced-functions$$ (T-cons funnm
							   $$traced-functions$$)))
		     
		     (t (T-patom '"No such function as: ")
			(T-print funnm)
			(T-terpr))))))
	 (return (nreverse did)))))



(def untrace
  (nlambda (argl)
	   (cond ((T-null argl) (T-setq argl $$traced-functions$$)))

	   (do ((i argl (T-cdr i))
		(curf)
		(res))
	       ((T-null i)  
		(cond ((T-null $$traced-functions$$)
		       (T-setq $$trace-indent$$ 0)))
		res)
	       (cond ((T-setq tmp (T-get (T-setq curf (T-car i)) 'T-original))
		      (T-putd curf tmp)
		      (T-remprop curf 'T-original)
		      (T-remprop curf 'entercount)
		      (T-setq $$traced-functions$$ 
			      (T-delq curf $$traced-functions$$))
		      (T-setq res (T-cons curf res)))
		     (t (T-setq res (T-cons `(,curf not traced) res)))))))


;--- 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
  (nlambda (nm)
	   (T-prog (name count)
		 (T-setq name (T-car nm))
		 (cond ((T-null (T-setq count (T-get name 'entercount)))
			(T-setq count 1)))
		 (T-putprop name (add1 count) 'entercount)

		 (do ((i 1 (T-add1 i)))
		     ((T-greaterp i $$trace-indent$$))
		     (T-patom '" "))
		 (T-setq $$trace-indent$$ (T-add1 $$trace-indent$$))
		 (T-print count)
		 (T-patom '" <Enter> ")
		 (T-print name)
		 (T-patom '" "))))

(def T-traceexit
  (lambda (name retval)
	  (T-prog (count)
		(T-putprop name 
			 (T-setq count (T-sub1 (T-get name 'entercount)))
			 'entercount)
		(do ((i 1 (T-add1 i))
		     (over (T-setq $$trace-indent$$ (T-sub1 $$trace-indent$$))))
		    ((T-greaterp i over))
		    (T-patom '" "))

		(T-print count)
		(T-patom '" <EXIT>  ")
		(T-print name)
		(T-patom '"  ")
		(T-print retval)
		(return retval))))

; trace-break  - this is the trace break loop
(def trace-break
  (lambda nil
	 (prog (tracevalread)
	       (T-terpr) (T-patom '"[tracebreak]")
	loop   (T-terpr)
	       (T-patom '"T>")
	       (T-drain)
	       (cond ((eq '<EOF> (T-setq tracevalread
					 (car
					  (errset (T-read nil '<EOF>)))))
		      (return nil)))
	       (T-print (car (errset (T-eval tracevalread))))
	       (go loop))))

(eval-when (eval)
  (setq readtable old-read-table-trace))