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