;;; -*- Mode:Common-Lisp; Package:Doc; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved.


Ï1;;;Ï*	Ï2Cross-reference and documentation utility - usage finders

Ï1;;;Ï*Ï*     Ï1  Ï2Note: this file requires Explorer release 3 or later.Ï*

;Version:
;  7/22/87 DNG - Original.
;  8/25/87 DNG - Update Ï*find-things-used-by-fileÏ1 to read the file when the 
;Ï*		Ï1information is not on the generic pathname plist.
;  9/11/87 DNG - Added new function Ï*find-things-used-by-initializationsÏ1 and 
;Ï*		Ï1added handling of UCL command tables to Ï*find-things-used-by-symbolÏ1 .
;  9/15/87 DNG - Updated Ï*find-things-used-by-symbolÏ1 to find function names 
;Ï*		Ï1appearing as values or properties of symbols.
;  9/17/87 DNG - Fixed Ï*find-things-used-by-symbolÏ1 to not loop forever if the symbol's value is a circular list.
;  9/22/87 DNG - Fixed Ï*report-list-of-usesÏ1 to not loop forever on undefined function.
; 10/09/87 DNG - Added special handling for crash lists to Ï*find-things-used-by-symbol .
Ï1; 11/17/87 DNG - Automatic loading of the code walker when necessary.
;  2/01/88 DNG - Don't need to load code-walker changes under release 4.
;  2/09/88 DNG - New function Ï*load-code-walkerÏ1 .  Fix Ï*find-things-used-by-fileÏ1 
;Ï*		Ï1to not be fooled by incomplete Ï*:definitionsÏ1 property.
;Ï*	Ï1-- The following changes are for release 6.  --
;  1/13/89 DNG - Update Ï*cw-handlerÏ1s to not break CLOS code walker.
;  1/16/89 DNG - Update Ï*find-things-used-by-fefÏ1 to scan methods of generic 
;Ï*		Ï1functions and record references to CLOS slots.
;  1/18/89 DNG - Incorporate code from DLC to automatically update table when Ï*fdefine Ï1is called.
;  1/21/89 DNG - Update Ï*find-things-used-by-symbolÏ1 to handle Ï*setf Ï1and Ï*locfÏ1 functions.
;  1/31/89 DNG - Update Ï*find-things-used-by-fefÏ1 to recognize calls to Ï*setf Ï1and Ï*locfÏ1 functions.
;  3/06/89 DNG - Added cw handler for Ï*add-methodÏ1.
;  4/25/89 DNG - Add recognition of Ï*defconstantÏ1s expanded.

;;  Each of the Ï*find-things-used-by-...Ï1 functions takes as an argument a 
;;  function which will be called for each reference found.  The function 
;;  should accept three arguments:  the name of the caller, the name of the 
;;  thing being used, and the kind of reference which is one of:
;;Ï*	:functionÏ1  - function call
;;Ï*	:macroÏ1      - uses expansion of a macro or inline function expansion
;;Ï*	:variableÏ1  - special variable access
;;Ï*	:constantÏ1  - symbol used as a quoted constant
;;Ï*	:instance-variableÏ1 - instance variable of Ï*selfÏ1 in a compiled flavor method
;;Ï*	:slot	 Ï1  - slot reference in a CLOS method
;;Ï*	:flavor	 Ï1  - symbol used as the name of a flavor
;;Ï*	:method   Ï1 - first arg is a flavor which defines a method for this operationÏ*

(defun FIND-THINGS-USED-BY-OBJECT (object handler)
  (cond ((symbolp object) (FIND-THINGS-USED-BY-SYMBOL object handler t))
	((functionp object t)
	 (FIND-THINGS-USED-BY-FUNCTION (function-name object) object handler))
	((si:validate-function-spec object)
	 (FIND-THINGS-USED-BY-FUNCTION
	   object (fdefinition (si:unencapsulate-function-spec object)) handler))
	((consp object)
	 (FIND-THINGS-USED-BY-EVALUATED-LIST object object handler))
	((or (pathnamep object) (stringp object))
	 Ï1;; report on random forms that were executed at top-level when the file was loaded.Ï*
	 (FIND-THINGS-USED-BY-FILE object handler))
	(t (error "~S is not a function, function-spec, expression, or pathname." object))
	))

(defun FIND-THINGS-USED-BY-SYMBOL (caller function &optional ignore-previous-definition-p)
  (declare (arglist symbol handler-function &optional ignore-previous-definition-p))
  "Call HANDLER-FUNCTION for each thing that is referenced by the definition of SYMBOL."
Ï1  ;; This function was adapted from Ï*SYS:FIND-CALLERS-OF-SYMBOLS-AUXÏ1 .

  ;; Ignore all symbols which are forwarded to others, to avoid duplication.Ï*
  (when (and (/= (sys:%p-data-type-offset caller 2) sys:dtp-one-q-forward)
	     (fboundp caller))
    (FIND-THINGS-USED-BY-FUNCTION caller (symbol-function caller) function))
  (when (/= (sys:%p-data-type-offset caller 3) sys:dtp-one-q-forward)
    Ï1;; Also look for propertiesÏ*
    (loop for (prop value) on (symbol-plist caller) by #'cddr
	  do (cond ((symbolp value)
		    (when (fboundp value)
		      (funcall function `(:property ,caller ,prop) value :constant)))
		   ((and (functionp value t)
			 (or (not ignore-previous-definition-p)
			     (not (eq prop ':PREVIOUS-DEFINITION))))
		    (FIND-THINGS-USED-BY-FUNCTION `(:property ,caller ,prop)
						  value function))
		   ((and (consp value)
			 (consp (car value))
			 (consp (cdr (car value)))
			 (eq caller (second (car value)))
			 (si:validate-function-spec (car value)))
		    (let ((defn (si:fdefinition-safe (car value) nil)))
		      (when (and defn (member defn (cdr value) :test #'eq))
			Ï1;; here for Ï*setfÏ1 and Ï*locfÏ1 functionsÏ*
			(FIND-THINGS-USED-BY-FUNCTION (car value)
						      (si:fdefinition-safe (car value) t)
						      function))))
		   ))
    Ï1;; Also look for flavor methodsÏ*
    (let ((fl (get caller 'si:flavor)))
      (when (and fl (arrayp fl))			;Could be T
	(dolist (mte (sys:flavor-method-table fl))
	  (dolist (meth (cdddr mte))
	    (when (sys:meth-definedp meth)
	      (when (eq function #'enter-in-xref-table)
		(let ((op (car-safe (last (sys:meth-function-spec meth)))))
		  (when (keywordp op)
		    (funcall function caller op ':method))))
	      (FIND-THINGS-USED-BY-FUNCTION (sys:meth-function-spec meth)
					    (sys:meth-definition meth)
					    function)))) ))
    (when (boundp caller)
      (CATCH-ERROR-RESTART (ERROR "Give up looking at the value of ~S" caller)
	(let ((value (symbol-value caller)))
	  (cond ((symbolp value)
		 (when (fboundp value)
		   (funcall function caller value :constant)))
		((consp value)
		 (cond ((get caller 'si:initialization-list)
			Ï1;; It is an initialization list.Ï*
			(dolist (init-list-entry value)
			  (FIND-THINGS-USED-BY-EVALUATED-LIST
			    caller (sys:init-form init-list-entry) function)))
		       ((member caller '(si:*EXTERNAL-SYSTEM-SYMBOLS*
					  si:*INITIAL-COMMON-LISP-SYMBOLS* si:*INITIAL-ZLC-SYMBOLS*
					  si:*INITIAL-TICL-SYMBOLS*) :test #'eq)) Ï1; ignore theseÏ*
		       ((member caller '(si::AUX-CRASH-LIST si::LISP-CRASH-LIST
					 si::ORIGINAL-LISP-CRASH-LIST si::Cold-Hardware-Initializations)
				:test #'eq)
			(FIND-THINGS-USED-BY-EVALUATED-LIST
			    caller (cons 'progn value) function))
		       ((null (list-length value)))	Ï1; watch out for circular listsÏ*
		       (t (dolist (x value)
			    (when (and (symbolp x) (fboundp x))
			      (funcall function caller x :constant))))
		       ))
		((vectorp value)
		 (when (eq (array-type value) 'si:art-q)
		   (ignore-errors Ï1; because a couple of system arrays contain Ï*DTP-TRAPÏ1sÏ*
		     (dotimes (i (length value))
		       (let ((x (aref value i)))
			 (when (and (symbolp x) (fboundp x))
			   (funcall function caller x :constant)))))))
		((and (instancep value)
		      (typep value 'ucl:command-table))
		 Ï1;; Look for functions used in a UCL command table.Ï*
		 (let ((commands (send value :commands)))
		   (dotimes (i (length commands))
		     (let ((defn (send (aref commands i) :definition)))
		       (when (and defn (symbolp defn))
			 (funcall function caller defn :function)
			 )))))
		)))) ))

(defun FIND-THINGS-USED-BY-FUNCTION (caller defn handler)
  (declare (arglist function-name function-definition handler-function))
  "Call HANDLER-FUNCTION for each thing that is referenced by FUNCTION-DEFINITION."
  Ï1;; Adapted from Ï*SYS:FIND-CALLERS-OF-SYMBOLS-AUX1Ï1 .Ï*
  
  Ï1;; Don't be fooled by macros, interpreted or compiled.Ï*
  (when (and (consp defn) (eq (car defn) 'macro))
    (setq defn (cdr defn)))
  (when (functionp defn t)
    (CATCH-ERROR-RESTART (ERROR "Give up looking at function ~S" caller)
      (typecase defn
	(compiled-function (FIND-THINGS-USED-BY-FEF caller defn handler))
	(list (FIND-THINGS-USED-BY-LAMBDA-EXPRESSION caller defn handler))
	(closure (FIND-THINGS-USED-BY-FUNCTION caller (closure-function defn) handler))
	(symbol (unless (null defn) (funcall handler caller defn :function)))
	)
      Ï1;; If this function is traced, advised, etc.Ï*
      Ï1;; then look through the actual definition.Ï*
      (when (or (listp defn) (typep defn 'compiled-function))
	(let* ((debug-info  (si:get-debug-info-struct defn))
	       (inner  (car (si:get-debug-info-field debug-info 'si:encapsulated-definition))))
	  (when inner
	    (FIND-THINGS-USED-BY-FUNCTION caller (fdefinition inner) handler)))))
    (values)))

(defun FIND-THINGS-USED-BY-FEF (caller defn function)
  Ï1;; Adapted from Ï*SYS:FIND-CALLERS-OF-SYMBOLS-AUX-FEFÏ1 . Ï*
  (do ((i si:%fef-header-length (1+ i))
       (lim (truncate (si:fef-initial-pc defn) 2))
       tem offset sym)
      ((>= i lim) nil)
    (cond ((= (sys:%p-data-type-offset defn i) sys:dtp-external-value-cell-pointer)
	   (setq tem (sys:%p-contents-as-locative-offset defn i)
		 sym (sys:%find-structure-header tem)
		 offset (sys:%pointer-difference tem sym))
	   (cond ((not (symbolp sym))
		  (when (and (consp sym)
			     (consp (car sym))
			     (sys:validate-function-spec (car sym)))
			 ;; The list could be a flavor "meth" list, or a CLOS
			 ;; "method-spec-object", or a SETF-GENERIC-FUNCTION property.
			 ;; In all of these cases, the function spec is the first
			 ;; element of the list.
		    (funcall function caller (car sym) :function)))
		 ((= offset 2)			Ï1;Ï* Ï1Function cell referenceÏ*
		  (funcall function caller sym :function))
		 (t				Ï1; Value reference presumablyÏ*
		  (funcall function caller sym :variable))))
	  ((= (sys:%p-data-type-offset defn i) sys:dtp-self-ref-pointer)
	   (LET ((NUMBER (sys:%P-POINTER-OFFSET DEFN i)))
	     (IF (ZEROP (sys:%LOGLDB SYS:%%SELF-REF-TYPE-FLAG NUMBER))
		 ;; Flavors reference
		 (let ((fn (si:fef-flavor-name defn)))
		   (unless (null fn)
		       (multiple-value-bind (name map-flag)
			   (si:flavor-decode-self-ref-pointer fn number)
			 (funcall function caller name
				  (if map-flag :flavor :instance-variable)))))
	       ;; Else CLOS reference.
	       (MULTIPLE-VALUE-BIND (NAME MAP-FLAG)
		   (compiler:DECODE-CLOS-SELF-REF-POINTER DEFN NUMBER)
		 (when (and name (not map-flag))
		   (funcall function caller name :slot))))))
	  ((symbolp (setq sym (sys:%p-contents-offset defn i)))
	   (unless (and (<= i sys:%fef-second-optional-word)
			(eq sym (si:fef-flavor-name defn)))
	     (funcall function caller sym :constant)))))
  Ï1;; See if the fef uses the symbol as a macro.Ï*
  (let ((debug-info (si:get-debug-info-struct defn)))
    (dolist (m  (si:get-debug-info-field debug-info :macros-expanded))
      (funcall function caller (if (atom m) m (car m)) :macro))
    (dolist (m  (si:get-debug-info-field debug-info :constants-open-coded)) Ï1; new in release 6Ï*
      (funcall function caller (if (atom m) m (car m)) :variable))
  (COMMENT
  ;; See if we have a function reference compiled into a misc instruction
  (if (symbolp symbol)
      (let ((misc-function (si:fef-calls-misc-function defn symbol)))
	(when misc-function
	  (funcall function caller symbol misc-function)))
      (dolist (sym symbol)
	(let ((misc-function (si:fef-calls-misc-function defn sym)))
	  (when misc-function
	    (funcall function caller sym misc-function)))))
  ) ; end comment
    (loop for offset in (si:get-debug-info-field debug-info :internal-fef-offsets)
	  for i from 0
	  when (numberp offset)
	  do (let ((idef (sys:%p-contents-offset defn offset)))
	       (when (and (consp idef)Ï1 ; definition not filled in yetÏ*
			  (< (send current-process :priority) 0))Ï1 ; background processÏ*
		Ï1 Ï*(sleep 2) Ï1; wait, hoping another process will store the definition.Ï*
		Ï1 Ï*(setq idef (sys:%p-contents-offset defn offset)))
	       (when (compiled-function-p idef)
		 (let ((iname (function-name idef)) indef )
		   (FIND-THINGS-USED-BY-FEF (cond ((consp iname)
						   (cond ((equal (second iname) caller)
							  iname)
							 ((pathnamep caller)
							  caller)
							 (t `(:internal ,caller ,(third iname)))))
						  ((and (symbolp iname)
							(or (eq idef (setq indef (si:fdefinition-safe iname t)))
							    (and (closurep indef)
								 (eq idef (closure-function indef)))))
						   iname)
						  ((pathnamep caller)
						   caller)
						  (t `(:internal ,caller ,i)))
					    idef
					    function)))))
    (let ((gfun (si:get-debug-info-field debug-info :generic-function)))
      (unless (null gfun)
	Ï1;; scan the methods of a generic functionÏ*
	(dolist (method (call-if-defined "CLOS" "GENERIC-FUNCTION-METHODS" gfun))
	  (let ((fn (clos:method-function method)))
	    (find-things-used-by-function (function-name fn) fn function)))))
    (when (and (consp caller)
	       (eq (first caller) ':method)
	       (eq function #'enter-in-xref-table))
      (let ((op (car (last caller))))
	(when (keywordp op)
	  Ï1;; record the fact that this flavor defines a method on this operation.Ï*
	  (funcall function (second caller) opÏ1 Ï*':method))))
    )
  (values))

(defun report-list-of-uses (list type caller function)
  (let ((new-list nil))
    (dolist (x list)
      (unless (and (eq type ':function)
		   (symbolp x)
		   Ï1;; exclude Lisp primitives that wouldn't appear in compiled codeÏ*
		   (if (eq (symbol-package x) sys:*lisp-package*)
		       (or (getl x '(compiler:p2 compiler:opcode)) 
			   (and (get x 'compiler:p1)
				(special-form-p x))
			   (member x '(quote) :test #'eq))
		     (member x '(si:displaced WITH-STACK-LIST WITH-STACK-LIST*) :test #'eq)))
	(push x new-list)))
    Ï1;; Ï*new-listÏ1 is now in order of first referenceÏ*
    (dolist (x new-list) 
      (funcall function caller x (cond ((and (eq type ':variable)
					     (keywordp x))
					':constant)
				       ((and (eq type ':function)
					     (let ((defn x))
					       (loop while (and defn (symbolp defn))
						     do (setq defn (si:fdefinition-safe defn)))
					       (eq (car-safe defn) 'macro)))
					':macro)
				       (t type))))))

(DEFUN FIND-THINGS-USED-BY-LAMBDA-EXPRESSION (CALLER DEFN FUNCTION)
  (load-code-walker)
  (multiple-value-bind (variables functions blocks go-tags)
      (compiler:CW-TOP-LEVEL-LAMBDA-EXPRESSION defn t t nil nil)
    (declare (ignore blocks go-tags))
    (report-list-of-uses variables ':variable caller function)
    (report-list-of-uses functions ':function caller function)
    (values)))

(DEFUN FIND-THINGS-USED-BY-EVALUATED-LIST (CALLER DEFN FUNCTION)
  (load-code-walker)
  (multiple-value-bind (variables functions blocks go-tags)
      (compiler:CW-TOP-LEVEL defn t t nil nil)
    (declare (ignore blocks go-tags))
    (report-list-of-uses variables ':variable caller function)
    (report-list-of-uses functions ':function caller function)
    (values)))

(defun load-code-walker ()
  (unless (fboundp 'compiler:CW-TOP-LEVEL)
    (if (ignore-errors (probe-file (make-pathname :host "SYS"
						  :directory "COMPILER"
						  :name "WALKER"
						  :canonical-type (si:local-binary-file-type)
						  :version :newest)))
	(load "SYS:COMPILER;WALKER")
      ;; For the microExplorer, a copy of this file is provided in the Documenter folder.
      (load (send '#,sys:fdefine-file-pathname :new-pathname
		  :name "WALKER"
		  :canonical-type (si:local-binary-file-type)
		  :version :newest)) )))
		  

(when (eql (si:get-system-version 'compiler) 3) Ï1; these changes included in release 4 Ï*
compiler:
 (defun cw-expression (exp &aux tem)
  ;; 10/18/86 DNG - Use si:args-desc instead of arglist to check for &quote args.
  ;;  1/28/87 DNG - Don't bind cw-function-environment to nil when expanding a local macro. [SPR 3088]
  ;;  6/19/87 DNG - Allow ALL-FUNCTIONS-TO-CHECK-FOR to be T to cause all to be returned.
  ;;  7/13/87 DNG - Modify update of ALL-FUNCTIONS to check for (SYMBOLP (CAR EXP))
  ;;		and use :TEST #'EQ for efficiency.
  ;;  9/22/87 DNG - Add :TEST #'EQ to the second PUSHNEW call for efficiency.
  (when (and (consp exp)
	     (symbolp (car exp))
	     (or (eq all-functions-to-check-for t)
		 (member (car exp) all-functions-to-check-for :test #'eq)))
    (pushnew (car exp) all-functions :test #'eq))
  (cond ((symbolp exp)
	 (when (or (eq all-variables-to-check-for t)
		   (member exp all-variables-to-check-for :test #'eq))
	   (pushnew exp all-variables :test #'eq))
	 exp)
	((atom exp) exp)
	((consp (car exp))
	 ;; Explicit lambda-expression
	 (if cw-return-expansion-flag
	     (cons (cw-lambda-expression (car exp))
		   (mapcar #'cw-expression (cdr exp)))
	   (cw-lambda-expression (car exp))
	   (mapc #'cw-expression (cdr exp))))
	((nsymbolp (car exp))
	 (cw-eval-args exp))
	((do ((tail cw-function-environment (cdr tail)))
	     ((atom tail))
	   (let ((frame (car tail)))
	     (setq tem
		   (get-location-or-nil (locf frame) (locf (fsymeval (car exp)))))
	     (when tem (return tem))))
	 (if (eq (car-safe (contents tem)) 'macro)
	     ;; Local definition is a macro.  Call its expander.
	     (let ((si:*macroexpand-environment* (list nil cw-function-environment)))
	       (cw-expression (funcall (cdr (contents tem)) exp
				       si:*macroexpand-environment*)))
	   ;; Local definition is not a macro.  Assume it evals its args.
	   (cw-eval-args exp)))
	((setq tem (get (car exp) 'cw-handler))
	 ;; special form with its own way of doing this.
	 (funcall tem exp))
	;;kludge to deal with &quote. Blech
	((and (fboundp (car exp))
	      (nth-value 3 (si:args-desc (car exp))))
	 (let ((quoted nil)
	       (tem (arglist (car exp) t)))
	   (flet ((frob (arg) (do ((x (pop tem) (pop tem)))
				  ((not (member x lambda-list-keywords :test #'eq))
				   (if quoted arg (cw-expression arg)))
				(cond ((eq x '&quote) (setq quoted t))
				      ((eq x '&eval) (setq quoted nil))))))
	     (if cw-return-expansion-flag
		 (cons (car exp) (mapcar #'frob (cdr exp)))
	       (mapc #'frob (cdr exp))))))
	((multiple-value-bind (v1 v2)
	     (with-stack-list (env nil cw-function-environment)
	       (macroexpand-1 exp env))
	   (setq tem v1)
	   v2)
	 ;; Macro call.
	 (cw-expression tem))
	(t
	 (cw-eval-args exp))))

compiler:
 (defun (:property function cw-handler) (exp)
  ;;  7/22/86 DNG - Don't call CW-LAMBDA-EXPRESSION on a non-symbol function spec. 
  ;;  6/19/87 DNG - Allow ALL-FUNCTIONS-TO-CHECK-FOR to be T to cause all to be returned. 
  (if (consp (cadr exp))
      (if (keywordp (car exp)) ; probably a function spec
	  exp
	;; else should be a lambda expression
	(if cw-return-expansion-flag
	    (list 'function (cw-lambda-expression (cadr exp)))
	  (cw-lambda-expression (cadr exp))))
    (progn
      (when (or (eq all-functions-to-check-for t)
		(member (cadr exp) all-functions-to-check-for :test #'eq))
	(pushnew (cadr exp) all-functions))
      exp)))

 )Ï1 ; end when release 3Ï*

compiler:
(defun (:property si:displaced cw-handler) (exp)
  ;;  7/13/87 DNG - Original version; added so that the name of the expanded
  ;;		macro will be included in ALL-FUNCTIONS.
  (let (( original (second exp) )
	( expansion (third exp) ))
    (when (and (consp original)
	       (boundp 'all-functions-to-check-for)
	       (or (eq all-functions-to-check-for t)
		   (member (car original) all-functions-to-check-for :test #'eq)))
      (pushnew (car original) all-functions :test #'eq))
    (cw-expression expansion)))

compiler:
(defvar *functions-defined*)

compiler:
(defun (:property fdefine cw-handler) (exp)
  (cond (cw-return-expansion-flag
	 (cons (car exp) (mapcar #'cw-expression (cdr exp))))
	((and (boundp 'all-functions-to-check-for)
	      (eq all-functions-to-check-for t)
	      (eq (car-safe (third exp)) 'function)
	      (boundp '*functions-defined*))
	 ;; When called from DOC:FIND-THINGS-USED-BY-FILE,
	 ;; don't scan the LAMBDA expression.
	 (when (quotep (second exp))
	   (pushnew (second (second exp)) *functions-defined* :test #'equal))
	 (cw-expression (second exp))
	 (cw-expression (fourth exp)))
	(t (mapc #'cw-expression (cdr exp)))))

compiler:
(defun (:property ticlos:add-method cw-handler) (exp)
  ;;  3/06/89 DNG - Original.  Added so that DOC:BUILD-XREF-TABLE-FROM-FILE 
  ;;		will find accessor methods defined by the expansion of DEFCLASS.
  (declare (notinline cw-eval-args every) (optimize (speed 0)))
  (let (arg2)
    (when (and (boundp 'all-functions-to-check-for)
	       (eq all-functions-to-check-for t)
	       (boundp '*functions-defined*)
	       (member (car-safe (setq arg2 (third exp))) '(ticlos:make-reader ticlos:make-writer))
	       (every #'quotep (cdr arg2)))
      (let ((fn (second (second arg2)))
	    (class (second (fourth arg2))))
	(pushnew (list 'ticlos:method fn (if (eq (car-safe fn) 'setf) (list t class) (list class)))
		 *functions-defined* :test #'equal))))
  (cw-eval-args exp))

(DEFUN FIND-THINGS-USED-BY-FILE (path FUNCTION)
  Ï1;; report on random forms that were executed at top-level when the file was loaded.Ï*
  (let* ((pathname (pathname path))
	 (generic-pathname (send pathname :generic-pathname))
	 (forms (send generic-pathname :get :random-forms))
	 (id (or (car (si:get-file-loaded-id generic-pathname nil))
		 generic-pathname))
	 (definitions (send generic-pathname :get :definitions)))
    (cond ((or forms (send pathname :get :macros-expanded))
	   Ï1;; can use the information recorded on the generic pathname plistÏ*
	   (FIND-THINGS-USED-BY-EVALUATED-LIST id `(progn . ,forms) function)
	   (let ((macros nil))
	     (dolist (package-defs definitions)
	       (dolist (def (cdr package-defs))
		 (pushnew (cdr def) macros :test #'eq)))
	     (dolist (x macros)
	       (funcall function id x (if (macro-function x) ':macro ':function))))
	   (dolist (form forms)
	     (when (and (consp form)
			(symbolp (car form))
			(eq (symbol-package (car form)) nil))
	       Ï1;; top-level form compiled into a gensym functionÏ*
	       (find-things-used-by-symbol (car form) function))) )
	  (t  Ï1; will have to read the fileÏ*
	   (let ((compiler:*functions-defined* nil)
		 (si:*loader-eval* #'(lambda (exp)
				       (FIND-THINGS-USED-BY-EVALUATED-LIST id exp function))))
	     (readfile (send pathname :new-pathname :type :lisp) nil t)
	     )))))

(defun FIND-THINGS-USED-BY-INITIALIZATIONS (handler)
  Ï1;; Find references in initialization list forms.Ï*
  (dolist (x si:Initialization-Keywords) Ï1; for each initialization listÏ*
    (let ((var (second x)))
      (when (boundp var)
	(dolist (init (symbol-value var)) Ï1; for each initializationÏ*
	  (FIND-THINGS-USED-BY-EVALUATED-LIST var (si:init-form init) handler)
	  ))))
  (values))

(defun check-for-new-who-calls-entries ()
  Ï1"This is called within the Ï**who-calls-updater-process*Ï1, not within the user process.  This way
the Ï*who-callsÏ1 information is updated asynchronously, without slowing down function definition."Ï*
  (loop (process-wait "Wait for New Caller" #'(lambda () *who-calls-addition-list*))
	(let ((new-caller (without-interrupts 
			    (pop *who-calls-addition-list*))))
	  (multiple-value-bind (ignore error-p)
	      (ignore-errors (find-things-used-by-function
			       (or (and (symbolp new-caller)
					(null (symbol-package new-caller))
					;; gensym name is not helpful, use file name instead.
					(sys:get-source-file-name new-caller 'defun))
				   new-caller)
			       (si:fdefinition-safe new-caller t)
			       #'enter-in-xref-table))
	    (when error-p
	      (tv:notify nil "Who Calls Updater Error:  Problem with ~s.  Function won't be entered in the xref-table."
			 new-caller))
	    ))))

Ï1;; When a function is defined, record the function spec on a list to be processed later.Ï*
(let ((compile-encapsulations-flag t))
  (advise sys:fdefine :after update-who-calls-database nil
    (when (and (car values)			Ï1; definition was done.Ï*
	       (third arglist)			Ï1; not an encapsulationÏ*
	       (not (member (car-safe (first arglist)) '(:location :internal) :test #'eq))
	       (ccase *record-who-calls-info-p*
		 (:never nil)
		 (:update (and *xref-hash-table*
			       (or (member *package* *packages-processed* :test #'eq)
				   (member (function-spec-package (first arglist)) *packages-processed* :test #'eq)
				   (member sys:fdefine-file-pathname *files-processed* :test #'eq))))
		 (:always t)))
      (without-interrupts
	(push (first arglist) *who-calls-addition-list*))
      (when (null *who-calls-updater-process*)
	(start-who-calls-updater))
      )))