perm filename TRACE.59[MAC,LSP] blob sn#278544 filedate 1977-04-20 generic text, type C, neo UTF8
C00001 00001
C00002 00002
C00009 00003
C00012 00004
C00020 00005
C00032 00006
C00034 ENDMK
;;  ************************************************************
;;  ************************************************************
;;  ************************************************************

;; Trace package now works in both Multics and PDP-10 lisp.

;;  45		(Rick Grossman, 12/74)
;;	Replace the trac1 template with compilable code.
;;	Flush trprint in favor of new trace-printer.
;;	Make trace, remtrace, untrace compilable.
;;	Improve trace-edsub so that this will work:
;;	 (trace y (x wherein y)), and similarly untrace.
;;	 Note that (trace (y wherein z) (x wherein y))
;;	 still partially loses.
;;	Have untrace return only the list of actually
;;	 previously traced functions.
;;  46		(Rick Grossman, 1/75)
;;	Add trace-indenter as default print function.
;;	Fix bug:  (.. value ..) also printed the arg.
;;	Put "break" condition within scope of the "cond" one.
;;	Fix bug:  (trace (foo cond bar1 value)) lost
;;	 because trace*g4 was referenced in "value"
;;	 but never set.
;;	Fix bug:  If FEXPR or MACRO is an atom, loses.
;;	Clean up some of the duplicate trace-1 code.
;;	Add TRACE-OK-FLAG to prevent tracing calls by trace.
;;	Flush definition of PLIST.
;;	Change ADD1 to 1+.
;;	Replace MIN with open-compilable COND.
;;	Flush excess consing in trace-indenter call.
;;  50		(JONL, 1/75)
;;	Try to merge Moons hackery with Grossman's latest stuff
;; 	Add function BREAK-IN
;;	 ever goes to zero, then simply skip indentation.
;;  51		(JONL, 2/75)
;;	Use the PRIN1 variable in TRACE-INDENTER.
;;  52		(GROSS, 2/75)
;;	Lambda-bind TRACE-INDENTATION (and use a gensym name).
;;  53		(MOON Feb. 25, 1975)
;;	Take break out from control of cond, dammit!!
;;	This is the only way to break on condition without
;;	printing a lot of garbage; also it's a documented feature.
;;  54		(Gls May 7, 1975)
;;	Flush occurrences of IOG function for newio.
;;  55		(MACRAK, 26 Aug 1975)
;;	Change || to \\ in entry and exit to avoid seeing 
;;	/|/|.  Set mapex to NIL.  Some cosmetics.

;; 57		(JONL   JAN 22, 76)
;;	fixed parens error in trace-indenter, and flushed the 
;;	superfluous (BOUNDP 'PRIN1)

;; 59      (JONL  FEB 3, 76)
;;      added LSUBR to list of properties to be removed by remtrace
;;      gave names to some quoted lambda expressions that were being mapped
;;;            so that remtrace could remove them.

;; Note:  When adding new functions to this file,
;;	  be sure to put their names in the list in REMTRACE.

 (macros nil) 
 (mapex nil)	;why waste space?
 (setq nfunvars t)
 (special trace-olduuo traced-stuff
  trace*g1 trace*g2 trace*g4 trace*g5
  trace*copies trace*subr-args trace-printer trace-ok-flag
  trace-indent-incr trace-indent-max )
 (fixnum ng)
 (*fexpr trace untrace remtrace) ) 

(defun macex macro (x) 
 (list 'defun (cadr x) 'macro (caddr x) 
  (eval (cadddr x)) ) )  

(macex newlineseq (x) 
  ((status feature Multics) ''(list (ascii 10.))) 
  (t ''(list (ascii 13.) (ascii 10.))) ) ) 

(macex version (x) 
  (maknam (nconc (newlineseq) 
    (explodec '/;loading/ trace/ ) 
      ((status feature newio) (caddr (names infile))) 
      ((cadr (status uread))) )) 
    (newlineseq) )) 
  ''(or (status feature noldmsg) 
     ((lambda (~w ~r) (princ 'version) (ascii 0.)) nil nil) ) ) )


(and (getl 'remtrace '(fsubr fexpr)) (remtrace)) 

(and (not (boundp 'trace-printer))
 (setq trace-printer 'trace-indenter) ) 

(setq trace-olduuo nouuo traced-stuff nil trace-ok-flag t) 
;; The flag  trace-ok-flag  is bound NIL inside all trace fns.

(sstatus feature trace) 

 (list (gensym) (gensym) (gensym) (gensym) (gensym))
 trace*g1 (gensym) trace*g2 (gensym)
 trace*g4 (gensym) trace*g5 (gensym) )

;; Initial indentation.
(set trace*g5 0)


;; Define remtrace first in case the loading does not finish.

(defun remtrace fexpr (l) 
 (prog (trace-ok-flag y) 
  (errset (untrace) nil) 
  (mapc '(lambda (x) 		;this map will be expanded anyway
          (do nil
              ((null (setq y (getl x '(expr fexpr subr fsubr lsubr)))))
            (remprop x (car y))))
        '(trace trace-2 untrace remtrace untrace-1 trace-edsub
          trace-indenter break-in break-in-1)) 
  (nouuo trace-olduuo) 
  (sstatus nofeature trace) 

(defun untrace fexpr (l) 
 (prog (trace-ok-flag) 
   (l (setq l (mapcan 'untrace-1 l)))  
   ((setq l (mapcan 'untrace-1 (trace))) 
    (and traced-stuff (progn (print 'lossage) (print (trace)))))) 
  (and (null traced-stuff) (nouuo trace-olduuo)) 
  (return l)))   

(defun untrace-1 (x) 
  (prog (y ret) 
    a 	(cond ((null (setq y (assoc x traced-stuff))) (return ret)) 
	      ((atom (car y)) 
		(and (eq (get (car y) (caddr y)) (cadddr y)) 
		     (remprop (car y) (caddr y)))) 
	      (t (trace-edsub (cons (caddr y) (caar y)) 
			      (caddar y) 
			      (cadr y)))) 
	(setq traced-stuff (delq y traced-stuff)) 
	(setq ret (list x))
	(go a))) 

(defun trace-edsub (pair sym ind) (prog (y z) 
  ;; Return NIL if lose.
  (and (setq y (assq sym traced-stuff)) 
   (eq ind (caddr y)) 
   (setq z (getl sym (list ind))) 
   (eq (cadddr y) (cadr z)) 
   ;; We want to munge the original definition,
   ;; not the trace kludgery.
   ;; Note that this partially loses for traced macros,
   ;; since we munge the macro property, not the
   ;; trace-generated fexpr one.
   (setq sym (cdr z)) ) 
    ((setq y (get sym ind)) 
     (putprop sym (sublis (list pair) y) ind) ) ) ) )) 


;; Define the code to produce the trace stuff.

(defun qu* macro (x) (prog (y) 
   (and (cdr x) (null (cddr x)) (eq (caadr x) 'quote)) 
   (error 'qu*-lossage x) ) 
  (setq y (qu*1 (cadadr x))) 
  (rplaca x (car y)) (rplacd x (cdr y)) 
  (return y) )) 

(declare (eval (read))) 

(defun qu*1 (x) (prog (y) 
    ((atom x) (list 'quote x)) 
    ((eq (car x) 'ev) (cadr x)) 
     (setq y
       ((atom (car x)) 
        (list 'cons
         (list 'quote (car x)) 
         (qu*1 (cdr x)) ) ) 
       ((eq (caar x) 'ev*) 
        (list 'append
         (cadar x) 
         (qu*1 (cdr x)) ) ) 
       ((list 'cons 
         (qu*1 (car x)) 
         (qu*1 (cdr x)) )) ) ) 
     (and (not (atom (cadr y))) (not (atom (caddr y))) 
      (eq (caadr y) 'quote) (eq (caaddr y) 'quote) 
      (setq y (list 'quote (eval y))) ) 
     (return y) ) ) ) )) 

(defun trace-1 macro (dummy) 
 '((lambda (t1 in-vals)
    (sublis trace*copies
     (qu* (quote
       (lambda (ev (cond (c) (gg) (g (car g)) (trace*g1))) 
          ((ev trace*g2) (ev trace*g1) 
           (ev* (cond ((null q) (list y)))) 
           (ev* (cond (f (list trace*g4)))) 
           (ev* (cond (p (list p))))
	   (ev* (cond
	     ((eq print 'trace-indenter) (list trace*g5)) )) ) 
          (ev* (and f (list (list 'setq trace*g4 (car f))))) 
	    ((or ne (memq (car m) '(arg both))) 
	     (setq t1 (cond
               ((eq print 'trace-indenter) 
                (list print y ''enter (list 'quote y) 
                  ((memq (car m) '(arg both)) trace*g2) 
                  ((list 'quote trace*g2)) ) 
		 (and (or n ne) (cons 'list (append ne n)))
		 trace*g5 ) ) 
               ((qu* (quote
                  ((ev print) 
                   (list (ev y) 
                    '(ev y) 
                      ((memq (car m) '(arg both)) 
                       (list trace*g2) ) ) ) 
                    (ev* ne) 
                    (ev* n) ) ) ))) )) 	       
              ((or f fe) 
               ;; There is a COND or ENTRYCOND
               (qu* (quote 
                   (ev* (and f (list trace*g4))) 
                   (ev* (and fe (list (car fe)))) 
                   (ev t1) )) )) ) 
	      ((list t1)) )) ) ) 
          (ev* (and break (list 
             (list 'break 
              break ) ))) 
            (q (list 'apply (list 'quote y) trace*g2)) 
            ((list 'setq trace*g1
              (list 'apply (list 'quote y) trace*g2))))) 
            ((and (null q) 
              (or nx (memq (car m) '(value both)))) 
             (setq t1 (cond
               ((eq print 'trace-indenter) 
                (list print y ''exit (list 'quote y) 
                  ((memq (car m) '(value both)) trace*g1) 
                  ((list 'quote trace*g2))) 
		 (and (or n nx) (cons 'list (append nx n)))
		 trace*g5 ) ) 
               ((qu* (quote
                  ((ev print) 
                   (list (ev y) 
                    '(ev y) 
                      ((memq (car m) '(value both)) 
                       (list trace*g1)))) 
                    (ev* nx) 
                    (ev* n))))))))            
              ((or f fx) 
               ;; There is a COND or EXITCOND
               (qu* (quote 
                   (ev* (and f (list trace*g4))) 
                   (ev* (and fx (list (car fx)))) 
                   (ev t1)))))) 
	      ((list t1))))))
          (ev* (cond ((null q) (list trace*g1))))) 
         ;; lambda args
          (setq in-vals
            (c (car c)) 
            (gg (list 'listify gg)) 
            (g (cons 'list (car g))) 
            ((list 'listify trace*g1)))))  
         (ev* (cond ((null q) (qu* '((1+ (ev y))))))) 
         (ev* (cond (f '(nil)))) 
            ;; ARGPDL stuff
                  (cond ((null q) (qu* '((1+ (ev y))))))) 
                 '(ev y) 
                 (ev in-vals)) 
                (ev p))))))))
	 (ev* (cond ((eq print 'trace-indenter)
	    (list (list '+ trace*g5 'trace-indent-incr)) )))
 nil nil)) 

;;	c is non-nil for f-type, holds lambda list 
;;	 cm = (MACRO (LAMBDA ...) ...) if macro.
;;	g is non-nil for expr type, (car g) is lambda list ;
;;	not c or g => l-form
;;	 gg = lexpr variable (if nil, is lsubr).
;;	q if non-nil means the function is go, throw, etc.,
;;	 so no return values (etc.) will be hacked.

;;	n holds list of extra quantities for typeout

;;	traced-stuff =
;;		list of currently traced stuff, typically
;;		((a 'trace 'expr newexpr) ...)
;;		(((a 'wherein b) 'expr g0003) ...)

;;	x = tracee
;;	y = new symbol for tracee
;;	m = (BOTH/ARGS/VALUE/NIL . stuff-to-print)
;;	Keyword values:
;;	 f:	COND
;;	 fx:	EXITCOND
;;	 p:	ARGPDL
;;	 break:	BREAK
;;	 b:	(foo WHEREIN bar)
;;	 ne:	ENTRY
;;	 nx:	EXIT

;; Obscure functions:
;;	qu*	Expand a quoted list, hacking:
;;		(EV frob)	eval the frob, & use result;
;;		(EV* frob)	eval, & splice the result in.
;;	trace-edsub	(pair atom ind):  Do sublis on the
;;					atom's property.
;;		This is used for WHEREIN substitution.

(defun break-in fexpr (l)  (apply 'trace (mapcar 'break-in-1 l)))

(defun break-in-1 (x)  (subst x 'x '(x break (prog2 (setq x arglist) t))))

(defun trace fexpr (l) 
  ((null l) (mapcar 'car traced-stuff)) 
  (t (prog2 nil 
            (mapcan 'trace-2 l) 
            (and traced-stuff (nouuo t) (sstatus uuolinks)))))) 

(defun trace-2 (c) 
  (prog (x y g gg n ne nx m break f fe fx b p q cm sube print getl trace-ok-flag ) 
        (setq print trace-printer) 
         ((atom c) (setq x c c nil)) 
          (setq x (car c)) 
          (setq c (cdr c)) 
          (or (atom x)
	   ;; hack list of functions
           (return (mapcar '(lambda (x) (car (apply 'trace (list (cons x c))))) 
                           x)))) )  
         (setq getl (getl x '(fexpr fsubr expr subr lsubr macro)) ) 
         (return (ncons (list '? x 'not 'function))) ) 
        (or (atom (cadr getl)) (eq (caadr getl) 'lambda) 
         (return (ncons (list '? x 'bad (car getl) 'definition))))  
        (go y) 
     l  (setq c (cdr c)) 
     l1 (setq c (cdr c)) 
     y  (cond
         ((null c) (setq m '(both)) (go x)) 
         ((eq (car c) 'grind) 
          (setq print 'sprinter) (go l1) ) 
         ((eq (car c) 'break) 
          (setq break (cadr c)) 
          (go l) ) 
         ((eq (car c) 'cond) 
          (setq f (cdr c)) 
          (go l) ) 
         ((eq (car c) 'entrycond) 
          (setq fe (cdr c)) 
          (go l) ) 
         ((eq (car c) 'exitcond) 
          (setq fx (cdr c)) 
          (go l) ) 
         ((memq (car c) '(arg value both nil)) 
          (setq m c)
	  (go x) ) 
         ((eq (car c) 'wherein) 
           ((or (not (atom (cadr c))) 
              (setq y
               (getl (cadr c) '(expr fexpr macro)) ) ) ) 
            (go wherein-loss) ) )  
          (untrace-1 (setq g (list x 'wherein (cadr c)))) 
          (setq traced-stuff
            (list g
             (car y) 
             (setq n (copysymbol x nil)) ) 
            traced-stuff ) ) 
	  (setplist n (plist x))
           (trace-edsub (cons x n)
	    (cadr c)
	    (car y))
	   ;; This can lose if the EXPR, FEXPR, or MACRO found
	   ;; above is really a tracing frob!  Hence:
	   (go wherein-loss) )
          (setq b g) 
          (setq x n) 
          (go l) ) 
         ((eq (car c) 'argpdl) 
           ((and (setq p (cadr c)) (eq (typep p) 'symbol)) 
            (set p nil) 
            (go l) ) 
           ((return (ncons (list '? 'argpdl p)))) ) ) 
         ((eq (car c) 'entry) 
          (setq ne (cons ''\\ (cadr c))) 
          (go l) ) 
         ((eq (car c) 'exit) 
          (setq nx (cons ''\\ (cadr c))) 
          (go l) ) 
         ((return (ncons (list '? (car c))))) ) 
     wherein-loss (return (ncons (list '? 'wherein (cadr c))))
     x  (untrace-1 x) 
         ((setq q (memq x '(go return err throw))) 
           ((eq (car m) 'value) 
            (setq m (cons nil (cdr m))) ) 
           ((eq (car m) 'both) 
            (setq m (cons 'arg (cdr m))) ) ) ) ) 
        ;; copy atom in way that works in any lisp.
        (set (setplist (setq y (copysymbol x nil)) nil) 0) 
        ;; transfer property list to new trace atom
        (setplist y (nconc (plist y) (plist x))) 
        (setq c
          ((memq (car getl) '(fexpr macro)) 
            ((atom (cadr getl)) (list trace*g1)) 
            ((cadr (cadr getl))	) ) )  
          ((eq (car getl) 'fsubr) (list trace*g1)) ) ) 
        (setq cm (cond ((eq (car getl) 'macro) getl))) 
        (setq g
          ((eq (car getl) 'expr) 
            ((atom (setq g (cadr getl))) nil) 
            ((null (cadr g)) (cdr g)) 
            ((atom (cadr g)) 
             (setq gg (cadr g)) 
             nil ) 
            (t (cdr g)) ) ) 
          ((eq (car getl) 'subr) 
            ((setq g (args x)) 
	     (setq g (cond ((> (cdr g) 5)
			    (do ((ng (- (cdr g) 5) (1- ng)) 
			         (l trace*subr-args (cons (gensym) l)))
			         ((zerop ng) l)))
	                   ((do ((ng (- 5 (cdr g)) (1- ng)) 
				 (l trace*subr-args (cdr l))) 
	                        ((zerop ng) l)))))
	     (list g)))))) 
	 ;; For fns called by TRACE itself, suppress tracing.
	 (or (memq x
           '(*append *delq *nconc args assoc assq boundp cons
             copysymbol fixp gctwa get getl last memq apply
             ncons nreverse plist princ print putprop remprop
             setplist sstatus status sublis terpri typep xcons
             trace-indenter sprinter delq error gensym nouuo
	     prin1 ) ) 
          (eq x prin1) ) 
	 (setq f (list
            (f (list 'and 'trace-ok-flag (car f))) 
        (setq sube
         (list (cons 'recurlev y) (cons 'arglist trace*g2))) 
        (setq n
          ((cdr m) 
           (cons ''// (sublis sube (cdr m))) ) ) ) 
        (setq ne (sublis sube (list ne f fe break))) 
        (setq nx 
          (cons (cons 'fnvalue trace*g1) sube) 
          (list nx  fx) ) ) 
         f (cadr ne) fe (caddr ne) 
         break (cadddr ne) ne (car ne) ) 
        (setq fx (cadr nx) nx (car nx)) 
            (setplist y 
             (cons 'fexpr (cons (cadr cm) (plist y))) ) 
            'macro ) 
           (c 'fexpr) 
           (t 'expr) ) 
          (cons (trace-1) (plist x)) ) )  
         (ncons (cond (b) 
	              (t (setq traced-stuff (cons (list x 'trace (car (plist x)) (cadr (plist x))) 

 (unspecial n) 
 (fixnum indentation trace-indent-incr trace-indent-max
  n recurlev ) ) 

(defun trace-indenter (recurlev type fn arg stuff indentation) 
 (prog (trace-ok-flag) 
   (setq indentation (- indentation trace-indent-incr))
  (do ((n 
	((< indentation 0) 0) 
	((< indentation trace-indent-max) indentation) 
	(trace-indent-max) ) 
       (1- n)))
      ((zerop n)) 
      (princ '/ )) 
  (princ '/() (prin1 recurlev) (princ '/ ) (prin1 type) 
  (princ '/ ) (prin1 fn) 
  (cond ((not (eq arg trace*g2)) 
    (princ '/ ) 
    (cond (prin1 (funcall prin1 arg))
          ((prin1 arg))) )) 
  (do ((l stuff (cdr l))) 
      ((null l))
      (princ '/ ) 
      (cond (prin1 (funcall prin1 (car l)))
	    ((prin1 (car l)))) )
  (princ '/)/ )))    

(setq 	trace-indent-incr 2. 
	trace-indent-max 16. 
	trace*copies (mapcar '(lambda (x) (cons x (copysymbol x t))) 
			     '(trace-indenter print quote cond list 
				and setq break apply listify)))