;;; -*- 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;Version:
;  9/11/87 DNG - Original version of Ï*unused-in-packageÏ1 .
; 10/06/87 DNG - Original version of Ï*unused-in-fileÏ1 .
; 12/02/87 DNG - Simplified Ï*unused-in-fileÏ1 by using new function Ï*map-definitions-in-fileÏ1 .
; 12/15/87 DNG - Correct use of Ï*function-nameÏ1 in Ï*unused-in-package.
Ï1;Ï*	Ï1-- The following changes are for release 6.  --
;  3/06/89 DNG - Update Ï*unused-in-fileÏ1s to recognize Ï*defclass.

(defun Ï3unused-in-packageÏ* (package)
Ï1  "Tell which things defined in this package have no known references.
Note that this will not find references from other packages unless you have 
first called Ï*BUILD-XREF-TABLEÏ1 for the other packages.  Also, it generally will 
not find references that are in data instead of in program code, although a 
few special cases are checked."Ï*
  (declare (unspecial package))
  (let ((pkg (pkg-find-package package))
	(functions nil)
	(variables nil)
	(flavors nil)
	(types nil))
    (declare (list functions variables flavors types))
    (assure-xref-table-from-package pkg)
    (format *terminal-io* "~&Ï1Collecting symbols from packageÏ* ~A." (package-name pkg))
    (do-local-symbols (symbol pkg)
      (when (and (or (boundp symbol)
		     (get symbol 'special))
		 (null (get-item symbol :variable nil))
		 (null (get-item symbol :constant nil)))
	(push symbol variables))
      (if (get symbol 'si:flavor)
	  (let ((fl (get symbol 'si:flavor)))
	    (unless (or (get-item symbol :constant nil)
			(get-item symbol :flavor nil)
			(si:flavor-depended-on-by fl))
	      (push symbol flavors))
	    (dolist (mte (sys:flavor-method-table fl))
	      (dolist (meth (cdddr mte))
		(when (sys:meth-definedp meth)
		  (let* ((def (sys:meth-definition meth))
			 (method-name (if (symbolp def)
					  (sys:meth-function-spec meth)
					(function-name def))))
		    (assert (eq (car method-name) :method))
		    (when (null (get-item (if (> (length method-name) 3)
					      (fourth method-name)
					    (third method-name))
					  :constant nil))
		      (push method-name functions) )))))
	    )
	(when (si:type-specifier-p symbol)
	  (unless (get-item symbol :constant nil)
	    (push symbol types))))
      (when (and (fboundp symbol)
		 (null (get-item symbol :function nil))
		 (null (get-item symbol :macro nil))
		 (null (get-item symbol :constant nil)))
        (push symbol functions))
      )Ï1 ; endÏ* do-local-symbols
    (format *terminal-io* "~&Ï1Checking symbol properties.Ï*")
    (do-symbols (symbol pkg)
      (loop for (prop value) on (symbol-plist symbol) by #'cddr
	    do (cond ((symbolp value)
		      (when (and (fboundp value)
				 (get-item prop :constant nil))
			(setq functions (delete value functions :test #'eq :count 1))))
		     ((and (functionp value t)
			   (or (eq (symbol-package symbol) pkg)
			       (and (symbolp prop)
				    (eq (symbol-package prop) pkg)))
			   (or (eq prop ':PREVIOUS-DEFINITION)
			       (null (get-item prop :constant nil)))
			   (not (get-item (function-name value) :function nil)))
		      (push `(:property ,symbol ,prop) functions))
		     ((and (consp value)
			   (symbolp prop)
			   (get-item prop :constant nil))
		      (dolist (x value)
			(when (consp x) (setq x (car x)))
			(let (name)
			  (when (and (functionp x t)
				     (eq (function-spec-package
					   (setq name (if (symbolp x) x (function-name x))))
					 pkg))
			    (setq functions (delete name functions :test #'equal :count 1))))) )
		     )))
    (format *terminal-io* "~&Ï1Grouping the symbols by pathnames.Ï*")
    (let ((pathname-alist nil))
      (declare (list pathname-alist))
      (flet ((update-path-alist (item kind &optional alternate-kind)
	         (let* ((pathname (or (si:get-source-file-name item kind)
				      (and alternate-kind
					   (si:get-source-file-name item alternate-kind))))
			(x (assoc pathname pathname-alist :test #'eq)))
		   (when (null x)
		     (push (setq x (cons pathname nil))
			   pathname-alist))
		   (let ((y (assoc kind (cdr x) :test #'eq)))
		     (if (null y)
			 (push (setq y (cons kind (list item)))
			       (cdr x))
		       (push item (cdr y)))))
		 (values))
	     (pathname-lessp (a b)
		 (cond ((null a) nil)
		       ((null b) t)
		       ((stringp b)
			(and (stringp a)
			     (string-lessp a b)))
		       ((stringp a) t)
		       (t (flet ((directory-string (path)
				   (let ((dir (send path :directory)))
				     (if (stringp dir) dir (first (last dir))))))
			    (let ((x (string-compare (directory-string a) (directory-string b))))
			      (cond ((< x 0) t)
				    ((= x 0) (string-lessp (send a :name) (send b :name)))
				    (t nil))))))) )
	(dolist (fspec functions) (update-path-alist fspec 'defun))
	(dolist (symbol variables) (update-path-alist symbol 'defvar))
	(dolist (symbol types) (update-path-alist symbol 'deftype 'defstruct))
	(dolist (symbol flavors) (update-path-alist symbol 'defflavor))
	(format *terminal-io* "~&Ï1Sorting the pathnames.Ï*")
	(setq pathname-alist (sort pathname-alist #'pathname-lessp :key #'car))
	) ; end flet
      (format *terminal-io* "~&Ï1Writing the report.Ï*")
      (let ((*package* pkg))
	(write-attributes)
	(send *formatter* :begin-document "Unused things in package" (package-name pkg))
	(dolist (x pathname-alist)
	  (send *formatter* :new-page)
	  (document-stuff pkg (sort (cdr (assoc 'defun (cdr x) :test #'eq)) #'function-spec-lessp)
			  (sort (cdr (assoc 'defvar (cdr x) :test #'eq)) #'string<)
			  (sort (cdr (assoc 'deftype (cdr x) :test #'eq)) #'string<)
			  (sort (cdr (assoc 'defflavor (cdr x) :test #'eq)) #'string<)
			  nil nil) )
	(send *formatter* :end-document)
      )))
  (values))

(defun Ï3unused-in-fileÏ* (file &optional (verbose t))
Ï1  "Tell which things defined in this file have no known references from outside of the file.
Note that this requires calling Ï*BUILD-XREF-TABLEÏ1 first to look for references."Ï*
  (let ((functions nil)
	(variables nil)
	(flavors nil)
	(types nil))
    (declare (list functions variables flavors types))
    (let ((pathname (send (merge-pathnames file) :generic-pathname)))
      (setq pathname (assure-xref-table-from-file pathname))
      (unless (null pathname)
	(map-definitions-in-file
	  pathname
	  #'(lambda (name kind)
	      (case kind
		( defun (pushnew name functions :test #'equal) )
		( defvar (pushnew name variables :test #'eq) )
		( defflavor (pushnew name flavors :test #'eq) )
		((deftype defstruct ticlos:defclass) (pushnew name types :test #'eq))
		((defsystem))
		( t ;(cerror "Continue." "Unrecognized definition type ~S" kind)
		 nil))
	      (values)))
	))
    (let ((functions-used nil) (functions-not-used nil)
	  (variables-used nil) (variables-not-used nil)
	  (flavors-used nil) (flavors-not-used nil)
	  (types-used nil) (types-not-used nil))
      (declare (list functions-used functions-not-used variables-used variables-not-used
		     flavors-used flavors-not-used types-used types-not-used))
      (declare (ignore types-used))
      (flet ((no-outside-use-p (name kind this-file-defs &optional used-defs)
		 (declare (list this-file-defs) (symbol kind))
		 (let ((item (get-item name kind nil)))
		   (or (null item)
		       (dolist (x (xref-item-callers item) t)
			 (unless (eq x name)
			   (unless (and (if (symbolp x)
					    (member x this-file-defs :test #'eq)
					  (member x this-file-defs :test #'equal))
					(not (member x used-defs :test #'eq)))
			     (return nil))))))))
      (dolist (fn functions)
	(if (and (no-outside-use-p fn :function functions)
		 (no-outside-use-p fn :macro functions)
		 (no-outside-use-p fn :constant functions)
		 (or (atom fn)
		     (case (car fn)
		       (:method (no-outside-use-p (if (> (length fn) 3) (fourth fn) (third fn))
						  :constant functions functions-used))
		       (:property (no-outside-use-p (third fn) :constant functions))
		       (t t))))
	    (push fn functions-not-used)
	  (push fn functions-used))
	;;Ï2(when (eq fn 'name:dump-to-log) (cerror "Continue." "~S found" fn))Ï*
	)
      (dolist (fn functions-used)
	(unless (or functions-not-used variables-not-used)
	  (return))
	(find-things-used-by-function
	  fn (si:fdefinition-safe fn t)
	  #'(lambda (caller callee how)
	      (declare (ignore caller))
	      (when (member how '(:function :macro :constant) :test #'eq)
		(when (member callee functions-not-used :test #'equal)
		Ï2  Ï*;;Ï2(when (eq callee 'name:dump-to-logÏ*)Ï2 (cerror "Continue." "~S found" callee))Ï*
		  (push-end callee functions-used)
		  (setf functions-not-used (delete callee functions-not-used :count 1 :test #'eq)) ))
	      (when (member how '(:variable :constant) :test #'eq)
		(when (member callee variables-not-used :test #'eq)
		  (push callee variables-used)
		  (setf variables-not-used (delete callee variables-not-used :count 1 :test #'eq)) ))
	      ))) ; end of DOLIST on functions-used
      (dolist (flavor-name flavors)
	(if (no-outside-use-p flavor-name :constant functions-not-used)
	    (push flavor-name flavors-not-used)
	  (push flavor-name flavors-used)))
      ) ; end of FLET
    (format *terminal-io* "~&Sorting the definitions.")
    (sortf functions #'function-spec-lessp)
    (sortf variables #'string<)
    (sortf flavors #'string<)
    (sortf types #'string<)
    (format *terminal-io* "~&Ï1Writing the report.Ï*")
    (if verbose
	(progn
	  (write-attributes)
	  (send *formatter* :begin-document "Unused things in file" file)
	  (send *formatter* :new-page)
	  (document-stuff nil functions-not-used variables-not-used types-not-used flavors-not-used nil nil)
	  (send *formatter* :end-document) )
      (flet ((report (title list kind)
	       (format t "~2&~A ~A:" title kind)
	       (if (null list)
		   (format t "  [none]")
		 (dolist (x list)
		   (format t "~&   ~S" x)))))
	(report "Unused" functions-not-used "functions")
	(report "Unused" variables-not-used "variables")
	(when flavors-not-used 
	  (report "Unused" flavors-not-used "flavors"))
	(report "Used" functions-used "functions")
	(report "Used" variables-used "variables")
	))
    (terpri)
    (terpri)
    (nunion functions-not-used variables-not-used)
    )))
