;;; -*- 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;;;Ï*	Ï2Calls-Who, Show-Call-Tree, Show-Forest, and Inverse-Tree

Ï1;Version:
;  7/22/87 DNG - Original.
;  7/28/87 DNG
; 11/24/87 DNG - Added new function Ï*Ï*inverse-treeÏ1 .
; 12/02/87 DNG - New function Ï*show-forestÏ1 .
; 12/11/87 DNG - Include Ï*external-symbol-pÏ1 here instead of using 
;Ï*		compiler:external-symbol-pÏ1 since the compiler may not always be present.
; 12/15/87 DNG - Fix Ï*inverse-treeÏ1 for argument which is a symbol whose 
;Ï*		Ï1function definition has a different name.
;  1/30/88 DNG - Fix Ï*line-lengthÏ1 to use Ï*:inside-widthÏ1 instead of Ï*:widthÏ1.
;  2/08/88 DNG - Fix Ï*file-treeÏ1 to not scan files more than once.
;  2/16/88 DNG - Modify Ï*line-lengthÏ1 to use Ï*:char-widthÏ1 message since release 4 
;Ï*		Ï1cold-load-stream understands that but not Ï*:current-font.
Ï1;  2/22/88 DNG - Modify to not use non-ASCII characters in the output. Ï* Ï1(The Ï*
;		Ï1microExplorer can't handle them.)
;Ï*	Ï1-- The following changes are for release 6.  --
; 12/23/88 DNG - Improve handling of methods in Ï*inverse-treeÏ1 .
;  2/22/89 DNG - Update Ï*calls-who Ï1to report CLOS slots references.Ï*

(defun Ï3calls-whoÏ* (function &key package filter)
Ï2  "Inverse of WHO-CALLS:  given a function, tell who it references.
The argument may be a symbol, function, function-spec, Lisp form, or pathname.
The optional keyword arguments are:
  :PACKAGE - show only references to things in this package.
  :FILTER  - a predicate to be called on each reference to decide whether to include it."Ï*
  (declare (unspecial package))
  (when package (setq package (pkg-find-package package nil)))
  (let ((*print-level* 2) (*print-length* 6)
	(name #\?)
	(refs nil))
    (labels ((report ()
		(unless (null refs)
		  (format t "~&~S uses" name)
		  (when package
		    (format t " in package ~A" (package-name package)))
		  (let ((*package* (or package *package*)))
		    (dolist (kind '( :function :macro :variable :flavor :constant 
				    :instance-variable :slot))
		      (let ((temp (assoc kind refs :test #'eq)))
			(unless (null temp)
			  (let ((*print-case* :downcase))
			    (format t "~&  ~As:  " (car temp)))
			  (dolist (x (sort (cdr temp) #'FUNCTION-SPEC-LESSP))
			    (format t "~&      ~S" x))
			  ))))
		  (setq refs nil)
		  (setq name #\?))
		(values))
	     (package-filter (object)
		(typecase object
		  (symbol (eq (symbol-package object) package))
		  (cons (some #'package-filter (the list (cdr object))))
		  (t t)))
	     (collector (caller callee how)
		(when (and (or (null package) (package-filter callee))
			   (or (null filter) (funcall filter callee)))
		  (unless (equal caller name)
		    (report)
		    (setq name caller))
		  (let ((temp (assoc how refs :test #'eq)))
		    (if (null temp)
			(push (cons how (cons callee nil)) refs)
		      (pushnew callee (cdr temp) :test #'equal))))
		(values)
		))
      (FIND-THINGS-USED-BY-OBJECT function #'collector)
      (report)))
  (values))

(defun primitive-calls-who (function) ; old version
Ï1  "Inverse of WHO-CALLS:  given a function, tell who it references."Ï*
  (let ((*print-level* 2) (*print-length* 6)
	(name #\?))
    (flet ((reporter (caller callee how)
	       (unless (equal caller name)
		 (format t "~&~S uses" caller)
		 (setq name caller))
	       (format t "~&    ~S as a ~A." callee how)))
      (FIND-THINGS-USED-BY-OBJECT function #'reporter)))
  (values))

(defun Ï3show-call-treeÏ* (root-function &key package (filter #'non-trivial-function-p) (depth 50)
			 return-names Ï1; t => return list of names displayedÏ*
			 (previous nil) Ï1; things already shownÏ*
			 include-inlines Ï1; show functions expanded inline?Ï*
			 )
  Ï2"Display function calling tree beginning with the indicated function as the root.
The argument may be a function or function spec.  This does not show use of
macros, but rather, the functions called by the macro expansion.
The optional keyword arguments are:
  Ï3:PACKAGE Ï*- show subtree only of functions in this package.
  Ï3:FILTERÏ*  - a predicate to be called on each reference to decide whether to
             include it.Ï*  Ï2Defaults to showing functions of non-trivial size.
  Ï3:DEPTHÏ* - number of levels of the tree to show.
The following special characters are used in the output:Ï*
 <- Ï2indicates a recursive call.Ï*
  ^ Ï2means that the sub-tree has already been shown above.Ï*
  v Ï2means that the sub-tree will be shown separately below.Ï*
 .. Ï2means the subtree is not shown because of Ï3:PACKAGEÏ* or Ï3:DEPTH Ï*limitations.Ï*
  ' Ï2preceding a name means the symbol is referenced as a constant, which may or 
    may not be a use of the function that it names.Ï*
... Ï2indicates that one or more names have been omitted because they were too
    long to fit on the line."Ï*
  (declare (arglist root-function &key :package (:filter #'non-trivial-function-p) (:depth 50)))
  (declare (unspecial package))
  (check-type root-function function-spec)
  (when package (setq package (pkg-find-package package nil)))
  (let* ((omission nil)
	 (line-length (line-length *standard-output* ))
	 (deferred nil) ; sub-trees broken off to be displayed separately below
	 (leader (make-string (min line-length (* depth 2)) :initial-element #\space))
	 )
  (labels ((fct-name (f)
	     (if (symbolp f) f (function-name f)))
	   (package-filter (object)
	     (or (null package)
		 (typecase object
		   ( symbol (eq (symbol-package object) package))
		   ( cons (some #'package-filter (the list (cdr object))))
		   ( t t))))
	   (show-tree (name defn indent callers levels &optional quoteit)
	     (format t "~&")
	     (if (> (+ indent (print-length name t)) line-length)
		 (unless omission
		   (write-string leader *standard-output* :end indent)
		   (format t "...")
		   (setq omission t))
	       (progn
		 (when (> indent 0)
		   (write-string leader *standard-output* :end (- indent 2))
		   (write-string "+-"))
		 (when quoteit (write-char #\'))
		 (format t "~S" name)
		 (setq omission nil)
		 (cond ((null defn)
			(format t " [undefined]"))
		       ((member name callers :test #'eq)
			(format t " <-"))
		       ((let ((x (assoc name deferred :test #'eq)))
			  (when x
			    (setf (third x) (max (third x) levels))
			    (format t " v")
			    t)))
		       (t (let ((calls nil)
				(quoted nil))
			    (declare (list calls quoted))
			    (flet ((collector (caller callee how)
			            (declare (ignore caller))
				    (when (and (or (eq how ':function)
						   (and (or (eq how ':constant)
							    (and (eq how ':macro)
								 include-inlines))
							(symbolp callee)
							(fboundp callee)
							(neq callee name)
							(package-filter callee)
							(functionp callee nil)))
					       (si:validate-function-spec callee)
					       (funcall filter callee) )
				      (if (eq how ':constant)
					  (unless (member callee calls :test #'eq)
					    (push callee calls)
					    (push callee quoted))
					(if (member callee calls :test #'eq)
					    (when quoted
					      (setq quoted (delete callee quoted :test #'eq :count 1)))
					  (push callee calls))))
				    (values)))
			      (find-things-used-by-function name defn #'collector)
			      (cond ((member name previous :test #'eq)
				     (unless (null calls) (format t " ^")))
				    ((or (and package (not (package-filter name)) callers)
					 (<= levels 0)
					 (> (+ indent 30) line-length))
				     (unless (null calls) (format t " ..")))
				    ((and (> indent 0)
					  (> (length calls) 10)
					  (let ((xr (get-item name :function nil)))
					    (or (and xr (> (length (xref-item-callers xr)) 2))
						(external-symbol-p name)
						(> (* indent 2) line-length))))
				     (unless (null calls)
				       (format t " v")
				       (push-end (list name (nreverse calls) levels quoted)
						 deferred)))
				    (t (push name previous)
				       (setq calls (nreverse calls))	Ï1; put in order of first useÏ*
				       (setf (char leader indent)
					     (char "| : !" (mod indent 6)))
				       (do ((funs calls (cdr funs)))
					   ((null funs))
					 (when (atom (cdr funs))
					   (setf (char leader indent) #\space))
					 (show-tree (fct-name (car funs))
						    (function-definition (car funs))
						    (+ indent 2)
						    (cons name callers)
						    (- levels 1)
						    (member (car funs) quoted :test #'eq)) )) )))))))
	     (values)) )
    (format t "~2&")
    (show-tree (fct-name root-function)
	       (function-definition root-function)
	       0 nil depth)
    (loop (when (null deferred) (return))
      (destructuring-bind (name calls levels quoted) (pop deferred)
	(unless (member name previous :test #'eq)
	  (push name previous)
	  (format t "~2&~S" name)
	  (setf (char leader 0) #\|)
	  (do ((callers (list name))
	       (funs calls (cdr funs)))
	      ((null funs))
	    (when (atom (cdr funs))
	      (setf (char leader 0) #\space))
	    (show-tree (fct-name (car funs))
		       (function-definition (car funs))
		       2 callers levels
		       (member (car funs) quoted :test #'eq))))))
    (format t "~%") )
  (if return-names previous (values))))

(defun function-definition (function)
  (cond ((si:validate-function-spec function)
	 (si:fdefinition-safe function t))
	((functionp function t)
	 function)
	(t (error "~S is neither a function nor the name of one." function))))

(defun line-length (stream &optional (default 113))
  Ï1;; Ï*113 Ï1is max. characters per line for printing on Imagen with font Cour08.Ï*
  Ï1;; note - Poscript printer can print 121 characters sideways with default font.Ï*
  Ï1"How many characters per line can be written to this stream?"Ï*
  (if (send stream :operation-handled-p :inside-width)Ï1 ; if a window, find how wide.Ï*
      (truncate (send stream :inside-width)
		(or (send stream :send-if-handles :char-width)
		    (tv:font-char-width (or (send stream :send-if-handles :current-font)
					    fonts:cptfont))))
    default))

(DEFUN EXTERNAL-SYMBOL-P (OBJECT)
  (AND (SYMBOLP OBJECT)
       (SYMBOL-PACKAGE OBJECT)
       (MULTIPLE-VALUE-BIND ( SYMBOL CLASS )
	   (FIND-SYMBOL (SYMBOL-NAME OBJECT)
			(SYMBOL-PACKAGE OBJECT))
	 (DECLARE (IGNORE SYMBOL))
	 (EQ CLASS :EXTERNAL) )))

(defunÏ3 in-fileÏ* (pathnames)
Ï1  "Given a pathname or list of pathnames, returns a predicate function that 
tests whether a function spec is defined in one of the files.  This may be 
useful as the Ï*:FILTERÏ1 argument to Ï*SHOW-CALL-TREE.Ï1"Ï*
  (when (atom pathnames)
    (setq pathnames (list pathnames)))
  (let ((generics nil))
    (dolist (path pathnames)
      (push (send (pathname path) :generic-pathname)
	    generics))
    #'(lambda (fspec)
	(member (sys:get-source-file-name fspec) generics :test #'eq))
    ))

(defun file-tree (file)
  Ï1"Display calling tree for functions defined in a file or list of files."Ï*
  (let ((functions nil)
	(pathnames nil))
    (dolist (file (if (atom file) (list file) file))
      (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)
		(when (eq kind 'defun)
		  (pushnew name functions :test #'equal))
		(values))))
	))
    (let ((externals nil)
	  (other-roots nil)
	  (more-functions nil))
      (dolist (fn functions)
	(let ((x (get-item fn :function nil)))
	  (if (or (null x)
		  (dolist (other (xref-item-callers x) t)
		    (when (and (member other functions :test #'eq)
			       (not (eq other fn)))
		      (return nil))))
	      (if (external-symbol-p fn)
		  (push fn externals)
		(if (and (symbolp fn) (null (symbol-package fn))) Ï1;  gensymÏ*
		    (push fn more-functions)
		  (push fn other-roots)))
	    (push fn more-functions))))
      (sortf externals #'string<)
      (sortf other-roots #'function-spec-lessp)
      (let ((roots (nconc externals other-roots more-functions))
	    (filter (in-file pathnames))
	    (previous nil))
	(dolist (root roots)
	  (unless (member root previous :test #'eq)
	    (setq previous (show-call-tree root :previous previous
					   :filter filter :return-names t
					   :include-inlines t)))))
      ))
  (values))

(defun Ï3show-forestÏ* (system-or-files)
Ï2  "Display calling trees for all functions defined in a system, or file, or list of files.
See the doc string of SHOW-CALL-TREE for an explanation of the notation used."Ï*
  (if (and (atom system-or-files)
	   (or (symbolp system-or-files)
	       (and (stringp system-or-files)
		    (sys:find-system-named system-or-files t t))))
      (file-tree (system-files system-or-files))
    (file-tree system-or-files)))

(defun Ï3inverse-treeÏ* (symbol)
  Ï1"Display the tree of who references this symbol, and who references them, etc.
All known references to the root are shown, but at levels beyond that, the 
tree is heuristically limited to that portion that seems interesting by 
considering external symbols and symbols with many users to be leaves."
  ;; 10/20/88 DNG - On a Ï*:METHODÏ1 fspec, look for references to the message name.
  ;;Ï*		Ï1For a CLOS method fspec, look for references to its generic function.
  ;; 10/21/88 DNG - Don't scan keyword package.Ï*
  (let ((name (if (symbolp symbol) symbol (function-name symbol)))
	(previous nil) ; things already shown
	)
    (let ((pkg (function-spec-package name)))
      (when (and pkg
		 (not (member pkg *packages-processed* :test #'eq))
		 (not (eq pkg (symbol-package ':key)))
		 ;;(not no-query)
		 (yes-or-no-p "Build cross-reference table for package ~A?" (package-name pkg)))
	(build-xref-table-from-package pkg)))
    (labels ((show (fspec indent)
		 (let ((users nil)
		       (fspec2 fspec))
		   (fresh-line)
		   (dotimes (i indent) (write-char #\space))
		   (prin1 fspec)
		   (unless (or (member fspec previous :test #'equal)
			       (and (external-symbol-p fspec)
				    (> indent 0)))
		     (flet ((add-users (kind)
			      (let ((item (get-item fspec2 kind nil)))
				(when (and item
					   (xref-item-callers item))
				  (if (null users)
				      (setq users (xref-item-callers item))
				    (setq users (union (xref-item-callers item) users)))))))
		       (add-users :function)
		       (add-users :macro)
		       (add-users :constant)
		       (add-users :variable)
		       (when (and (null users)
				  (consp fspec2))
			 (cond ((eq (car fspec2) ':method)
				;; look for who might be sending this message
				(setq fspec2 (car (last fspec2)))
				(add-users :constant))
			       ((let ((pkg (find-package "TICLOS")))
				  (and pkg (eq (car fspec2) (find-symbol "METHOD" pkg))))
				;; look for callers of the generic function
				(setq fspec2 (second fspec2))
				(add-users :function))
			       ((eq (car fspec2) ':internal)
				(push (second fspec2) users))
				))
		       (when (or (= indent 0)
				 (<= (length users) (max (- 8 indent) 2)))
			 (push fspec previous)
			 (dolist (user users)
			   (unless (eq user fspec) Ï1; not interested in recursive calls hereÏ*
			     (show user (+ indent 2)))))))
		   )
	       (values)))
      (show name 0)
      ))
  (values))
