;;; -*- 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)Ï1 Ï*1989 Texas Instruments Incorporated. All rights reserved.


Ï1;;;Ï*	Ï2Cross-reference utility.

Ï1;Version:
;  1/30/88 DNG - Original.
;  2/08/88 DNG - Fix  to not scan files more than once.
;  1/16/89 DNG - Update to handle CLOS classes and slots.Ï*Ï*

(defun Ï3cross-referenceÏ* (&key package file system output-file line-length)
Ï1  "Write a brief cross-reference listing -- for each symbol that names a function,
variable, or type, show the name of the file in which it is defined, and the
names of functions or methods that reference it.  The following keyword
arguments specify which definitions are to be included; each can be either a 
single item or a list.
  Ï*:PACKAGEÏ1 - A package or package name -- include local symbols of the package.
  Ï*:FILE	Ï1   - A pathname or file name string -- include things defined there.
  Ï*:SYSTEMÏ1  - A symbol or string naming a system -- include things defined there.
If more than one of these is specified, the union of the sets is used.  If 
none are specified, then whatever definitions are already in the 
cross-reference table are used.  Two more optional keywords control the output:
  Ï*:OUTPUT-FILEÏ1 - Write the report to this file, else to Ï**STANDARD-OUTPUT*Ï1.
  Ï*:LINE-LENGTHÏ1 - Maximum number of characters per line of output."Ï*
  (declare (unspecial package))
  (let* ((symbols '())
	 (keywords '())
	 (others '())
	 (pathnames '())
	 (files '())
	 (fspecs '())
	 (packages (mapcar #'pkg-find-package
			  (if (listp package) package (list package))))
	 (*package* (if (= (length packages) 1) (first packages) *package*)))
    (declare (list symbols keywords others pathnames packages fspecs))
    (when output-file
      (return-from cross-reference
	(with-open-file (*standard-output* (text-pathname output-file) :direction :output)
	  (format t "   -*- Mode: Text; Package: ~A; Base: ~D -*- "
		  (package-name *package*) *print-base*)
	  (let (kind name)
	    (cond (system (setq kind "system" name system))
		  (file (setq kind "file" name file))
		  (package (setq kind "package" name package)))
	    (if kind
		(format t "~2&      Cross-reference for ~A ~A ~60T~\\datime\\~%"
			kind name)
	      (format t "~2&      Cross-reference listing~60T~\\datime\\~%")))
	  (cross-reference :package packages :file file :system system :line-length line-length)
	  (truename *standard-output*))))

    Ï1;; Scan filesÏ*

    (setq files (if (listp file) file (list file)))
    (dolist (sys (if (listp system) system (list system)))
      (setq files (union (system-files system) files)))
    (dolist (file files)
      (let ((pathname (send (merge-pathnames file) :generic-pathname)))
	(setq pathname (assure-xref-table-from-file pathname))
	(unless (or (null pathname)
		    (member pathname pathnames :test #'eq))
	  (push pathname pathnames)
	  (map-definitions-in-file
	    pathname
	    #'(lambda (name kind)
		(declare (ignore kind))
		(if (symbolp name)
		    (pushnew name symbols :test #'eq)
		  (pushnew name fspecs :test #'equal))
		(values))
	    ))))

    Ï1;; Scan packagesÏ*

    (mapc #'assure-xref-table-from-package packages)
    (dolist (pkg packages)
      (format *terminal-io* "~&Collecting symbols from package ~A."
	      (package-name pkg))
      (do-local-symbols (symbol pkg)
	(when (or (boundp symbol)
		  (fboundp symbol)
		  (get symbol 'special)
		  (si:type-specifier-p symbol)
		  (gethash symbol *xref-hash-table*))
	  (pushnew symbol symbols :test #'eq))
	)) Ï1; end of dolist pkgÏ*

    Ï1;; Scan xref tableÏ*
    
    (flet ((interesting-reference-p (s)
	      (or (member (function-spec-package s)
			  packages :test #'eq)
		  (member s (typecase s
			      (symbol symbols)
			      (cons fspecs)
			      (pathname pathnames)
			      (t '())) :test #'eq)) ))
      (if (or symbols fspecs pathnames packages)
	  (progn
	    (format *terminal-io* "~&Collecting keywords.")
	    (map-items #'(lambda (name xitem)
			   (when (and (eq (xref-item-type xitem) :constant)
				      (not (and (symbolp name) (null (symbol-package name))))
				      (or (keywordp name)
					  (not (member name symbols :test #'eq)))
				      (some #'interesting-reference-p
					    (xref-item-callers xitem)))
			     (if (keywordp name)
				 (push name keywords)
			       (push name others))
			     ))))
	(progn
	  (format *terminal-io* "~&Scanning xref table.")
	  (map-items #'(lambda (name xitem)
			 (declare (ignore xitem))
			 (when (symbolp name)
			   (if (keywordp name)
			       (push name keywords)
			     (pushnew name symbols :test #'eq))
			   )))))

    Ï1;; Write reportÏ*

    (format *terminal-io* "~&Sorting the symbols.")
    (sortf symbols #'string-lessp)
    (sortf keywords #'string-lessp)
    (sortf others #'string-lessp)
    (format *terminal-io* "~&Writing the report.")
    (let* ((output-width (or line-length
			     (line-length *standard-output*)))
	   (line (make-array (+ output-width 10) :element-type 'string-char
			     :initial-element #\space :fill-pointer 0)))
      (declare (string line))
      (labels ((tab-to (column)
		  (let ((current (fill-pointer line)))
		    (unless (< current column)
		      (end-line)
		      (setq current 0))
		    (dotimes (i (- column current))
		      (vector-push #\space line))
		    (values)))
	       (end-line ()
		  (when (> (fill-pointer line) 0)
		    (write-string line)
		    (terpri)
		    (setf (fill-pointer line) 0))
		  (values))
	       (report (name kind item pathname &optional predicate)
		 (format line "~S" name)
		 (tab-to 30)
		 (format line "~A" kind)
		 (tab-to 40)
		 (when (pathnamep pathname)
		   (format line "~A" (send pathname :name)))
		 (unless (null item)
		   (format line "~54T")
		   (dolist (caller (sortf (xref-item-callers item) #'function-spec-lessp))
		     (when (or (null predicate)
			       (funcall predicate caller))
		       (if (typep caller 'pathname)
			   (setq caller (send caller :short-string-for-printing))
			 (loop while (and (consp caller)
					  (eq (first caller) ':internal)
					  (numberp (third caller)))
			       do (setq caller (second caller))))
		       (if (> (+ (fill-pointer line) 2 (print-length caller t))
			      output-width)
			   (tab-to (min 32 (truncate output-width 2)))
			 (format line "  "))
		       (format line "~S" caller))))
		 (end-line)
		 (values))
	       )
	(format t "~2% name ~30T kind~40T file~60Treferenced by
--------~30T--------~40T--------~54T------------------------~%")
      (dolist (symbol symbols)
	(let ((item (get-item symbol :variable nil)))
	  (when (or item
		    (boundp symbol)
		    (get symbol 'special))
	    (report symbol (if (constantp symbol) "constant" "variable")
		    item (si:get-source-file-name symbol 'defvar))))
	(let ((item (get-item symbol :instance-variable nil)))
	  (when item
	    (report symbol "inst var" item
		    (let ((flavor nil))
		      (dolist (caller (xref-item-callers item))
			(let ((method-flavor (function-flavor caller)))
			  (cond ((null method-flavor))
				((null flavor)
				 (setq flavor method-flavor))
				((flavor-match-p method-flavor flavor))
				((flavor-match-p flavor method-flavor)
				 (setq flavor method-flavor))
				((eq (si:get-source-file-name flavor 'defflavor)
				     (si:get-source-file-name method-flavor 'defflavor)))
				(t (setq flavor nil)
				   (return)))))
		      (unless (null flavor)
			(si:get-source-file-name flavor 'defflavor)))
		    )))
	(let ((item (get-item symbol :slot nil)))
	  (when item
	    (report symbol "slot" item
		    (slot-source-file symbol (xref-item-callers item)))))
	(if (si:type-specifier-p symbol)
	    (report symbol (cond ((get symbol 'si:flavor) "flavor")
				 ((get symbol 'si::defstruct-description) "struct")
				Ï1  Ï*((call-if-defined "CLOS" "FIND-CLASS" symbol nil) "class")
				 (t "type"))
		    (get-item symbol :constant nil)
		    (or (si:get-source-file-name symbol 'defflavor)
			(si:get-source-file-name symbol 'defstruct)
			(si:get-source-file-name symbol 'deftype)
			(si:get-source-file-name symbol (find-symbol "DEFCLASS" "CLOS"))
			(si:get-source-file-name `(:property ,symbol si::type-expander))
			(si:get-source-file-name `(:property ,symbol si::type-optimizer))
			(si:get-source-file-name `(:property ,symbol si::type-predicate))))
	  (let ((item (get-item symbol :constant nil)))
	    (when item
	      (report symbol "symbol" item nil))))
	(let ((item (get-item symbol :function nil)))
	  (when (or item (and (fboundp symbol)
			      (not (eq (car-safe (symbol-function symbol)) 'macro))
			      (not (get-item symbol :macro nil))))
	    (report symbol "function" item (si:get-source-file-name symbol 'defun))))
	(let ((item (get-item symbol :macro nil)))
	  (when (or item (and (fboundp symbol)
			      (eq (car-safe (symbol-function symbol)) 'macro)))
	    (report symbol (if (get symbol 'compiler:integrable) Ï1; fromÏ* scheme:define-integrable
			       "integr" "macro")
		    item (si:get-source-file-name symbol 'defun))))
	)Ï1 ; end of dolist on symbolsÏ*
      (flet ((report-keywords (list)
	       (unless (null list)
		 (terpri)
		 (dolist (symbol list)
		   (let ((item (get-item symbol :constant nil)))
		     (when item
		       (report symbol "symbol" item nil #'interesting-reference-p) ))))
	       (values)))
	(report-keywords keywords)
	;;(report-keywords others)
	)
      ))))
  (values))

  
(defun slot-source-file (symbol callers)
  (let ((class nil)
	(dc (find-symbol "DEFCLASS" "CLOS")))
    (block search
      (dolist (caller callers)
	(when (and (consp caller)
		   (string-equal (first caller) "METHOD"))
	  (dolist (class-name (car-safe (last caller)))
	    (let ((method-class (call-if-defined "TICLOS" "CLASS-NAMED" class-name)))
	      (unless (null method-class)
		(dolist (class-object (if (call-if-defined "CLOS" "CLASS-FINALIZED-P" method-class)
					  (call-if-defined "CLOS" "CLASS-PRECEDENCE-LIST" method-class)
					(list method-class)))
		  (cond ((not (member symbol (call-if-defined "CLOS" "CLASS-DIRECT-SLOTS" class-object)
				      :test #'eq
				      :key (find-symbol "SLOT-DEFINITION-NAME" "CLOS"))))
			((null class)
			 (setq class (call-if-defined "CLOS" "CLASS-NAME" class-object)))
			((eq (si:get-source-file-name class dc)
			     (si:get-source-file-name class-name dc)))
			(t (setq class nil)
			   (return-from search))))))))))
    (unless (null class)
      (si:get-source-file-name class dc))))
