cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/lucid.lisp

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; lucid.lisp --
   4 ;;; Lucid initializations
   5 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
   6 ;;;
   7 ;;; This file is part of ILISP.
   8 ;;; Please refer to the file COPYING for copyrights and licensing
   9 ;;; information.
  10 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  11 ;;; of present and past contributors.
  12 ;;;
  13 ;;; $Id: lucid.lisp,v 1.4 2002-05-30 13:59:21 wbd Exp $
  14
  15 (in-package :ilisp)
  16
  17 ;;;
  18 (defun ilisp-callers (symbol package &aux (list-of-callers nil))
  19   "Print the callers of PACKAGE::SYMBOL.  Only compiled functions
  20 currently.  Return T if successful."
  21   (ilisp-errors
  22    (let ((function-name (ilisp-find-symbol symbol package))
  23          (*print-level* nil)
  24          (*print-length* nil)
  25          (*package* (find-package 'lisp)))
  26      (when (and function-name (fboundp function-name))
  27        (flet
  28            ((check-symbol (symbol)
  29               (labels
  30                   ((check-function (function &optional exclusions)
  31                      (do ((i 4 (1+ i)))
  32                          ((>= i (lucid::procedure-length function)))
  33                        (let ((element (sys:procedure-ref function i)))
  34                          (cond ((eq element function-name)
  35                                 (pushnew symbol list-of-callers))
  36                                ((and (compiled-function-p element)
  37                                      (not (find element exclusions)))
  38                                 (check-function
  39                                  element
  40                                  (cons element exclusions))))))))
  41                 (check-function (symbol-function symbol)))))
  42          (do-all-symbols (symbol)
  43            (when (fboundp symbol)
  44              (check-symbol symbol)))
  45          (dolist (caller list-of-callers)
  46            (print caller))
  47          t)))))
  48
  49 ;;;
  50 (defun ilisp-source-files (symbol package type)
  51   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  52 return T if successful."
  53   (ilisp-errors
  54    (let* ((symbol (ilisp-find-symbol symbol package))
  55           (all (equal type "any"))
  56           (type (unless all (ilisp-find-symbol type package)))
  57           (paths (when symbol
  58                    (lucid::get-source-file symbol type all))))
  59      (if paths
  60          (progn
  61            (if all
  62                (dolist (file (remove-duplicates paths
  63                                                 :key #'cdr :test #'equal))
  64                  (print (namestring (cdr file))))
  65                (print (namestring paths)))
  66            t)
  67          nil))))
  68
  69 ;;;
  70 (dolist (symbol '(ilisp-callers ilisp-source-files))
  71   (export symbol))
  72 (unless (compiled-function-p #'ilisp-callers)
  73   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))