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 / lucid.lisp < prev    next >
Encoding:
Text File  |  1992-06-29  |  1.9 KB  |  64 lines
  1. ;;;
  2. ;;; Lucid initializations 
  3. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  4. ;;;
  5. (in-package "ILISP")
  6.  
  7. ;;;
  8. (defun ilisp-callers (symbol package &aux (list-of-callers nil))
  9.   "Print the callers of PACKAGE::SYMBOL.  Only compiled functions
  10. currently.  Return T if successful."
  11.   (ilisp-errors
  12.    (let ((function-name (ilisp-find-symbol symbol package))
  13.      (*print-level* nil)
  14.      (*print-length* nil)
  15.      (*package* (find-package 'lisp)))
  16.      (when (and function-name (fboundp function-name))
  17.        (flet
  18.        ((check-symbol (symbol)
  19.           (labels
  20.           ((check-function (function &optional exclusions)
  21.              (do ((i 4 (1+ i)))
  22.              ((>= i (lucid::procedure-length function)))
  23.                (let ((element (sys:procedure-ref function i)))
  24.              (cond ((eq element function-name)
  25.                 (pushnew symbol list-of-callers))
  26.                    ((and (compiled-function-p element)
  27.                      (not (find element exclusions)))
  28.                 (check-function
  29.                  element
  30.                  (cons element exclusions))))))))
  31.         (check-function (symbol-function symbol)))))
  32.      (do-all-symbols (symbol)
  33.        (when (fboundp symbol)
  34.          (check-symbol symbol)))
  35.      (dolist (caller list-of-callers)
  36.        (print caller))
  37.      t)))))
  38.  
  39. ;;;
  40. (defun ilisp-source-files (symbol package type)
  41.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  42. return T if successful."
  43.   (ilisp-errors
  44.    (let* ((symbol (ilisp-find-symbol symbol package))
  45.       (all (equal type "any"))
  46.       (type (unless all (ilisp-find-symbol type package)))
  47.       (paths (when symbol
  48.            (lucid::get-source-file symbol type all))))
  49.      (if paths
  50.      (progn
  51.        (if all
  52.            (dolist (file (remove-duplicates paths
  53.                         :key #'cdr :test #'equal))
  54.          (print (namestring (cdr file))))
  55.            (print (namestring paths)))
  56.        t)
  57.      nil))))
  58.  
  59. ;;;
  60. (dolist (symbol '(ilisp-callers ilisp-source-files))
  61.   (export symbol))
  62. (unless (compiled-function-p #'ilisp-callers)
  63.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  64.