From 59b47038145d2b5cced09f2dcb1df76460415361 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 27 May 1992 01:09:51 +0000
Subject: [PATCH] Substantially rewritten.  TRACE has a new syntax.  It now
 subsumes the old encapsulation-based trace via the :ENCAPSULATE option. 
 Interpreted functions and generic functions are traced via encapsulation by
 default, which works. Conditional stuff works much better.

---
 code/ntrace.lisp | 879 ++++++++++++++++++++++++++++++++---------------
 1 file changed, 600 insertions(+), 279 deletions(-)

diff --git a/code/ntrace.lisp b/code/ntrace.lisp
index f86f43449..ccc56c5de 100644
--- a/code/ntrace.lisp
+++ b/code/ntrace.lisp
@@ -7,311 +7,226 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.7 1992/05/15 18:31:05 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.8 1992/05/27 01:09:51 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; This is a tracing facility.
+;;; This is a tracing facility based on breakpoints.
 ;;;
-;;; THIS IS CURRENTLY UNDER DEVELOPMENT AND TESTING.
-;;;
-;;; Written by Bill Chiles.
+;;; Written by Rob MacLachlan and Bill Chiles.
 ;;;
 ;;; **********************************************************************
 ;;;
-
 (in-package "LISP")
 
 (export '(trace untrace))
 
-
 (in-package "DEBUG")
 
-(export '(*trace-print-level* *trace-print-length* *traced-function-list*
-	  *trace-frame* *trace-values* *max-trace-indentation*))
-
-(defvar *traced-function-list* nil
-  "A list of functions which are traced.")
-
-(defvar *trace-print-length* nil
-  "Tracing output occurs with *print-length* bound to this value.")
-
-(defvar *trace-print-level* nil
-  "Tracing output occurs with *print-level* bound to this value.")
-
-(defvar *trace-frame* nil
-  "TRACE causes expressions for its switches to evaluate within a context
-   where this is bound to the appropriate control stack frame.")
+(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*))
 
 (defvar *trace-values* nil
   "This is bound to the returned values when evaluating :BREAK-AFTER and
    :PRINT-AFTER forms.")
 
-(defvar *max-trace-indentation* nil
-  "This is currently unused.")
+(defvar *max-trace-indentation* 40
+  "If the trace indentation exceeds this value, then indentation restarts at
+   0.")
 
-
-;;; TRACE -- Public.
-;;;
-(defmacro trace (&rest specs)
-  "Establishes tracing for specified functions and pushes them on
-   *traced-function-list*.  Each specification is one of the following:
-      function
-      the name of a function
-      a list form
-   If it is a list form, it has the following structure:
-      (function-or-name <trace-option> <value> <trace-option> <value> ...)
-   If you supply no specifications, TRACE returns the list of traced functions.
-   The following options are valid:
-      :condition
-         A form to EVAL to determine whether TRACE should display anything.
-      :break
-         A form to EVAL to determine whether to call BREAK before the call.
-      :break-after
-         Like :break, but takes effect after the call.
-      :break-all
-         Like :break, but takes effect before and after call.
-      :wherein
-         A function name or list of names in which TRACE will display a call.
-      :print
-         A list of forms for EVAL whose results TRACE will display in addition
-         to other information before the call.
-      :print-after
-         Like :print, but takes effect after the call.
-      :print-all
-         Like :print, but takes effect before and after the call.
-
-   While the provided expression evaluate, debug:*trace-frame* is bound to the
-   appropriate frame for accessing locals of the TRACE'd function.  Therefore,
-   you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if
-   necessary) and with its resulting function, provide an expression including
-   a FUNCALL of the function and debug:*trace-frame*."
-  (cond
-   ((not specs) '*traced-function-list*)
-   (t
-    (let ((name-list nil)
-	  (trace-1-forms nil))
-      (dolist (spec specs `(progn
-			     ,@trace-1-forms
-			     ',(reverse name-list)))
-	(multiple-value-bind
-	    (name options)
-	    (typecase spec
-	      ((or symbol function)
-	       (values spec nil))
-	      (list
-	       (let ((fun (car spec)))
-		 (cond ((eq fun 'quote)
-			(error "Do NOT quote function names."))
-		       ((or (symbolp fun) (functionp fun))
-			(values fun (cdr spec)))
-		       ((not (and (consp fun) (= (length fun) 2)))
-			(error "Illegal function name:  ~S." fun))
-		       ((eq (car fun) 'setf)
-			(values fun (cdr spec)))
-		       (t (error "Illegal function name:  ~S." fun)))))
-	      (t (error "Illegal trace spec:  ~S." spec)))
-	  (push name name-list)
-	  (destructuring-bind (&key condition break break-after break-all
-				    wherein print print-after print-all)
-			      options
-	    (when break-all
-	      (setf break (setf break-after break-all)))
-	    (when print-all
-	      (setf print (setf print-after print-all)))
-	    ;; Wherein must be a list of symbols or nil.
-	    (setf wherein
-		  (typecase wherein
-		    (null nil)
-		    (symbol (list wherein))
-		    (list (dolist (fun wherein wherein)
-			    (unless (or (symbolp fun)
-					(and (consp fun)
-					     (= (length fun) 2)
-					     (eq (car fun) 'setf)))
-			      (error "Illegal function name, ~S, in :wherein."
-				     fun))))
-		    (t (error "Illegal :wherein option:  ~S." wherein))))
-	    ;; Print and print-after must be lists.
-	    (unless (listp print)
-	      (error "Illegal form list, ~S, for :print." print))
-	    (unless (listp print-after)
-	      (error "Illegal form list, ~S, for :print-after." print-after))
-	    (push `(trace-1 ',name ',condition ',break ',break-after
-			    ',wherein ',print ',print-after)
-		  trace-1-forms))))))))
+(defvar *trace-encapsulate-default* :default
+  "The default value for the :ENCAPSULATE option to trace.")
 
+
+;;;; Internal state:
 
-;;; TRACE-FDEFINITION  --  Internal
-;;;
-;;;    Given a function or macro name, return the definition.  Error if a
-;;; special form.  If already a function, just return it.
+;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry
+;;; for a closure is the shared function-entry object.
 ;;;
-(defun trace-fdefinition (x)
-  (typecase x
-    (symbol
-     (cond ((special-form-p x)
-	    (error "Can't trace special form ~S." x))
-	   ((macro-function x))
-	   (t
-	    (fdefinition x))))
-    (function x)
-    (t (fdefinition x))))
+(defvar *traced-functions* (make-hash-table :test #'eq))
 
-
-;;; This is a list of function-end-cookies, which we use to note distinct
-;;; dynamic entries into functions.
+;;; The TRACE-INFO structure represents all the information we need to trace a
+;;; given function.
 ;;;
+(defstruct (trace-info
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore d))
+	       (print-unreadable-object (s stream)
+		 (format stream "Trace-Info ~S" (trace-info-what s)))))
+	    (:make-load-form-fun :just-dump-it-normally))
+  ;;
+  ;; The original representation of the thing traced.
+  (what nil :type (or function cons symbol))
+  ;;
+  ;; True if What is a function name whose definition we should track.
+  (named nil)
+  ;;
+  ;; True if tracing is to be done by encapsulation rather than breakpoints.
+  ;; T implies Named.
+  (encapsulated *trace-encapsulate-default*)
+  ;;
+  ;; True if this trace has been untraced.
+  (untraced nil)
+  ;;
+  ;; Breakpoints we set up to trigger tracing.
+  (start-breakpoint nil :type (or di:breakpoint null))
+  (end-breakpoint nil :type (or di:breakpoint null))
+  ;;
+  ;; The list of function names for wherein.  NIL means unspecified.
+  (wherein nil :type list)
+  ;;
+  ;; The following slots represent the forms that we are supposed to evaluate
+  ;; on each iteration.  Each form is represented by a cons (Form . Function),
+  ;; where the Function is the cached result of coercing Form to a function.
+  ;; Forms which use the current environment are converted with
+  ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.  
+  ;; Null environment forms also have one-arg functions, but the argument is
+  ;; ignored.  NIL means unspecified (the default.)
+  ;;
+  ;; Current environment forms:
+  (condition nil)
+  (break nil)
+  ;;
+  ;; List of current environment forms:
+  (print () :type list)
+  ;;
+  ;; Null environment forms.
+  (condition-after nil)
+  (break-after nil)
+  ;;
+  ;; List of null environment forms
+  (print-after () :type list))
+
+;;; This is a list of conses (function-end-cookie . condition-satisfied),
+;;; which we use to note distinct dynamic entries into functions.  When we
+;;; enter a traced function, we add a entry to this list holding the new
+;;; end-cookie and whether the trace condition was statisfied.  We must save
+;;; the trace condition so that the after breakpoint knows whether to print.
 ;;; The length of this list tells us the indentation to use for printing TRACE
 ;;; messages.
 ;;;
 ;;; This list also helps us synchronize the TRACE facility dynamically for
-;;; detecting non-local flow of control that affects TRACE'ing.  Whenever
-;;; execution hits a :function-end breakpoint used for TRACE'ing, we look for
-;;; the function-end-cookie at the top of *traced-entries*.  If it is not
-;;; there, we can adjust our indentation and the contents of the list
-;;; accordingly, printing a warning that some TRACE'd entries have been fouled.
+;;; detecting non-local flow of control.  Whenever execution hits a
+;;; :function-end breakpoint used for TRACE'ing, we look for the
+;;; function-end-cookie at the top of *traced-entries*.  If it is not there, we
+;;; discard any entries that come before our cookie.
 ;;;
-(defvar *traced-entries* nil)
+;;; When we trace using encapsulation, we bind this variable and add
+;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated
+;;; tracing.
+;;;
+(defvar *traced-entries* ())
+(declaim (list *traced-entries*))
+
+;;; This variable is used to discourage infinite recursions when some trace
+;;; action invokes a function that is itself traced.  In this case, we quietly
+;;; ignore the inner tracing.
+;;;
+(defvar *in-trace* nil)
+
+
+;;;; Utilities:
+
+;;; TRACE-FDEFINITION  --  Internal
+;;;
+;;;    Given a function name, a function or a macro name, return the raw
+;;; definition and some information.  "Raw"  means that if the result is a
+;;; closure, we strip off the closure and return the bare code.  The second
+;;; value is T if the argument was a function name.  The third value is one of
+;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
+;;; :FUNCALLABLE-INSTANCE.
+;;;
+(defun trace-fdefinition (x)
+  (multiple-value-bind
+      (res named-p)
+      (typecase x
+	(symbol
+	 (cond ((special-form-p x)
+		(error "Can't trace special form ~S." x))
+	       ((macro-function x))
+	       (t
+		(values (fdefinition x) t))))
+	(function x)
+	(t (values (fdefinition x) t)))
+    (if (eval:interpreted-function-p res)
+	(values res named-p (if (eval:interpreted-function-closure res)
+				:interpreted-closure :interpreted))
+	(case (kernel:get-type res)
+	  (#.vm:closure-header-type
+	   (values (kernel:%closure-function res) named-p :compiled-closure))
+	  (#.vm:funcallable-instance-header-type
+	   (values res named-p :funcallable-instance))
+	  (t (values res named-p :compiled))))))
+
 
-;;; This maps functions to the two breakpoints created in TRACE-1, so we can
-;;; get rid of them in UNTRACE-1.
+;;; TRACE-REDEFINED-UPDATE  --  Internal
 ;;;
-(defvar *trace-breakpoints* (make-hash-table :test #'eq))
+;;;    When a function name is redefined, and we were tracing that name, then
+;;; untrace the old definition and trace the new one.
 ;;;
-(defun clear-trace-breakpoint-record (fname new-value)
-  (declare (ignore new-value))
+(defun trace-redefined-update (fname new-value)
   (when (fboundp fname)
     (let* ((fun (trace-fdefinition fname))
-	   (bpts (gethash fun *trace-breakpoints*)))
-      (when bpts
-	;; Free breakpoint bookkeeping data.
-	(di:delete-breakpoint (car bpts))
-	(di:delete-breakpoint (cdr bpts))
-	;; Free TRACE bookkeeping data.
-	(setf (gethash fun *trace-breakpoints*) nil)))))
+	   (info (gethash fun *traced-functions*)))
+      (when (and info (trace-info-named info))
+	(untrace-1 fname)
+	(trace-1 fname info new-value)))))
 ;;;
-(push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
+(push #'trace-redefined-update ext:*setf-fdefinition-hook*)
 
-;;; TRACE-1 -- Internal.
+
+;;; COERCE-FORM, COERCE-FORM-LIST  --  Internal
 ;;;
-;;; This establishes :function-start and :function-end breakpoints with
-;;; appropriate hook functions to TRACE function-name as described by the user.
+;;;    Annotate some forms to evaluate with pre-converted functions.  Each form
+;;; is really a cons (exp . function).  Loc is the code location to use for
+;;; the lexical environment.  If Loc is NIL, evaluate in the null environment.
+;;; If Form is NIL, just return NIL.
 ;;;
-(defun trace-1 (function-or-name condition break break-after wherein print
-		 print-after)
-  (let ((fun (trace-fdefinition function-or-name)))
-    (when (member fun *traced-function-list*)
-      (warn "Function ~S already TRACE'd, retracing it." function-or-name)
-      (untrace-1 fun))
-    
-    (when wherein
-      (dolist (f wherein)
-	(unless (fboundp f)
-	  (error "Undefined :wherein name -- ~S." f))))
-    (let* ((debug-fun (di:function-debug-function fun))
-	   ;; The start and end hooks use conditionp for communication.
-	   (conditionp nil)
-	   (start (di:make-breakpoint
-		   #'(lambda (frame bpt)
-		       (let ((*trace-frame* frame))
-			 (cond ((and (or (not condition) ;Save a call to EVAL
-					 (eval condition))
-				     (or (not wherein)
-					 (trace-wherein-p frame wherein)))
-				(setf conditionp t)
-				(print-trace-start frame bpt print))
-			       (t (setf conditionp nil)))
-			 (when (and break (eval break))
-			   (di:flush-frames-above frame)
-			   (let ((*stack-top-hint* frame))
-			     (break "Breaking before TRACE'd call to ~S."
-				    function-or-name)))))
-		   debug-fun :kind :function-start))
-	   (end (di:make-breakpoint
-		 #'(lambda (frame bpt *trace-values* cookie)
-		     (if (member fun *traced-function-list*)
-			 (let ((*trace-frame* frame))
-			   (when conditionp
-			     (print-trace-end frame bpt *trace-values* cookie
-					      print-after))
-			   (pop *traced-entries*)
-			   (when (and break-after (eval break-after))
-			     (di:flush-frames-above frame)
-			     (let ((*stack-top-hint* frame))
-			       (break "Breaking after TRACE'd call to ~S."
-				      function-or-name))))
-			 (pop *traced-entries*)))
-		 debug-fun :kind :function-end
-		 :function-end-cookie
-		 #'(lambda (frame x)
-		     (when (and *traced-entries*
-				(not (di:function-end-cookie-valid-p
-				      frame (car *traced-entries*))))
-		       (loop
-			 (pop *traced-entries*)
-			 (when (or (not *traced-entries*)
-				   (di:function-end-cookie-valid-p
-				    frame (car *traced-entries*)))
-			   (return))))
-		     (push x *traced-entries*)))))
-      (assert (not (gethash fun *trace-breakpoints*)))
-      (setf (gethash fun *trace-breakpoints*) (cons start end))
-      ;; The next two forms must be in the order in which they appear.  They
-      ;; rely on a documented property that later activated breakpoint hooks
-      ;; run first, and the end breakpoint establishes a starting helper bpt.
-      (di:activate-breakpoint start)
-      (di:activate-breakpoint end))
-    (push fun *traced-function-list*)))
-
-;;; PRINT-TRACE-START -- Internal.
-;;;
-;;; This prints a representation of the call establishing frame.
-;;;
-(defun print-trace-start (frame bpt &optional print)
-  (declare (ignore bpt))
-  (let ((*print-length* (or *trace-print-length* *print-length*))
-	(*print-level* (or *trace-print-level* *print-level*)))
-    (fresh-line)
-    (print-trace-indentation)
-    (print-frame-call-1 frame nil)
-    (dolist (ele print)
-      (fresh-line)
-      (print-trace-indentation)
-      (prin1 (eval ele)))
-    (terpri)))
-
-;;; PRINT-TRACE-END -- Internal.
-;;;
-;;; This prints a representation of the return values delivered to frame by the
-;;; function for which bpt is a :function-end breakpoint.  First, this checks
-;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
-;;; need to adjust this list to determine the correct indentation for output.
-;;;
-(defun print-trace-end (frame bpt values cookie &optional print-after)
-  (declare (ignore frame bpt))
-  (unless (eq cookie (car *traced-entries*))
-    (setf *traced-entries* (member cookie *traced-entries*)))
-  (print-trace-indentation)
-  (write-string "returned ")
-  (dolist (v values)
-    (prin1 v)
-    (write-char #\space))
-  (dolist (ele print-after)
-    (terpri)
-    (print-trace-indentation)
-    (prin1 (eval ele)))
-  (terpri))
+(defun coerce-form (form loc)
+  (when form
+    (let ((exp (car form)))
+      (if (di:code-location-p loc)
+	  (let ((fun (di:preprocess-for-eval exp loc)))
+	    (cons exp
+		  #'(lambda (frame)
+		      (let ((*current-frame* frame))
+			(funcall fun frame)))))
+	  (let* ((bod (ecase loc
+			((nil) exp)
+			(:encapsulated
+			 `(flet ((debug:arg (n)
+				   (declare (special argument-list))
+				   (elt argument-list n)))
+			    (declare (ignorable #'debug:arg))
+			    ,exp))))
+		 (fun (coerce `(lambda () ,bod) 'function)))
+	    (cons exp
+		  #'(lambda (frame)
+		      (declare (ignore frame))
+		      (let ((*current-frame* nil))
+			(funcall fun)))))))))
+;;;
+(defun coerce-form-list (forms loc)
+  (mapcar #'(lambda (x) (coerce-form x loc)) forms))
 
+	      
+;;; PRINT-TRACE-INDENTATION  --  Internal
+;;;
+;;;    Print indentation according to the number of trace entries.  Entries
+;;; whose condition was false don't count.
+;;;
 (defun print-trace-indentation ()
-  (let ((len (length (the list *traced-entries*))))
-    (dotimes (i len) (write-string "  "))
-    (prin1 len)
-    (write-string ": ")))
+  (let ((depth 0))
+    (dolist (entry *traced-entries*)
+      (when (cdr entry) (incf depth)))
+    (format t "~&~VT~D: "
+	    (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2)
+	    depth)))
+
 
 ;;; TRACE-WHEREIN-P -- Internal.
 ;;;
-;;; The TRACE hooks use this for the :wherein arg.
+;;;    Return true if one of the Names appears on the stack below Frame.
 ;;;
 (defun trace-wherein-p (frame names)
   (do ((frame (di:frame-down frame) (di:frame-down frame)))
@@ -320,26 +235,432 @@
 		  names :test #'equal)
       (return t))))
 
+;;; TRACE-PRINT  --  Internal
+;;;
+;;;    Handle print and print-after options.
+;;;
+(defun trace-print (frame forms)
+  (dolist (ele forms)
+    (fresh-line)
+    (print-trace-indentation)
+    (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
+
+;;; TRACE-MAYBE-BREAK  --  Internal
+;;;
+;;;    Test a break option, and break if true.
+;;;
+(defun trace-maybe-break (info break where frame)
+  (when (and break (funcall (cdr break) frame))
+    (di:flush-frames-above frame)
+    (let ((*stack-top-hint* frame))
+      (break "Breaking ~A traced call to ~S:" where
+	     (trace-info-what info)))))
+
+;;; DISCARD-INVALID-ENTRIES  --  Internal
+;;;
+;;;    This function discards any invalid cookies on our simulated stack.
+;;; Encapsulated entries are always valid, since we bind *traced-entries* in
+;;; the encapsulation.
+;;;
+(defun discard-invalid-entries (frame)
+  (loop
+    (when (or (null *traced-entries*)
+	      (let ((cookie (caar *traced-entries*)))
+		(or (not cookie)
+		    (di:function-end-cookie-valid-p frame cookie))))
+      (return))
+    (pop *traced-entries*)))
 
 
-;;;; N-UNTRACE.
+;;;; Hook functions:
+
+;;; TRACE-START-BREAKPOINT-FUN -- Internal.
+;;;
+;;;    Return a closure that can be used for a function start breakpoint hook
+;;; function and a closure that can be used as the FUNCTION-END-COOKIE
+;;; function.  The first communicates the sense of the Condition to the second
+;;; via a closure variable.
+;;;
+(defun trace-start-breakpoint-fun (info)
+  (let (conditionp)
+    (values
+     #'(lambda (frame bpt)
+	 (declare (ignore bpt))
+	 (discard-invalid-entries frame)
+	 (let ((condition (trace-info-condition info))
+	       (wherein (trace-info-wherein info)))
+	   (setq conditionp
+		 (and (not *in-trace*)
+		      (or (not condition)
+			  (funcall (cdr condition) frame))
+		      (or (not wherein)
+			  (trace-wherein-p frame wherein)))))
+	 
+	 (when conditionp
+	   (let ((*print-length* (or *debug-print-length* *print-length*))
+		 (*print-level* (or *debug-print-level* *print-level*))
+		 (*standard-output* *trace-output*)
+		 (*in-trace* t))
+	     (fresh-line)
+	     (print-trace-indentation)
+	     (if (trace-info-encapsulated info)
+		 (locally (declare (special basic-definition argument-list))
+		   (prin1 `(,(trace-info-what info) ,@argument-list)))
+		 (print-frame-call-1 frame nil))
+	     (terpri)
+	     (trace-print frame (trace-info-print info)))
+	   (trace-maybe-break info (trace-info-break info) "before" frame)))
+
+     #'(lambda (frame cookie)
+	 (declare (ignore frame))
+	 (push (cons cookie conditionp) *traced-entries*)))))
+
+
+;;; TRACE-END-BREAKPOINT-FUN  --  Internal
+;;; 
+;;;    This prints a representation of the return values delivered.  First,
+;;; this checks to see that cookie is at the top of *traced-entries*; if it is
+;;; not, then we need to adjust this list to determine the correct indentation
+;;; for output.  We then check to see if the function is still traced and that
+;;; the condition succeeded before printing anything.
+;;;
+(defun trace-end-breakpoint-fun (info)
+  #'(lambda (frame bpt *trace-values* cookie)
+      (declare (ignore bpt))
+      (unless (eq cookie (caar *traced-entries*))
+	(setf *traced-entries*
+	      (member cookie *traced-entries* :key #'car)))
+      
+      (let ((entry (pop *traced-entries*)))
+	(when (and (not (trace-info-untraced info))
+		   (or (cdr entry)
+		       (let ((cond (trace-info-condition-after info)))
+			 (and cond (funcall (cdr cond) frame)))))
+	  (let ((*print-length* (or *debug-print-length* *print-length*))
+		(*print-level* (or *debug-print-level* *print-level*))
+		(*standard-output* *trace-output*)
+		(*in-trace* t))
+	    (print-trace-indentation)
+	    (format t "~S returned " (trace-info-what info))
+	    (dolist (v *trace-values*)
+	      (prin1 v)
+	      (write-char #\space))
+	    (trace-print frame (trace-info-print-after info))
+	    (terpri))
+	  (trace-maybe-break info (trace-info-break-after info)
+			     "after" frame)))))
+
+
+;;; TRACE-CALL  --  Internal
+;;;
+;;;    This function is called by the trace encapsulation.  It calls the
+;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
+;;; we have cleverly contrived to work for our hook functions.
+;;;
+(defun trace-call (info)
+  (multiple-value-bind
+      (start cookie)
+      (trace-start-breakpoint-fun info)
+    (let ((frame (di:frame-down (di:top-frame))))
+      (funcall start frame nil)
+      (let ((*traced-entries* *traced-entries*))
+	(declare (special basic-definition argument-list))
+	(funcall cookie frame nil)
+	(let ((vals
+	       (multiple-value-list
+		(apply basic-definition argument-list))))
+	  (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
+	  (values-list vals))))))
+
+
+;;; TRACE-1 -- Internal.
+;;;
+;;;    Trace one function according to the specified options.  We copy the
+;;; trace info (it was a quoted constant), fill in the functions, and then
+;;; install the breakpoints or encapsulation.
+;;;
+;;;    If non-null, Definition is the new definition of a function that we are
+;;; automatically retracing; this 
+;;;
+(defun trace-1 (function-or-name info &optional definition)
+  (multiple-value-bind
+      (fun named kind)
+      (if definition
+	  (values definition t
+		  (nth-value 2 (trace-fdefinition definition)))
+	  (trace-fdefinition function-or-name))
+    (when (gethash fun *traced-functions*)
+      (warn "Function ~S already TRACE'd, retracing it." function-or-name)
+      (untrace-1 fun))
+    
+    (let* ((debug-fun (di:function-debug-function fun))
+	   (encapsulated 
+	    (if (eq (trace-info-encapsulated info) :default)
+		(ecase kind
+		  (:compiled nil)
+		  (:compiled-closure
+		   (unless (functionp function-or-name)
+		     (warn "Tracing shared code for ~S:~%  ~S"
+			   function-or-name fun))
+		   nil)
+		  ((:interpreted :interpreted-closure :funcallable-instance)
+		   t))
+		(trace-info-encapsulated info)))
+	   (loc (if encapsulated
+		    :encapsulated
+		    (di:debug-function-start-location debug-fun)))
+	   (info (make-trace-info
+		  :what function-or-name
+		  :named named
+		  :encapsulated encapsulated
+		  :wherein (trace-info-wherein info)
+		  :condition (coerce-form (trace-info-condition info) loc)
+		  :break (coerce-form (trace-info-break info) loc)
+		  :print (coerce-form-list (trace-info-print info) loc)
+		  :break-after (coerce-form (trace-info-break-after info) nil)
+		  :condition-after
+		  (coerce-form (trace-info-condition-after info) nil)
+		  :print-after
+		  (coerce-form-list (trace-info-print-after info) nil))))
+
+      (dolist (wherein (trace-info-wherein info))
+	(unless (or (stringp wherein)
+		    (fboundp wherein))
+	  (warn ":WHEREIN name is not a defined global function: ~S"
+		wherein)))
+
+      (cond
+       (encapsulated
+	(unless named
+	  (error "Can't use encapsulation to trace anonymous function ~S."
+		 fun))
+	(ext:encapsulate function-or-name 'trace `(trace-call ',info)))
+       (t
+	(multiple-value-bind
+	    (start-fun cookie-fun)
+	    (trace-start-breakpoint-fun info)
+	  (let ((start (di:make-breakpoint start-fun debug-fun
+					   :kind :function-start))
+		(end (di:make-breakpoint
+		      (trace-end-breakpoint-fun info)
+		      debug-fun :kind :function-end
+		      :function-end-cookie cookie-fun)))
+	    (setf (trace-info-start-breakpoint info) start)
+	    (setf (trace-info-end-breakpoint info) end)
+	    ;;
+	    ;; The next two forms must be in the order in which they appear,
+	    ;; since the start breakpoint must run before the function-end
+	    ;; breakpoint's start helper (which calls the cookie function.)
+	    ;; One reason is that cookie function requires that the CONDITIONP
+	    ;; shared closure variable be initialized.
+	    (di:activate-breakpoint start)
+	    (di:activate-breakpoint end)))))
+
+      (setf (gethash fun *traced-functions*) info)))
+
+  function-or-name)
+
+
+;;;; The TRACE macro:
+
+;;;  PARSE-TRACE-OPTIONS  --  Internal
+;;;
+;;;    Parse leading trace options off of Specs, modifying Info accordingly.
+;;; The remaining portion of the list is returned when we encounter a plausible
+;;; function name.
+;;;
+(defun parse-trace-options (specs info)
+  (let ((current specs))
+    (loop
+      (when (endp current) (return))
+      (let ((option (first current))
+	    (value (cons (second current) nil)))
+	(case option
+	  (:condition (setf (trace-info-condition info) value))
+	  (:condition-after
+	   (setf (trace-info-condition info) (cons nil nil))
+	   (setf (trace-info-condition-after info) value))
+	  (:condition-all
+	   (setf (trace-info-condition info) value)
+	   (setf (trace-info-condition-after info) value))
+	  (:wherein
+	   (setf (trace-info-wherein info)
+		 (if (listp (car value)) (car value) value)))
+	  (:encapsulate
+	   (setf (trace-info-encapsulated info) (car value)))
+	  (:break (setf (trace-info-break info) value))
+	  (:break-after (setf (trace-info-break-after info) value))
+	  (:break-all
+	   (setf (trace-info-break info) value)
+	   (setf (trace-info-break-after info) value))
+	  (:print
+	   (setf (trace-info-print info)
+		 (append (trace-info-print info) (list value))))
+	  (:print-after
+	   (setf (trace-info-print-after info)
+		 (append (trace-info-print-after info) (list value))))
+	  (:print-all
+	   (setf (trace-info-print info)
+		 (append (trace-info-print info) (list value)))
+	   (setf (trace-info-print-after info)
+		 (append (trace-info-print-after info) (list value))))
+	  (t (return)))
+	(pop current)
+	(unless current
+	  (error "Missing argument to ~S TRACE option." option))
+	(pop current)))
+    current))
+
+
+;;; EXPAND-TRACE  --  Internal
+;;;
+;;;    Compute the expansion of TRACE in the non-trivial case (arguments
+;;; specified.)  If there are no :FUNCTION specs, then don't use a LET.  This
+;;; allows TRACE to be used without the full interpreter.
+;;;
+(defun expand-trace (specs)
+  (collect ((binds)
+	    (forms))
+    (let* ((global-options (make-trace-info))
+	   (current (parse-trace-options specs global-options)))
+      (loop
+	(when (endp current) (return))
+	(let ((name (pop current))
+	      (options (copy-trace-info global-options)))
+	  (cond
+	   ((eq name :function)
+	    (let ((temp (gensym)))
+	      (binds `(,temp ,(pop current)))
+	      (forms `(trace-1 ,temp ',options))))
+	   ((and (keywordp name)
+		 (not (or (fboundp name) (macro-function name))))
+	    (error "Unknown TRACE option: ~S" name))
+	   (t
+	    (forms `(trace-1 ',name ',options))))
+	  (setq current (parse-trace-options current options)))))
+
+    (if (binds)
+	`(let ,(binds) (list ,@(forms)))
+	`(list ,@(forms)))))
+
+
+;;; %LIST-TRACED-FUNCTIONS  --  Internal
+;;;
+(defun %list-traced-functions ()
+  (loop for x being each hash-value in *traced-functions*
+        collect (trace-info-what x)))
+
+
+;;; TRACE -- Public.
+;;;
+(defmacro trace (&rest specs)
+  "TRACE {Option Global-Value}* {Name {Option Value}*}*
+   TRACE is a debugging tool that prints information when specified functions
+   are called.  In its simplest form:
+       (trace Name-1 Name-2 ...)
+
+   TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
+   functions is entered or returns (the Names are not evaluated.)  The output
+   is indented according to the number of pending traced calls, and this trace
+   depth is printed at the beginning of each line of output.
+
+   Options allow modification of the default behavior.  Each option is a pair
+   of an option keyword and a value form.  Options may be interspersed with
+   function names.  Options only affect tracing of the function whose name they
+   appear immediately after.  Global options are specified before the first
+   name, and affect all functions traced by a given use of TRACE.
+
+   The following options are defined:
+
+   :CONDITION Form
+   :CONDITION-AFTER Form
+   :CONDITION-ALL Form
+       If :CONDITION is specified, then TRACE does nothing unless Form
+       evaluates to true at the time of the call.  :CONDITION-AFTER is
+       similar, but suppresses the initial printout, and is tested when the
+       function returns.  :CONDITION-ALL tries both before and after.
+
+   :WHEREIN Names
+       If specified, Names is a function name or list of names.  TRACE does
+       nothing unless a call to one of those functions encloses the call to
+       this function (i.e. it would appear in a backtrace.)  Anonymous
+       functions have string names like \"DEFUN FOO\".
+
+   :BREAK Form
+   :BREAK-AFTER Form
+   :BREAK-ALL Form
+       If specified, and Form evaluates to true, then the debugger is invoked
+       at the start of the function, at the end of the function, or both,
+       according to the respective option.
+
+   :PRINT Form
+   :PRINT-AFTER Form
+   :PRINT-ALL Form
+       In addition to the usual prinout, he result of evaluating Form is
+       printed at the start of the function, at the end of the function, or
+       both, according to the respective option.  Multiple print options cause
+       multiple values to be printed.
+
+   :FUNCTION Function-Form
+       This is a not really an option, but rather another way of specifying
+       what function to trace.  The Function-Form is evaluated immediately,
+       and the resulting function is traced.
+
+   :ENCAPSULATE {:DEFAULT | T | NIL}
+       If T, the tracing is done via encapsulation (redefining the function
+       name) rather than by modifying the function.  :DEFAULT is the default,
+       and means to use encapsulation for interpreted functions and funcallable
+       instances, breakpoints otherwise.  When encapsulation is used, forms are
+       *not* evaluated in the function's lexical environment, but DEBUG:ARG can
+       still be used.
+
+   :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
+   of the called function; DEBUG:VAR and DEBUG:ARG can be used.  The -AFTER and
+   -ALL forms are evaluated in the null environment."
+  (if specs
+      (expand-trace specs)
+      '(%list-traced-functions)))
+
+
+;;;; Untracing:
+
+;;; UNTRACE-1  --  Internal
+;;;
+;;;    Untrace one function.
+;;;
+(defun untrace-1 (function-or-name)
+  (let* ((fun (trace-fdefinition function-or-name))
+	 (info (gethash fun *traced-functions*)))
+    (cond
+     ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name))
+     ((trace-info-encapsulated info)
+      (ext:unencapsulate (trace-info-what info) 'trace))
+     (t
+      (di:delete-breakpoint (trace-info-start-breakpoint info))
+      (di:delete-breakpoint (trace-info-end-breakpoint info))))
+    (setf (trace-info-untraced info) t)
+    (remhash fun *traced-functions*)))
+
+;;; UNTRACE-ALL  --  Internal
+;;;
+;;;    Untrace all traced functions.
+;;;
+(defun untrace-all ()
+  (dolist (fun (%list-traced-functions))
+    (untrace-1 fun))
+  t)
 
 (defmacro untrace (&rest specs)
   "Removes tracing from the specified functions.  With no args, untraces all
    functions."
-  (let ((specs (or specs *traced-function-list*)))
-    `(progn
-       ,@(mapcar #'(lambda (spec)
-		     `(untrace-1 ',(if (consp spec) (car spec) spec)))
-		 specs)
-       t)))
-
-(defun untrace-1 (function-or-name)
-  (let ((fun (trace-fdefinition function-or-name)))
-    (cond ((member fun *traced-function-list*)
-	   (let ((breakpoints (gethash fun *trace-breakpoints*)))
-	     (di:delete-breakpoint (car breakpoints))
-	     (di:delete-breakpoint (cdr breakpoints))
-	     (setf (gethash fun *trace-breakpoints*) nil))
-	   (setf *traced-function-list* (delete fun *traced-function-list*)))
-	  (t (warn "Function is not TRACE'd -- ~S." fun)))))
+  (if specs
+      (collect ((res))
+	(let ((current specs))
+	  (loop
+	    (unless current (return))
+	    (let ((name (pop current)))
+	      (res (if (eq name :function)
+		       `(untrace-1 ,(pop current))
+		       `(untrace-1 ',name)))))
+	  `(progn ,@(res) t)))
+      '(untrace-all)))
-- 
GitLab