LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031574. :SYSTEM-TYPE :LOGICAL :VERSION 7. :TYPE "LISP" :NAME "WHO-CALLS" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758658444. :AUTHOR "REL3" :LENGTH-IN-BYTES 14165. :LENGTH-IN-BLOCKS 14. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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) 1986,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;;; Facilities for looking through all functions in the world;;; and finding out what they do.;;  2/18/87 DNG - Fix checking for macro-instruction usage.(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.")     (nil ", an interpreted function, uses ~S somehow.")     (t " uses ~S somehow.")) callee) (push caller return-list))     inheritors inherited)    return-list))(deff who-uses 'who-calls)(defun what-files-call (symbol-or-symbols &optional pkg (inheritors t) (inherited t))  "Find all files in package PKG which use SYMBOL.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 files are printed and a list of them is returned.The symbol :UNBOUND-FUNCTION is special:  (WHAT-FILES-CALL :UNBOUND-FUNCTION)will find all functions that are used but not currently defined."  (let ((l nil))    (declare (special l))    (find-callers-of-symbols symbol-or-symbols pkg     #'(lambda (caller ignore ignore) (and (setq caller (get-source-file-name caller 'defun))      (not (member caller (the list l) :test #'eq))      (push caller l)))     inheritors inherited)    l))  ;;;PHD 4/1/87 avoid duplication, do not look in *global-package* which is a duplicate ;;; of (lisp and zlc).(defun find-callers-of-symbols (symbol pkg function &optional (inheritors t) (inherited t))  "This is the main driving function for WHO-CALLS and friends.Looks at all symbols in PKG and USErs (if INHERITORS is T)and the ones it USEs (if INHERITED is T).If PKG is NIL, looks at all packages.Looks at each symbol's function definition and if itrefers to SYMBOL calls FUNCTION with the function name, the symbol used,and the type of use (:VARIABLE, :FUNCTION, :MISC-FUNCTION, :CONSTANT, :UNBOUND-FUNCTION, :FLAVOR, or NIL if used in an unknown way in an interpreted function.)SYMBOL can be a single symbol or a list of symbols.The symbol :UNBOUND-FUNCTION is treated specially."    ;; Sorting first, in order of function definitions, didn't help much when  ;; tried in the previous generation of this function.  (when pkg    (setq pkg (find-package pkg)))  (check-arg symbol     (or (symbolp symbol) (loop for sym in symbol always (symbolp sym)))     "a symbol or a list of symbols")  (if (symbolp symbol)      (setq symbol (add-symbols-optimized-into symbol (list symbol)))      (dolist (sym symbol)(setq symbol (add-symbols-optimized-into sym symbol))))  ;;  Since we can't find everything.  (loop for sym in symbolwhen (get sym 'compiler:post-optimizers)do (format t "~&~S has a COMPILER:POST-OPTIMIZERS property:  some uses may actually use another symbol." sym))  ;; If one of the symbols is :PUTPROP, say, make sure we look for GLOBAL:PUTPROP too.  (let (tem)    (dolist (sym symbol)      (when (and (eq (symbol-package sym)  *keyword-package*) (setq tem (find-symbol sym  *lisp-package* )))(push tem symbol))))  (cond (pkg (if inherited     (do-symbols (s pkg)       (find-callers-of-symbols-aux s symbol function))     (do-local-symbols (s pkg)       (find-callers-of-symbols-aux s symbol function))) (when inheritors   (dolist (p (package-used-by-list pkg))     (do-local-symbols (s p)       (find-callers-of-symbols-aux s symbol function)))))(t (dolist (p (list-all-packages))   (when (neq p *global-package*)     (do-local-symbols (s p)       (find-callers-of-symbols-aux s symbol function))))))  nil) (defun add-symbols-optimized-into (sym list)  (when (symbolp list)    (setq list (list list)))  (dolist (sym1 (get sym 'compiler:optimized-into))    (unless (member sym1 (the list list) :test #'eq)      (setq list (add-symbols-optimized-into sym1 (cons sym1 list)))))  list)(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  when (= (%data-type value) dtp-fef-pointer); To become dtp-function.  do (find-callers-of-symbols-aux-fef (list :property caller prop)      value 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.(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)))    ;; 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)))))) (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))) ((= 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))      (if (if (atom symbol)      (eq symbol  (if (consp m)      (car m)      m))      (member (if (consp m)  (car m)  m)      (the list symbol)      :test #'eq))  (funcall function caller symbol :macro))))  ;; 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))))(eval-when (eval compile load) ; because used in #.(proclaim '(inline op-value))(defun op-value (opcode)  (and opcode       (if (symbolp opcode) (compiler:lap-value opcode) opcode)))(defun main-op-code (name)  (let ((whole (op-value name)))    (and whole  (ldb %%qmi-full-opcode whole)))));;; See if this FEF uses a certain MISC instruction(defun fef-calls-misc-function (fef sym)   (let ((opcodes (compiler:get-opcodes sym)))     (declare (optimize speed))     (when opcodes       (loop with lim-pc = (fef-limit-pc fef)     with mainop-test  = (main-op-code (compiler:opcode-test-op opcodes))     with mainop-push  = (main-op-code (compiler:opcode-push-op opcodes))     with miscop = (compiler:opcode-misc-op opcodes)     with auxop  = (op-value (compiler:opcode-aux-op opcodes))     with immedop = (cdr (assoc sym '((EQ . #.(main-op-code 'compiler:EQ-IMMED))      (= . #.(main-op-code 'compiler:=-IMMED))      (< . #.(main-op-code 'compiler:<-IMMED))      (> . #.(main-op-code 'compiler:>-IMMED))      (+ . #.(main-op-code 'compiler:ADD-IMMED))      (LDB . #.(main-op-code 'compiler:LDB-IMMED))):test #'eq))     for pc from (fef-initial-pc fef) below lim-pc     as instr = (fef-instruction fef pc)     as full-op = (ldb %%qmi-full-opcode instr)     doing (case full-op     ((#.(main-op-code 'compiler:push-misc-group)       #.(main-op-code 'compiler:push-module-group))      (when (and miscop (eql miscop (- instr #.(compiler:lap-value 'compiler:push-misc-group))))(return :instruction)))     ((#.(main-op-code 'compiler:test-misc-group)       #.(main-op-code 'compiler:test-module-group))      (when (and miscop (eql miscop (- instr #.(compiler:lap-value 'compiler:test-misc-group))))(return :instruction)))     (#.(main-op-code 'compiler:aux-group)(when (eql instr auxop)  (return :instruction))(when (<= #o160 instr #o177) ; first half of long branch  (incf pc 1)))     (t (when (or (eql full-op mainop-test)  (eql full-op mainop-push)  (eql full-op immedop))  (return :instruction)  )))))));;; Tree-walk CALLER looking for FUNCTION.  CALLER should be the function name,;;; and DEFN should be its definition.  Avoids listing symbols twice.(defun find-callers-of-symbols-aux-list (caller defn symbol function)  (let ((suppress nil))    (declare (special suppress))    (find-callers-of-symbols-aux-list1 caller defn symbol function)))(defun find-callers-of-symbols-aux-lambda (caller defn symbol function)  (let ((suppress nil))    (declare (special suppress))    (find-callers-of-symbols-aux-list1 caller (lambda-exp-args-and-body defn) symbol function)))(defun find-callers-of-symbols-aux-list1 (caller defn symbol function)  (declare (special suppress))  (loop for l on defnuntil (atom l)finally (if (not (null l))    (find-callers-of-symbols-aux1 caller l symbol function))as carl = (car l)doing (cond ((and (symbolp carl)  (not (member carl (the list suppress) :test #'eq))  (if (atom symbol)      (eq carl symbol)      (member carl (the list symbol) :test #'eq)))     (push carl suppress)     (funcall function caller carl nil))    ((listp carl)     (find-callers-of-symbols-aux-list1 caller carl symbol function))    (t     (find-callers-of-symbols-aux1 caller carl symbol function)))))sions (array-rank object))  (and (= (length dimensions) (array-rank object))     (dotimes (i (array-rank object) t)       (unless (or (eq (nth i dimensions) '*) (= (