home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / ilisp / allegro.lisp next >
Encoding:
Text File  |  1992-06-29  |  1.9 KB  |  66 lines
  1. ;;;
  2. ;;; Allegro initializations
  3. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  4. ;;;
  5. (in-package "ILISP")
  6.  
  7. ;;;
  8. (defun ilisp-callers (symbol package)
  9.   "Print a list of all of the functions that call FUNCTION and return
  10. T if successful." 
  11.   (ilisp-errors
  12.    (let ((function (ilisp-find-symbol symbol package))
  13.      (callers nil)
  14.      (*print-level* nil)
  15.      (*print-length* nil)
  16.      (*package* (find-package 'lisp)))
  17.      (when (and function (fboundp function))
  18.        (labels ((in-expression (function expression)
  19.           (cond ((null expression) nil)
  20.             ((listp expression)
  21.              (let ((header (first expression)))
  22.                (if (or (eq header function)
  23.                    (and (eq header 'function)
  24.                     (eq (second expression) function)))
  25.                    t
  26.                    (dolist (subexp expression)
  27.                  (when (in-expression function subexp)
  28.                    (return t)))))))))
  29.      (excl::who-references
  30.       function
  31.       #'(lambda (function)
  32.           (push (excl::fn_symdef function) callers)))
  33.      (do-all-symbols (symbol)
  34.        (when (and (fboundp symbol)
  35.               (not (compiled-function-p (symbol-function symbol)))
  36.               (in-expression function (symbol-function symbol)))
  37.          (push symbol callers)))
  38.      (dolist (caller callers)
  39.        (print caller))
  40.      t)))))
  41.  
  42. ;;;
  43. (defun ilisp-source-files (symbol package type)
  44.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  45. return T if successful."
  46.   (ilisp-errors
  47.    (let* ((symbol (ilisp-find-symbol symbol package))
  48.       (type (if (equal type "any") t (ilisp-find-symbol type "keyword")))
  49.       (paths (when symbol (excl:source-file symbol type))))
  50.      (if paths
  51.      (progn
  52.        (if (eq type t)
  53.            (dolist (path (remove-duplicates paths
  54.                         :key #'cdr :test #'equal))
  55.          (print (namestring (cdr path))))
  56.            (print (namestring paths)))
  57.        t)
  58.      nil))))
  59.  
  60. ;;;
  61. (dolist (symbol '(ilisp-callers ilisp-source-files))
  62.   (export symbol))
  63. (unless (compiled-function-p #'ilisp-callers)
  64.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  65.  
  66.