call-tree grapher submission

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

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

0(defvar 2*excluded-functions*0 '(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 2call-tree-graph0 (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 2real-packages0 (packages)
  (typecase packages
    (package packages)
    ((or symbol string) (find-package packages))
    (list (mapcar #'real-packages packages))))

(defun 2call-tree0 (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 2get-callees 0(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))		1;probably setf method
0	       (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