;;; -*- Mode:Common-Lisp; Package:SYSTEM; Base:10; Patch-file:T -*-

;;; Reason: Update WHO-CALLS to handle SETF and LOCF functions.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 05/02/89 14:35:29 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Experimental REL6G 6.5, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Experimental CLX 4.0, Experimental X11M 2.1, Experimental CLUE 19.1,
;;;  Experimental RPC 6.0, NFS 3.5, Experimental BUG 11.4, IP 3.45, Experimental DOCUMENTER 618.0,
;;;  Experimental TI-CLOS 17.0,  microcode 424, Band Name: REL6G,Scribe,&c u424 4/20

#!C
; From file WHO-CALLS.LISP#> KERNEL; MR-X:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; WHO-CALLS.#"


;;  5/02/89 DNG - Add support for SETF and LOCF functions.

(defun who-calls (symbol-or-symbols &optional pkg (inheritors t) (inherited t))
  "Find all symbols in package PKG whose values, definitions or properties use SYMBOL.
SYMBOL-OR-SYMBOLS can be a symbol or a list of symbols, each of which is looked for.
PKG defaults to NIL, which means search all packages.
The packages which inherit from PKG are processed also, unless INHERITORS is NIL.
The packages PKG inherits from are processed also, unless INHERITED is NIL.
\(Other packages which merely inherit from the same ones are NOT processed.)
The symbols are printed and a list of them is returned.
The symbol :UNBOUND-FUNCTION is special:  (WHO-CALLS :UNBOUND-FUNCTION)
will find all functions that are used but not currently defined."
  (let ((return-list nil))
    (declare (special return-list))
    (find-callers-of-symbols symbol-or-symbols pkg
			     #'(lambda (caller callee how)
				 (format t "~&~S" caller)
				 (format t (case how
					     (:variable " uses ~S as a variable.")
					     (:function " calls ~S as a function.")
					     (:instruction " uses an instruction for the ~S function.")
					     (:constant " uses ~S as a constant.")
					     (:flavor " uses ~S's flavor definition.")
					     (:unbound-function " calls ~S, an undefined function.")
					     (:macro " calls ~S as a macro.")
					     (setf " calls function (SETF ~S).")
					     (locf " calls function (LOCF ~S).")
					     (nil ", an interpreted function, uses ~S somehow.")
					     (t " uses ~S somehow."))
					 callee)
				 (push caller return-list))
			     inheritors inherited)
    return-list))
))

#!C
; From file WHO-CALLS.LISP#> KERNEL; MR-X:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; WHO-CALLS.#"


;;  5/2/89 DNG - Updated to recognize and scan SETF and LOCF functions.
(defun find-callers-of-symbols-aux (caller symbol function)
  ;; Ignore all symbols which are forwarded to others, to avoid duplication.
  (when (and (/= (%p-data-type-offset caller 2) dtp-one-q-forward)
	     (fboundp caller))
    (find-callers-of-symbols-aux1 caller (symbol-function caller) symbol function))
  (when (/= (%p-data-type-offset caller 3) dtp-one-q-forward)
    ;; Also look for properties
    (loop for (prop value) on (symbol-plist caller) by #'cddr
	  if (= (%data-type value) dtp-function)
	  do (find-callers-of-symbols-aux-fef (list :property caller prop)
					      value symbol function)
	  else if (and (consp value)
		       (consp (car value))
		       (consp (cdr (car value)))
		       (eq caller (second (car value)))
		       (si:validate-function-spec (car value)))
	  do (let ((defn (fdefinition-safe (car value) nil)))
	       (when (and defn (member defn (cdr value) :test #'eq))
		 ;; here for SETF and LOCF functions
		 (find-callers-of-symbols-aux1 (car value)
					       (fdefinition-safe (car value) t)
					       symbol
					       function))))
    ;; Also look for flavor methods
    (let (fl)
      (when (and (setq fl (get caller 'flavor))
		 (arrayp fl))			;Could be T
	(dolist (mte (flavor-method-table fl))
	  (dolist (meth (cdddr mte))
	    (if (meth-definedp meth)
		(find-callers-of-symbols-aux1 (meth-function-spec meth)
					      (meth-definition meth)
					      symbol function))))))
    ;; Also look for initializations
    (when (get caller 'initialization-list)
      ;; It is an initialization list.
      (dolist (init-list-entry (symbol-value caller))
	(find-callers-of-symbols-aux-list caller (init-form init-list-entry) symbol function))))) 


;;;PHD 4/1/87 SPR 4459, make this function more robust, follow things only of DEFN is a function.
;;;DNG 8/5/87 SPR 4575, fix to handle closures.
;;;DNG 4/3/89 - Add handling for methods of generic functions.
;;;DNG 5/2/89 - Fix to not error on generic function names in interpreted code.
(defun find-callers-of-symbols-aux1 (caller defn symbol function)
  ;; Don't be fooled by macros, interpreted or compiled.
  (when (functionp defn t)
    (when (and (consp defn) (eq (car defn) 'macro))
      (setq defn (cdr defn)))
    (typecase defn
      (compiled-function (find-callers-of-symbols-aux-fef caller defn symbol function))
      (list (find-callers-of-symbols-aux-lambda caller defn symbol function))
      (closure
       (when (eql (%data-type defn) dtp-closure)
	 (dolist (sym (closure-variables defn))
	   (when (if (atom symbol)
		     (eq sym symbol)
		   (member sym (the list symbol) :test #'eq))
	     (funcall function caller sym :variable))))
       (find-callers-of-symbols-aux1 caller (closure-function defn) symbol function)))
    ;; If this function is traced, advised, etc.
    ;; then look through the actual definition.
    (when (or (listp defn) (typep defn 'compiled-function))
      (let* ((debug-info  (get-debug-info-struct defn))
	     (inner  (car (get-debug-info-field debug-info 'si:encapsulated-definition))))
	(when inner
	  (find-callers-of-symbols-aux inner symbol function))))
    (locally
      (declare (notinline ticlos:generic-function-p ticlos:generic-function-methods ticlos:method-function))
      (when (and (ticlos:generic-function-p defn)
		 (not (symbolp defn)))
	(dolist (method (ticlos:generic-function-methods defn))
	  (let ((fef (ticlos:method-function method)))
	    (find-callers-of-symbols-aux1 (function-name fef) fef symbol function)))))
    (values)))

(unless (fboundp 'ticlos:generic-function-p)
  (setf (symbol-function 'ticlos:generic-function-p) #'ignore))

;;; 10/13/87 CLM - Fixes problem when given a macro in a list of symbols to search for.
;;;	We were printing the whole list; now it correctly prints just the macro name. [SPR 6648]
;;;  4/25/89 DNG - Add use of :CONSTANTS-OPEN-CODED debug info for SPR 6501.
;;;  5/02/89 DNG - Add handling for calls to SETF and LOCF functions.
(defun find-callers-of-symbols-aux-fef (caller defn symbol function)
  (do ((i %fef-header-length (1+ i))
       (lim (truncate (fef-initial-pc defn) 2))
       tem offset sym)
      ((>= i lim) nil)
    (cond ((= (%p-data-type-offset defn i) dtp-external-value-cell-pointer)
	   (setq tem (%p-contents-as-locative-offset defn i)
		 sym (%find-structure-header tem)
		 offset (%pointer-difference tem sym))
	   (cond ((not (symbolp sym))
		  (when (and (= offset 1)
			     (consp sym)
			     (consp (car sym))
			     (if (atom symbol)
				 (eq (second (car sym)) symbol)
			       (member (second (car sym)) (the list symbol) :test #'eq))
			     (validate-function-spec (car sym)))
		    ;; here for a call to a SETF or LOCF function.
		    (funcall function caller (second (car sym)) (caar sym))))
		 ((= offset 2)			;Function cell reference
		  (if (if (atom symbol)
			  (eq sym symbol)
			  (member sym (the list symbol) :test #'eq))
		      (funcall function caller sym :function)
		    (when (and (if (atom symbol)
				   (eq :unbound-function symbol)
				 (member :unbound-function (the list symbol) :test #'eq))
			       (not (fboundp sym)))
		      (funcall function caller sym :unbound-function))))
		 (t				;Value reference presumably
		  (when (if (atom symbol)
			    (eq sym symbol)
			    (member sym (the list symbol) :test #'eq))
		    (funcall function caller sym :variable)))))
	  ((= (%p-data-type-offset defn i) dtp-self-ref-pointer)
	   (let ((fn (fef-flavor-name defn)))
	     (if fn
		 (multiple-value-bind (sym use)
		     (flavor-decode-self-ref-pointer fn (%p-pointer-offset defn i))
		   (if (or (eq sym symbol)
			   (and (consp symbol)
				(member sym (the list symbol) :test #'eq)))
		       (funcall function caller sym
				(if use :flavor :variable)))))))
	  ((symbolp (setq sym (%p-contents-offset defn i)))
	   (when (if (atom symbol)
		     (eq sym symbol)
		     (member sym (the list symbol) :test #'eq))
	     (funcall function caller sym :constant)))))
  ;; See if the fef uses the symbol as a macro.
  (let ((di  (get-debug-info-struct defn)))
    (dolist (m  (get-debug-info-field di :macros-expanded))
      (let ((macro-symbol (if (consp m) (car m) m)))
	(when (if (atom symbol)
		  (eq symbol
		      macro-symbol)
		  (member macro-symbol
			  (the list symbol)
			  :test #'eq))
	  (funcall function caller macro-symbol :macro))))
    ;; See if the symbol names a DEFCONSTANT that was expanded in the FEF.
    (dolist (m  (get-debug-info-field di :constants-open-coded))
      (let ((constant-symbol (if (consp m) (car m) m)))
	(when (if (atom symbol)
		  (eq symbol constant-symbol)
		  (member constant-symbol (the list symbol) :test #'eq))
	  (funcall function caller constant-symbol :variable)))))
  ;; See if we have a function reference compiled into a misc instruction
  (if (symbolp symbol)
      (let ((misc-function (fef-calls-misc-function defn symbol)))
	(when misc-function
	  (funcall function caller symbol misc-function)))
      (dolist (sym symbol)
	(let ((misc-function (fef-calls-misc-function defn sym)))
	  (when misc-function
	    (funcall function caller sym misc-function)))))
  (let ((tem  (get-debug-info-field (get-debug-info-struct defn) :internal-fef-offsets)))
    (loop for offset in tem
	  for i from 0
	  when (numberp offset)
	  do (find-callers-of-symbols-aux-fef `(:internal ,caller ,i)
					      (%p-contents-offset defn offset)
					      symbol function))))
))