call-tree grapher submission

[<@IU.AI.SRI.COM:slug-admin@iu.ai.sri.com>]

(Resent w/o fonts for those using non-smbx mail readers.)

I've written some short code for graphing the call tree of symbols.  It works like a
recursive :show callers.  I've included the code below.

For what I know, there may already be one of these floating around.

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;;
;;;Functions for seeing the call tree.  call-tree returns list representation of tree.
;;;call-tree-graph graphs the tree using scl:format-graph-from-root.  I think it will
;;;find all the callers that executing :show callers will find.  That is, it will find
;;;where symbols are used as constants, functions, methods, etc but not likely as macros.
;;;Will work with CLOS methods including setf but I don't know if it will work with
;;;Flavors.
;;;
;;;Handles recursion by leaving it out of the graph.
;;;
;;;Copylefted or whatever, you are free to use and copy this for whatever use you see
;;;fit.  If you make money off of it, maybe you could come work for me (I could use a
;;;good salesman) or at least buy stock in my company :-)
;;;
;;;Warning: uses internal Symbolics functions and thus is not portable and may break
;;;after future symbolics releases.
;;;
;;;History
;;;  Don Mitchell 10 Mar 93  Finished and released to slug

(defvar *excluded-functions* '(clim:present clim::present-method)
  "Symbols that repesent as far as you want to go in seeing the tree: i.e., symbols for
which you do not want to see their callers.  Basically, put everything in here that is
likely to have a lot of callers, or alternatively, use the :max-breadth keyword.")  

(defun call-tree-graph (symbol
			&key in-packages exclude-packages
			duplicates-ok (orientation :horizontal)
			how-called max-breadth)
  "Finds the callers of SYMBOL and their callers and so on.  IN-PACKAGES and
EXCLUDE-PACKAGES may be NIL, a package, or a list of packages.  You may use a package
name in place of an actual package object.  If you make DUPLICATES-OK non-nil, then the
graph will be a tree rather than a graph.  HOW-CALLED takes the same values as it does
for :SHOW CALLERS.  MAX-BREADTH is a way to screen out symbols whose callers you probably
don't want to see because there are too many of them.  If nil, then there will be no
breadth screening."    
  (terpri)
  (setf in-packages (real-packages in-packages))
  (setf exclude-packages (real-packages exclude-packages))
  (scl:format-graph-from-root
    (call-tree symbol in-packages exclude-packages how-called max-breadth)
    #'(lambda (e stream) (princ (car e) stream))
    #'cdr
    :dont-draw-duplicates (not duplicates-ok)
    :key #'car
    :orientation orientation))


(defun real-packages (packages)
  (typecase packages
    (package packages)
    ((or symbol string) (find-package packages))
    (list (mapcar #'real-packages packages))))

(defun call-tree (symbol
		  &optional in-packages exclude-packages
		  how-called max-breadth (visited (make-hash-table)) (path '(0)))
  "HOW-CALLED either an atom or list of keywords :function, :constant, etc. (see show
callers)"
  (cond ((and (gethash symbol visited)
	      (tailp (gethash symbol visited) path)) nil)
	((gethash symbol visited) (list symbol))
	((member symbol *excluded-functions*) (list symbol))
	(t (setf (gethash symbol visited) path)
	   (cons symbol
		 (let ((n 0))
		   (delete
		     nil
		     (mapcar #'(lambda (c)
				 (call-tree c in-packages exclude-packages how-called
					    max-breadth visited (cons (incf n) path)))
			     (get-callees symbol in-packages exclude-packages
					  how-called max-breadth))))))))


(defun get-callees (function-name in-packages
		    exclude-packages how-called-targets max-breadth)
  (labels ((convert-callee-to-atom (callee)
	     (typecase callee
	       (clos:method
		 (clos:generic-function-name
		   (clos:method-generic-function callee)))
	       (cons
		 (convert-callee-to-atom (second callee)))
	       (t callee)))
	   (caller-id (callee)
	     (typecase callee
	       (cons (second callee))		;probably setf method
	       (atom callee)))
	   (check-package (callee packages)
	     (typecase packages
	       (atom (eq (symbol-package (caller-id callee)) packages))
	       (cons (member (symbol-package (caller-id callee)) packages)))))
    (let ((result '()))
      (si:map-over-callers
	function-name
	#'(lambda (callee ignore)
	    (setf callee (convert-callee-to-atom callee))
	    (when (and (or (null in-packages)
			   (check-package callee in-packages))
		       (or (null exclude-packages)
			   (not (check-package callee exclude-packages))))
	      (pushnew callee result)))
	:called-how how-called-targets)
      (if (and max-breadth (> (length result) max-breadth)) nil result))))

;;;Don Mitchell			dmitchell@trc.amoco.com
;;;Proactive Solutions, Inc.	(918) 660-4270
;;;10814 S. Quebec Ave.
;;;Tulsa, OK 74137