cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/call-tree.el

   1 ;;; call-tree.el --- Uses tree mode to display a call tree of the
   2 ;;                  give emacs lisp function.
   3 ;;
   4 ;; Copyright (C) 1996, 1998, 2001, 2005 Eric M. Ludlam
   5 ;;
   6 ;; Author: <zappo@gnu.ai.mit.edu>
   7 ;; Version: 0.1
   8 ;; RCS: $Id: call-tree.el,v 1.3 2007-11-26 15:01:03 michaels Exp $
   9 ;; Keywords: OO, tree, call-graph
  10 ;;
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25 ;;
  26 ;; Please send bug reports, etc. to zappo@gnu.org
  27
  28 ;;; Commentary:
  29 ;;   This function allows the user to display a call tree for a
  30 ;; given function.  Function symbols are expanded only if they are
  31 ;; evaluated Lisp expressions.  Compiled functions and (of course)
  32 ;; subroutines are not expanded.  Subroutines are not even listed in
  33 ;; the tree as they are assumed to be in there.
  34 ;;   This was created in the hopes that it would aid me in debugging
  35 ;; things by being able to visualize the flow of control.  As a
  36 ;; result, symbols are expanded multiple times, and recursion is
  37 ;; removed (and assumed)
  38 ;;
  39
  40 (require 'tree)
  41
  42 ;;; Code:
  43 (defclass call-tree-node (tree-node)
  44   ((symbol :initarg :symbol
  45            :initform nil)
  46    )
  47   "Class used to define a tree node representing a lisp function.
  48 This function is assumed to have been called from it's parent node")
  49
  50 (defmethod edit ((tn call-tree-node))
  51   "Action to take when middle mouse button is clicked."
  52   (let* ((sym (oref tn symbol))
  53          (sff (locate-library (describe-function-find-file sym)))
  54          (sffs (if (string-match "\\.elc$" sff)
  55                    (substring sff 0 (1- (length sff)))
  56                  sff)))
  57     (find-file sffs)
  58     (goto-char (point-min))
  59     (re-search-forward (concat "def\\(un\\|macro\\|method\\)\\s-+"
  60                                (symbol-name sym) "\\s-+"))
  61   ))
  62
  63 (defmethod select ((tn call-tree-node))
  64   "Action to take when first mouse is clicked."
  65   (if (featurep 'eldoc)
  66       (eldoc-print-fnsym-args (oref tn symbol))
  67     (message "Clicked on node %s" (object-name tn))
  68   ))
  69
  70 (defun call-tree-new-node (func)
  71   "Build a variable `call-tree-node' based on the function FUNC."
  72   (call-tree-node (symbol-name func)
  73                   :name (symbol-name func)
  74                   :symbol func))
  75
  76 ;;;###autoload
  77 (defun call-tree (func)
  78   "Build a call tree to show all functions called by FUNC."
  79   (interactive "aFunction: ")
  80   (switch-to-buffer (tree-new-buffer (format "*CALL-TREE-%s*" func)))
  81   (erase-buffer)
  82   (let ((np (tree-set-root (call-tree-new-node func))))
  83     (call-tree-grow np))
  84   (tree-refresh-tree))
  85
  86 (defun call-tree-grow (func)
  87   "Decompose the function stored in the object FUNC and create children."
  88   (let* ((fvv (symbol-function (oref func symbol)))
  89          (fv (if (and (listp fvv) (listp (cdr fvv))) (cdr (cdr fvv)) nil))
  90          (nnl nil))
  91     (if (and fv (listp fv))
  92         (progn
  93           ;; elimitate the doc-string
  94           (if (stringp (car fv)) (setq fv (cdr fv)))
  95           (call-tree-grow-recurse func fv)
  96           (setq nnl (oref func children))
  97           (while nnl
  98             (if (not (call-tree-recursive-p func (oref (car nnl) symbol)))
  99                 (call-tree-grow (car nnl)))
 100             (setq nnl (cdr nnl)))))))
 101
 102 (defun call-tree-grow-recurse (func forms)
 103   "Recurse down FUNC's FORMS list adding tree nodes to func the whole way."
 104   (if (and (symbolp (car forms)) (fboundp (car forms)))
 105       (if (or (equal (car forms) 'macro))
 106           (setq forms nil)
 107         (if (and (not (call-tree-duplicate func (car forms)))
 108                  (not (subrp (symbol-function (car forms))))
 109                  (not (and (symbolp (symbol-function (car forms)))
 110                            (subrp (symbol-function
 111                                    (symbol-function (car forms)))))))
 112             (tree-add-child func (call-tree-new-node (car forms))))
 113         (cond ((equal (car forms) 'let)
 114                (setq forms (cdr (cdr forms))))
 115               (t
 116                (setq forms (cdr forms))))))
 117   (while (and forms (listp forms))
 118     (if (and forms (listp forms) (listp (car forms)))
 119         (call-tree-grow-recurse func (car forms)))
 120     (setq forms (cdr forms)))
 121   )
 122
 123 (defun call-tree-duplicate (func newfunc)
 124   "Scan siblings in FUNC to see if we already have it listed here.
 125 Argument NEWFUNC is a function I cannot devine at this time."
 126   (let ((fp (oref func children)))
 127     (while (and fp (not (eq (oref (car fp) symbol) newfunc)))
 128       (setq fp (cdr fp)))
 129     fp))
 130
 131
 132 (defun call-tree-recursive-p (func newfunc)
 133   "Scan parents of FUNC for occurance of NEWFUNC."
 134   (let ((fp func))
 135     (while (and fp (not (eq newfunc (oref fp symbol))))
 136       (setq fp (oref fp parent)))
 137     fp))
 138
 139 (provide 'call-tree)
 140
 141 ;;; call-tree.el ends here