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

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; allegro.lisp --
   4 ;;; ILISP Franz ACL dialect support definitions.
   5 ;;;
   6 ;;; This file is part of ILISP.
   7 ;;; Please refer to the file COPYING for copyrights and licensing
   8 ;;; information.
   9 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  10 ;;; of present and past contributors.
  11 ;;;
  12 ;;; $Id: allegro.lisp,v 1.4 2002-05-30 13:59:20 wbd Exp $
  13
  14 ;;; Allegro initializations
  15 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  16
  17 (in-package :ilisp)
  18
  19 ;;; 20001203 Patch suggested by Larry Hunter <Larry.Hunter@uchsc.edu>
  20 ;;; EXCL::FN_SYMDEF is no longer available by default.
  21
  22 #+(or allegro-v5.0 allegro-v6.0 allegro-v6.1) (eval-when (compile load) (require
  23                                                             :llstructs))
  24
  25 ;;;
  26 (defun ilisp-callers (symbol package)
  27   "Print a list of all of the functions that call FUNCTION.
  28 Returns T if successful."
  29   (ilisp-errors
  30    (let ((function (ilisp-find-symbol symbol package))
  31          (callers nil)
  32          (*print-level* nil)
  33          (*print-length* nil)
  34          (*package* (find-package 'lisp)))
  35      (when (and function (fboundp function))
  36        (labels ((in-expression (function expression)
  37                   (cond ((null expression) nil)
  38                         ((listp expression)
  39                          (let ((header (first expression)))
  40                            (if (or (eq header function)
  41                                    (and (eq header 'function)
  42                                         (eq (second expression) function)))
  43                                t
  44                                (dolist (subexp expression)
  45                                  (when (in-expression function subexp)
  46                                    (return t)))))))))
  47          (excl::who-references
  48           function
  49           #'(lambda (function)
  50               (push (excl::fn_symdef function) callers)))
  51          (do-all-symbols (symbol)
  52            (when (and (fboundp symbol)
  53                       (not (compiled-function-p (symbol-function symbol)))
  54                       (in-expression function (symbol-function symbol)))
  55              (push symbol callers)))
  56          (dolist (caller callers)
  57            (print caller))
  58          t)))))
  59
  60 ;;;
  61 (defun ilisp-source-files (symbol package type)
  62   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line.
  63 Returns T if successful."
  64   (ilisp-errors
  65    (let* ((symbol (ilisp-find-symbol symbol package))
  66           (type (if (equal type "any") t (ilisp-find-symbol type "keyword")))
  67           (paths (when symbol (excl:source-file symbol type))))
  68      (if paths
  69          (progn
  70            (if (eq type t)
  71                (dolist (path (remove-duplicates paths
  72                                                 :key #'cdr :test #'equal))
  73                  (print (namestring (cdr path))))
  74                (print (namestring paths)))
  75            t)
  76          nil))))
  77
  78 ;;;===========================================================================
  79 ;;; Epilogue
  80
  81 (eval-when (load eval)
  82   (unless (compiled-function-p #'ilisp-callers)
  83     (ilisp-message t "File is not compiled, use M-x ilisp-compile-inits")))
  84
  85 ;;; end of file -- allegro.lisp --