;;; -*- 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 - definitions

Ï1;Version:
;  7/22/87 DNG - Original.
;  8/03/87 DNG - ModifiedÏ*Ï* dump-xref-tableÏ1 to use the largest package as the default package.
;  8/19/87 DNG - Add Ï*si::loop-collect-initÏ1 to the list in Ï*uninteresting-macro-p Ï1.
;  8/25/87 DNG - Update Ï*BUILD-XREF-TABLE-FROM-FILEÏ1 to read file when the 
;Ï*		Ï1needed information is not on the generic pathname plist.
;  9/15/87 DNG - Update Ï*BUILD-XREF-TABLE-FROM-PACKAGEÏ1 to record uses in the 
;Ï*		Ï1microcode support vector.
; 10/06/87 DNG - Fix Ï*BUILD-XREF-TABLE-FROM-FILEÏ1 to not be fooled by a 
;Ï*		:DEFINITIONSÏ1 property that only lists functions that have been patched.
; 10/09/87 DNG - Added Ï*:initializationsÏ1 option to Ï*build-xref-tableÏ1 .
;  1/30/88 DNG - New functions Ï*assure-xref-table-from-packageÏ1 and Ï*assure-xref-table-from-fileÏ1 .
;  2/12/88 DNG - Fix Ï*build-xref-tableÏ1 to handle a list of files.
;  11/11/88 DNG - Fix Ï*build-xref-table-from-fileÏ1 to declare 
;Ï*		compiler:*functions-defined*Ï1 special. [SPR 8179].
;  1/18/89 DNG - Make sure packages Ï*CLOS Ï1and Ï*TICLOSÏ1 exist.  Add 
;Ï*		*record-who-calls-info-p*Ï1 , Ï**who-calls-updater-process*, Ï1etc.
;  1/24/89 DNG - Use Ï*fs:generic-pathname-source-pathnameÏ1 to enable looking at 
;Ï*		Ï1source files whose type is something other than Ï*:LISP.
Ï1;  2/21/89 DNG - Update handling of support vector to look at actual current contents.
;Ï*		Ï1Added restart to Ï*build-xref-table-from-fileÏ1 to enable continuing without loading the file.
;  2/23/89 DNG - Update the Ï*:directory Ï1option of Ï*build-xref-table Ï1to permit 
;;Ï*		Ï1wildcarding just part of the name.  Add wildcard support to Ï*build-xref-table-from-fileÏ1 .

;; If loaded prior to release 6, make sure these packages exist so that references to them can be loaded.Ï*
(unless (find-package "TICLOS")
  (make-package "TICLOS" :use '("TICL" "LISP")))
(unless (find-package "CLOS")
  (make-package "CLOS" :use '("COMMON-LISP")))

(define-modify-macro sortf (lessp-predicate) sort
		     "Sort PLACE")

(defvar *formatter* 'text-formatter Ï1"Document formatting function"Ï*)
		    
(deftype function-spec () '(satisfies si:validate-function-spec))

Ï1;;;Ï*		Ï1Cross-reference hash tableÏ*

(defvar *xref-hash-table* nil Ï1"Hash-table of who-calls data."Ï*)

(DEFSTRUCT (XREF-ITEM (:type list) Ï1; use list for efficiency when dumped to XLD file.Ï*
		      (:copier nil) (:predicate nil))
 ; NAME	Ï1   ; Name of this item (symbol or function-spec)Ï*
  TYPE	  Ï1 ; One of:Ï*  :function :macro :variable :flavor :constant :instance-variable
 ; FILE	   Ï1; Pathname where definedÏ*
  CALLERS   Ï1; List of items that call this oneÏ*
 ; CALLEES   ; Ï1Item names this one calls.Ï*
  )

(defvar *packages-processed* nil
  Ï1"List of packages for which we have data in the xref table."Ï*)
(defvar *files-processed* nil
  Ï1"List of files for which we have data in the xref table."Ï*)

(defvar *record-who-calls-info-p* :update
  Ï1"Controls whether functions are automatically scanned for cross-references when
they are defined.  The value is one of:Ï*
  :always =>Ï1 scan all new function definitions.Ï*
  :never  =>Ï1 don't do any automatic scanning.Ï*
  :update =>Ï1 scan only definitions in files or packages scanned previously."Ï*)

(defvar *who-calls-addition-list* nil
  Ï1"List of function specs that need to be added to the who-calls database."Ï*)

(defun erase-xref-table ()
  (setq *who-calls-addition-list* nil)
Ï1   (Ï*stop-who-calls-updaterÏ1)Ï*
  (let ((table *xref-hash-table*))
    (unless (null table)
      (setq *packages-processed* nil
	    *files-processed* nil)
      (clrhash table)))
  (values))

(defun get-item (name type create-p)
  Ï1"Lookup an Ï*XREF-ITEMÏ1 in the hash table."Ï*
  (when (null *xref-hash-table*)
    (setf *xref-hash-table*
	  (make-hash-table :test #'equal :size 2000 :rehash-size 2.0s0)))
  (let ((hash-entry (gethash name *xref-hash-table*)))
    (cond ((null hash-entry)
	   (and create-p
		(setf (gethash name *xref-hash-table*)
		      (make-xref-item :type type))))
	  ((and (consp hash-entry)
		(consp (car hash-entry)))
	   (dolist (x hash-entry)
	     (when (eq type (xref-item-type x))
	       (return-from get-item x)))
	   (and create-p
		(let ((new (make-xref-item :type type)))
		  (setf (cdr hash-entry)
			(cons new (cdr hash-entry)))
		  new)))
	  (t (if (eq (xref-item-type hash-entry) type)
		 hash-entry
	       (and create-p
		    (let ((new (make-xref-item :type type)))
		      (setf (gethash name *xref-hash-table*)
			    (cons new (list hash-entry)))
		      new))))
	  )))

(defun any-item-p (name) Ï1; is there any information recorded about this name?Ï*
  (and *xref-hash-table*
       (gethash name *xref-hash-table*)
       t))

(defun map-items (function) Ï1; callÏ* functionÏ1 on eachÏ* xref-itemÏ1 in the tableÏ*
  (unless (null *xref-hash-table*)
    (maphash #'(lambda (key value)
		 (if (and (consp value) (consp (car value)))
		     (dolist (x value)
		       (funcall function key x))
		   (funcall function key value)))
	     *xref-hash-table*)
    (values)))

(defun Ï3dump-xref-tableÏ* (file)
  Ï1"Write the cross-reference table to an object file which can be loaded later to restore the data."Ï*
  (let* ((package-names (mapcar #'package-name *packages-processed*))
	 (forms `((setq *xref-hash-table* ',*xref-hash-table*)
		  (setq *packages-processed* (mapcar #'find-package ',package-names))
		  (setq *files-processed* ',*files-processed*))))
    (when package-names
      (push `(format t "~&Loading cross-reference table for packages: ~A" ',package-names)
	    forms))
    (SYS:INHIBIT-GC-FLIPS ; work-around for SPR 5073
      (dump-forms-to-file file forms
			  `(:mode #.(lisp-mode)
			    :package ,(let ((max 0)
					    (largest *user-package*))
					(dolist (pack *packages-processed*)
					  (let ((size (si:PACK-NUMBER-OF-SYMBOLS pack)))
					    (when (> size max)
					      (setq max size largest pack))))
					(package-name largest)))
			  ))))

(defvar *who-calls-updater-process* nil
  Ï1"The process in which updates to the who-calls table are made for newly-defined functions."Ï*)

(defun stop-who-calls-updater ()
  (unless (null *who-calls-updater-process*)
    (send *who-calls-updater-process* :kill)
    (setq *who-calls-updater-process* nil)
    t))

(DEFUN start-who-calls-updater ()
  Ï1"Starts the who calls updater process and bashes any existing who calls updater processes."Ï*
  Ï1(Ï*stop-who-calls-updaterÏ1)Ï*
  (SETQ *who-calls-updater-process*
	(PROCESS-RUN-FUNCTION `(:name "Who Calls Updater"
				      :restart-after-reset t
				      Ï1;; Lower priority than background listener, but higher than mail daemon.Ï*
				      :priority -4
				      :restart-after-boot t)
			      #'check-for-new-who-calls-entries)))

(add-initialization "Discard cross-reference table"
		    '(progn (erase-xref-table)
			    (setq *xref-hash-table* nil))
		    :full-gc)



Ï1;;;   building the data baseÏ*

(defun Ï3build-xref-tableÏ* (&key package file directory system initializations)
  Ï2"Build cross-reference table for Ï3DOCUMENT-FUNCTIONÏ* and Ï3DOCUMENT-VARIABLEÏ* to use 
to tell who calls something.  With no arguments, scans all packages that have not
already been scanned.  [Warning: this takes more than an hour on an Explorer I.]
The optional arguments may be used to specify what to scan:
  Ï3:PACKAGEÏ* - A package name or list of package names to be scanned.
  Ï3:FILEÏ* - A pathname or list of pathnames; scan functions defined there.  The Ï*
	Ï2file must have already been loaded, since this uses information from theÏ*
	Ï2generic pathname plist instead of actually reading the file.
  Ï3:DIRECTORYÏ* - Scan functions defined in files loaded from this directory.
  Ï3:SYSTEMÏ* - Scan all files in this system or list of systems.Ï*
  Ï3:INITIALIZATIONSÏ* Ï2- When true, scan initialization lists."Ï*
  (declare (unspecial package))
  Ï1;; check systems first because make-system may query the userÏ*
  (cond ((null system))
	((atom system) (build-xref-table-from-system system))
	((consp system)
	 (dolist (x system)
	   (build-xref-table-from-system x))))
  (cond ((null file))
	((atom file) (build-xref-table-from-file file nil t))
	((consp file)
	 (dolist (f file)
	   (build-xref-table-from-file f nil t)))
	)
  (cond ((null package))
	((atom package) (build-xref-table-from-package package t))
	((consp package)
	 (dolist (pkg package)
	   (build-xref-table-from-package pkg t)))
	)
  (when directory
    (let* ((path (pathname directory))
	   (dir-path (send path :new-pathname
			   :name (or (send path :name) :wild)
			   :type (or (send path :type) :lisp)
			   :version :newest))
	   (files (directory dir-path))
	   (some nil))
      (dolist (f files)
	(when (build-xref-table-from-file f nil t t)
	  (setq some t)))
      (unless some (format t "~&  No loaded files found in ~A." dir-path))))
  (unless (or package file directory system initializations)
    (dolist (pkg (list-all-packages))
      (unless (member pkg *packages-processed* :test #'eq)
	(build-xref-table-from-package pkg t) )))
  (when initializations
    (format t "~&  Scanning initialization lists.")
    (find-things-used-by-initializations #'enter-in-xref-table))
  (values))

(defun BUILD-XREF-TABLE-FROM-PACKAGE (package &optional verbose)
  (declare (unspecial package))
  (let ((pkg (pkg-find-package package)))
    (when verbose
      (format t "~&  Scanning symbols in package ~A" (package-name pkg)))
    (do-local-symbols (symbol pkg)
      (find-things-used-by-symbol symbol #'enter-in-xref-table t))
    #+Explorer
    (when (or (eq pkg *system-package*)
	      (eq pkg sys:pkg-compiler-package))
      (dotimes (i (length #'si:support-entry-vector))
	(let ((e (aref #'si:support-entry-vector i)))
	  (unless (null e)
	    Ï1;; The microcode calls out to this function.Ï*
	    (enter-in-xref-table 'si:support-entry-vector e :constant)))))
    (pushnew pkg *packages-processed* :test #'eq)
    pkg))

(defun assure-xref-table-from-package (pkg)
  (unless (member pkg *packages-processed* :test #'eq)
    (format *terminal-io* "~&Building cross-reference table for package ~A."
	    (package-name pkg))
    (build-xref-table-from-package pkg)))

(defun BUILD-XREF-TABLE-FROM-FILE (file &optional package verbose only-if-loaded-p dont-redo)
  (declare (unspecial package))
  (catch-error-restart (error "Give up looking at file ~A" file)
    (let* ((pkg (and package (pkg-find-package package)))
	   (pathname (send (pathname file) :generic-pathname)))
      (when (send pathname :wild-p)
	(let ((files (directory (send pathname :new-pathname :version :newest 
				      :canonical-type (si:local-binary-file-type)))))
	  (unless (null files)
	    (return-from build-xref-table-from-file
	      (loop for f in files
		    collect (build-xref-table-from-file (send pathname :back-translated-pathname f)
							package verbose 
							only-if-loaded-p dont-redo))))))
      (unless (or (send pathname :get :file-id-package-alist)
		  (send (setq pathname (send pathname :back-translated-pathname pathname))
			:get :file-id-package-alist))
	(when only-if-loaded-p (return-from build-xref-table-from-file nil))
	(catch-error-restart (error "Proceed as though it were loaded.")Ï1 ; may have been compiled in a bufferÏ*
	  (cerror "Load the file and continue."
		  "File ~A is not loaded." pathname)
	  (load (send pathname :new-pathname :type nil :version nil)
		:package pkg :verbose t)))
      (when (and dont-redo
		 (member pathname *files-processed* :test #'eq))
	(return-from build-xref-table-from-file pathname))
      (when verbose
	(format t "~&  Scanning definitions in file ~A" pathname))
      (let ((forms (send pathname :get :random-forms))
	    (definitions (send pathname :get :definitions)))
	(if (or forms (send pathname :get :macros-expanded))
 	    (progn Ï1; can use the information recorded on the generic pathname plistÏ*
	      (FIND-THINGS-USED-BY-EVALUATED-LIST pathname `(progn . ,forms) #'enter-in-xref-table)
	      (dolist (def (cdr (if pkg
				    (assoc pkg definitions :test #'eq)
				  (car definitions))))
		(let ((name (car def)))
		  (unless (assoc name compiler:fasd-markers-alist :test #'eq)	Ï1; to avoid trouble in Ï*dump-xref-table
		    (case (cdr def)
		      ( defun (find-things-used-by-function name (si:fdefinition-safe name t)
							    #'enter-in-xref-table) )
		      ( defvar )
		      ( sys:encapsulation
		       (find-things-used-by-function name (si:fdefinition-safe name nil)
						     #'enter-in-xref-table) )
		      ( t (when (symbolp name)
			    (find-things-used-by-symbol name #'enter-in-xref-table t))) ))))
	      (dolist (form forms)
		(when (and (consp form)
			   (symbolp (car form))
			   (eq (symbol-package (car form)) nil)
			   (fboundp (car form)))
		  Ï1;; top-level form compiled into a gensym functionÏ*
		  (find-things-used-by-function (or (si:function-parent (car form)) pathname)
						(symbol-function (car form))
						#'enter-in-xref-table))) )
	  Ï1; else will have to read the fileÏ*
	  (let ((compiler:*functions-defined* nil))
	Ï1     Ï*(declare (special compiler:*functions-defined*))
	    (let ((si:*loader-eval*
		    #'(lambda (exp)
			(FIND-THINGS-USED-BY-EVALUATED-LIST pathname exp #'enter-in-xref-table))))
	      (readfile (source-pathname pathname) nil t))
	    (dolist (name compiler:*functions-defined*)
	      (find-things-used-by-function name (si:fdefinition-safe name t)
					    #'enter-in-xref-table))
	    ))
	(pushnew pathname *files-processed* :test #'eq)
	pathname
	))))

(defun source-pathname (generic-pathname)
  (if (fboundp 'fs:generic-pathname-source-pathname)
      (fs:generic-pathname-source-pathname generic-pathname)
    (send generic-pathname :new-pathname :type :lisp
	  :version :newest) Ï1; Ï*IPÏ1 server on VAX-VMS can't handle Ï*:unspecific Ï1version.Ï*
    ))

(defun assure-xref-table-from-file (pathname)
  ;; returns pathname, or nil if unable to process the file.
  (if (member pathname *files-processed* :test #'eq)
      pathname
    (progn (format *terminal-io* "~&Building cross-reference table for file ~A." pathname)
	   (build-xref-table-from-file pathname))))

(defun enter-in-xref-table (caller callee how)
  (unless (or (and (eq how ':macro)
		   (uninteresting-macro-p callee))
	      (and (eq how ':constant)
		   (not (symbolp callee))))
    (let ((node (get-item callee how t)))
      (pushnew caller (xref-item-callers node) :test #'equal))))

(defun uninteresting-macro-p (name)
  Ï1;; Is this a macro that is used so often that it is not worth remembering who uses it?Ï*
  (member name '(BYTE CASE CONSP DOLIST DOTIMES FIRST INCF PROG PUSH SECOND SETF
		 THIRD UNLESS WHEN NEQ
		 SI::LOOP-COLLECT-INIT
		 SI::XR-BQ-CONS SI::XR-BQ-LIST SI::XR-BQ-LIST* ) :test #'eq))
