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

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; lispworks.lisp --
   4 ;;; LispWorks ILISP initializations.
   5 ;;;
   6 ;;; Independently written by:
   7 ;;;
   8 ;;; Jason Trenouth: jason@harlequin.co.uk
   9 ;;; Qiegang Long: qlong@cs.umass.edu
  10 ;;;
  11 ;;; and later merged together by Jason.
  12 ;;;
  13 ;;; This file is part of ILISP.
  14 ;;; Please refer to the file COPYING for copyrights and licensing
  15 ;;; information.
  16 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  17 ;;; of present and past contributors.
  18 ;;;
  19 ;;; $Id: lispworks.lisp,v 1.4 2002-05-30 13:59:20 wbd Exp $
  20
  21 (in-package "ILISP")
  22
  23 ;; Make LispWorks interactive
  24 #+Unix
  25 (setf system::*force-top-level* t)
  26
  27
  28 ;;; ilisp-eval --
  29 ;;;
  30 ;;; Notes:
  31 ;;;
  32 ;;; 19990806 Unknown Author (blame Marco Antoniotti for this)
  33
  34 (defun ilisp-eval (form package filename)
  35   "Evaluate FORM in PACKAGE recording FILENAME as the source file."
  36   (let ((*package* (ilisp-find-package package))
  37         #+LispWorks3 (compiler::*input-pathname* (merge-pathnames filename))
  38         #+LispWorks3 (compiler::*warn-on-non-top-level-defun* nil)
  39         )
  40     #+LispWorks3
  41     (eval (read-from-string form))
  42     #+LispWorks4
  43     (dspec:at-location ((or (probe-file filename) (merge-pathnames filename)))
  44                        (eval (read-from-string form)))))
  45
  46
  47 ;;; ilisp-trace --
  48 ;;;
  49 ;;; Notes:
  50 ;;;
  51 ;;; 19990806 Unknown Author (blame Marco Antoniotti for this)
  52
  53 (defun ilisp-trace (symbol package breakp)
  54   "Trace SYMBOL in PACKAGE."
  55   (declare (ignorable breakp))
  56   (ilisp-errors
  57    (let ((real-symbol (ilisp-find-symbol symbol package)))
  58      (when real-symbol (eval `(trace (,real-symbol :break ,breakp)))))))
  59
  60
  61 (defun ilisp-callers (symbol package)
  62   "Print a list of all of the functions that call FUNCTION.
  63 Returns T if successful."
  64   (ilisp-errors
  65       (let ((function-name (ilisp-find-symbol symbol package))
  66             (*print-level* nil)
  67             (*print-length* nil)
  68             (*package* (find-package 'lisp))
  69             (callers ())
  70             )
  71         (when (and function-name (fboundp function-name))
  72           (setf callers (munge-who-calls
  73                          #+(or :lispworks3 :lispworks4) (hcl:who-calls function-name)
  74                          #-(or :lispworks3 :lispworks4) (lw:who-calls function-name)
  75                          ))
  76           (dolist (caller callers)
  77             (print caller))
  78           t))))
  79
  80 ;; gross hack to munge who-calls output for ILISP
  81 (defun munge-who-calls (who-calls)
  82   (labels ((top-level-caller (form)
  83              (if (atom form)
  84                  form
  85                  (top-level-caller (second form)))))
  86     (delete-if-not 'symbolp
  87                    (delete-duplicates (mapcar #'top-level-caller who-calls)))))
  88
  89
  90 ;; Jason 6 SEP 94 -- tabularized Qiegang's code
  91 ;;
  92 ;; There are some problems lurking here:
  93 ;;   - the mapping ought to be done by LispWorks
  94 ;;   - surely you really want just three source types:
  95 ;;     function, type, and variable
  96 ;;
  97 (defconstant *source-type-translations*
  98   '(
  99     ("class"     defclass)
 100     ("function"  )
 101     ("macro"     )
 102     ("structure" defstruct)
 103     ("setf"      defsetf)
 104     ("type"      deftype)
 105     ("variable"  defvar defparameter defconstant)
 106     ))
 107
 108
 109 (defun translate-source-type-to-dspec (symbol type)
 110   (let ((entry (find type *source-type-translations*
 111                      :key 'first :test 'equal)))
 112     (if entry
 113         (let ((wrappers (rest entry)))
 114           (if wrappers
 115               (loop for wrap in wrappers collecting `(,wrap ,symbol))
 116               `(,symbol)))
 117         (error "unknown source type for ~S requested from ILISP: ~S"
 118                symbol type))))
 119
 120
 121 (defun ilisp-source-files (symbol package type)
 122   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line.
 123 Returns T if successful."
 124   ;; A function to limit the search with type?
 125   (ilisp-errors
 126    (let* ((symbol (ilisp-find-symbol symbol package))
 127           (all (equal type "any"))
 128           ;; Note:
 129           ;; 19990806 Marco Antoniotti
 130           ;;
 131           ;; (paths (when symbol (compiler::find-source-file symbol)))
 132           (paths (when symbol (dspec:find-dspec-locations symbol)))
 133           (dspecs (or all (translate-source-type-to-dspec symbol type)))
 134           (cands ())
 135           )
 136      (if (and paths (not all))
 137          (setq cands
 138                (loop for path in paths
 139                      when (find (car path) dspecs :test 'equal)
 140                      collect path))
 141        (setq cands paths))
 142      (if cands
 143          (progn
 144            (dolist (file (remove-duplicates paths
 145                                             :key #'cdr :test #'equal))
 146              (print (truename (cadr file))))
 147            t)
 148          nil))))
 149
 150 ;;; sys::get-top-loop-handler, sys::define-top-loop-handler --
 151 ;;;
 152 ;;; Notes:
 153 ;;;
 154 ;;; 19990806 Unknown Author (blame Marco Antoniotti for this)
 155 ;;;
 156 ;;; 19990806 Marco Antoniotti
 157 ;;; I decided to leave these in, although they are a little too system
 158 ;;; dependent.  I will remove them if people complain.
 159
 160 (eval-when (:compile-toplevel :load-toplevel :execute)
 161   (unless (fboundp 'sys::define-top-loop-handler)
 162
 163     ;; Duplicated from ccl/top-loop.lisp
 164     (defmacro sys::get-top-loop-handler (command-name)
 165       `(get ,command-name 'sys::top-loop-handler))
 166
 167     (defmacro sys::define-top-loop-handler (name &body body)
 168       (lw:with-unique-names (top-loop-handler)
 169         `(let ((,top-loop-handler #'(lambda (sys::line) ,@body)))
 170           (mapc #'(lambda (name)
 171                     (setf (sys::get-top-loop-handler name) ,top-loop-handler))
 172            (if (consp ',name) ',name  '(,name))))))))
 173
 174 (sys::define-top-loop-handler :ilisp-send
 175   (values (multiple-value-list (eval (cadr sys::line))) nil))
 176
 177
 178 (eval-when (load eval)
 179   (unless (compiled-function-p #'ilisp-callers)
 180     (ilisp-message t "File is not compiled, use M-x ilisp-compile-inits")))
 181
 182 ;;; end of file -- lispworks.lisp --