1 |
|
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
;;; Basic environmental stuff. |
28 |
|
;;; |
29 |
|
|
30 |
|
(in-package :pcl) |
31 |
|
|
32 |
|
#+Lucid |
33 |
|
(progn |
34 |
|
|
35 |
|
(defun pcl-arglist (function &rest other-args) |
36 |
|
(let ((defn nil)) |
37 |
|
(cond ((and (fsc-instance-p function) |
38 |
|
(generic-function-p function)) |
39 |
|
(generic-function-pretty-arglist function)) |
40 |
|
((and (symbolp function) |
41 |
|
(fboundp function) |
42 |
|
(setq defn (symbol-function function)) |
43 |
|
(fsc-instance-p defn) |
44 |
|
(generic-function-p defn)) |
45 |
|
(generic-function-pretty-arglist defn)) |
46 |
|
(t (apply (original-definition 'sys::arglist) |
47 |
|
function other-args))))) |
48 |
|
|
49 |
|
(redefine-function 'sys::arglist 'pcl-arglist) |
50 |
|
|
51 |
|
) |
52 |
|
|
53 |
|
|
54 |
|
;;; |
55 |
|
;;; |
56 |
|
;;; |
57 |
|
|
58 |
|
(defgeneric describe-object (object stream)) |
59 |
|
|
60 |
|
#-Genera |
61 |
|
(progn |
62 |
|
|
63 |
|
(defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints) |
64 |
|
(let (#+Lispm (*describe-no-complaints* no-complaints)) |
65 |
|
#+Lispm (declare (special *describe-no-complaints*)) |
66 |
|
(describe-object object *standard-output*) |
67 |
|
(values))) |
68 |
|
|
69 |
|
(defmethod describe-object (object stream) |
70 |
|
#-cmu |
71 |
|
(cond ((or #+kcl (packagep object)) |
72 |
|
(describe-package object stream)) |
73 |
|
(t |
74 |
|
(funcall (original-definition 'describe) object))) |
75 |
|
#+cmu |
76 |
|
(describe object stream)) |
77 |
|
|
78 |
|
#-cmu |
79 |
|
(redefine-function 'describe 'pcl-describe) |
80 |
|
|
81 |
|
) |
82 |
|
|
83 |
|
(defmethod describe-object ((object slot-object) stream) |
84 |
|
(let* ((class (class-of object)) |
85 |
|
(slotds (slots-to-inspect class object)) |
86 |
|
(max-slot-name-length 0) |
87 |
|
(instance-slotds ()) |
88 |
|
(class-slotds ()) |
89 |
|
(other-slotds ())) |
90 |
|
(flet ((adjust-slot-name-length (name) |
91 |
|
(setq max-slot-name-length |
92 |
|
(max max-slot-name-length |
93 |
|
(length (the string (symbol-name name)))))) |
94 |
|
(describe-slot (name value &optional (allocation () alloc-p)) |
95 |
|
(if alloc-p |
96 |
|
(format stream |
97 |
|
"~% ~A ~S ~VT ~S" |
98 |
|
name allocation (+ max-slot-name-length 7) value) |
99 |
|
(format stream |
100 |
|
"~% ~A~VT ~S" |
101 |
|
name max-slot-name-length value)))) |
102 |
|
;; Figure out a good width for the slot-name column. |
103 |
|
(dolist (slotd slotds) |
104 |
|
(adjust-slot-name-length (slot-definition-name slotd)) |
105 |
|
(case (slot-definition-allocation slotd) |
106 |
|
(:instance (push slotd instance-slotds)) |
107 |
|
(:class (push slotd class-slotds)) |
108 |
|
(otherwise (push slotd other-slotds)))) |
109 |
|
(setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) |
110 |
|
(format stream "~%~S is an instance of class ~S:" object class) |
111 |
|
|
112 |
|
(when instance-slotds |
113 |
|
(format stream "~% The following slots have :INSTANCE allocation:") |
114 |
|
(dolist (slotd (nreverse instance-slotds)) |
115 |
|
(describe-slot (slot-definition-name slotd) |
116 |
|
(slot-value-or-default object (slot-definition-name slotd))))) |
117 |
|
|
118 |
|
(when class-slotds |
119 |
|
(format stream "~% The following slots have :CLASS allocation:") |
120 |
|
(dolist (slotd (nreverse class-slotds)) |
121 |
|
(describe-slot (slot-definition-name slotd) |
122 |
|
(slot-value-or-default object (slot-definition-name slotd))))) |
123 |
|
|
124 |
|
(when other-slotds |
125 |
|
(format stream "~% The following slots have allocation as shown:") |
126 |
|
(dolist (slotd (nreverse other-slotds)) |
127 |
|
(describe-slot (slot-definition-name slotd) |
128 |
|
(slot-value-or-default object (slot-definition-name slotd)) |
129 |
|
(slot-definition-allocation slotd)))) |
130 |
|
(values)))) |
131 |
|
|
132 |
|
(defmethod slots-to-inspect ((class slot-class) (object slot-object)) |
133 |
|
(class-slots class)) |
134 |
|
|
135 |
|
(defvar *describe-metaobjects-as-objects-p* nil) |
136 |
|
|
137 |
|
(defmethod describe-object ((fun standard-generic-function) stream) |
138 |
|
(format stream "~A is a generic function.~%" fun) |
139 |
|
(format stream "Its arguments are:~% ~S~%" |
140 |
|
(generic-function-pretty-arglist fun)) |
141 |
|
(format stream "Its methods are:") |
142 |
|
(dolist (meth (generic-function-methods fun)) |
143 |
|
(format stream "~2% ~{~S ~}~:S =>~%" |
144 |
|
(method-qualifiers meth) |
145 |
|
(unparse-specializers meth)) |
146 |
|
(describe-object (or (method-fast-function meth) |
147 |
|
(method-function meth)) |
148 |
|
stream)) |
149 |
|
(when *describe-metaobjects-as-objects-p* |
150 |
|
(call-next-method))) |
151 |
|
|
152 |
|
;;; |
153 |
|
;;; |
154 |
|
;;; |
155 |
|
(defmethod describe-object ((class class) stream) |
156 |
|
(flet ((pretty-class (c) (or (class-name c) c))) |
157 |
|
(macrolet ((ft (string &rest args) `(format stream ,string ,@args))) |
158 |
|
(ft "~&~S is a class, it is an instance of ~S.~%" |
159 |
|
class (pretty-class (class-of class))) |
160 |
|
(let ((name (class-name class))) |
161 |
|
(if name |
162 |
|
(if (eq class (find-class name nil)) |
163 |
|
(ft "Its proper name is ~S.~%" name) |
164 |
|
(ft "Its name is ~S, but this is not a proper name.~%" name)) |
165 |
|
(ft "It has no name (the name is NIL).~%"))) |
166 |
|
(ft "The direct superclasses are: ~:S, and the direct~%~ |
167 |
|
subclasses are: ~:S. The class precedence list is:~%~S~%~ |
168 |
|
There are ~D methods specialized for this class." |
169 |
|
(mapcar #'pretty-class (class-direct-superclasses class)) |
170 |
|
(mapcar #'pretty-class (class-direct-subclasses class)) |
171 |
|
(mapcar #'pretty-class (class-precedence-list class)) |
172 |
|
(length (specializer-direct-methods class))))) |
173 |
|
(when *describe-metaobjects-as-objects-p* |
174 |
|
(call-next-method))) |
175 |
|
|
176 |
|
(defun describe-package (object stream) |
177 |
|
(unless (packagep object) (setq object (find-package object))) |
178 |
|
(format stream "~&~S is a ~S.~%" object (type-of object)) |
179 |
|
(let ((nick (package-nicknames object))) |
180 |
|
(when nick |
181 |
|
(format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%" |
182 |
|
(butlast nick) (first (last nick))))) |
183 |
|
(let* (#+cmu (internal (lisp::package-internal-symbols object)) |
184 |
|
(internal-count #+cmu (- (lisp::package-hashtable-size internal) |
185 |
|
(lisp::package-hashtable-free internal)) |
186 |
|
#-cmu 0) |
187 |
|
#+cmu (external (lisp::package-external-symbols object)) |
188 |
|
(external-count #+cmu (- (lisp::package-hashtable-size external) |
189 |
|
(lisp::package-hashtable-free external)) |
190 |
|
#-cmu 0)) |
191 |
|
#-cmu (do-external-symbols (sym object) |
192 |
|
(declare (ignore sym)) |
193 |
|
(incf external-count)) |
194 |
|
#-cmu (do-symbols (sym object) |
195 |
|
(declare (ignore sym)) |
196 |
|
(incf internal-count)) |
197 |
|
#-cmu (decf internal-count external-count) |
198 |
|
(format stream "It has ~D internal and ~D external symbols (~D total).~%" |
199 |
|
internal-count external-count (+ internal-count external-count))) |
200 |
|
(let ((used (package-use-list object))) |
201 |
|
(when used |
202 |
|
(format stream "It uses the packages ~{~S~^, ~}.~%" |
203 |
|
(mapcar #'package-name used)))) |
204 |
|
(let ((users (package-use-list object))) |
205 |
|
(when users |
206 |
|
(format stream "It is used by the packages ~{~S~^, ~}.~%" |
207 |
|
(mapcar #'package-name users))))) |
208 |
|
|
209 |
|
#+cmu |
210 |
|
(defmethod describe-object ((object package) stream) |
211 |
|
(describe-package object stream)) |
212 |
|
|
213 |
|
#+cmu |
214 |
|
(defmethod describe-object ((object hash-table) stream) |
215 |
|
(format stream "~&~S is an ~a hash table." |
216 |
|
object |
217 |
|
#-cmu17 (lisp::hash-table-kind object) |
218 |
|
#+cmu17 (lisp::hash-table-test object)) |
219 |
|
(format stream "~&Its size is ~d buckets." |
220 |
|
(lisp::hash-table-size object)) |
221 |
|
(format stream "~&Its rehash-size is ~d." |
222 |
|
(lisp::hash-table-rehash-size object)) |
223 |
|
(format stream "~&Its rehash-threshold is ~d." |
224 |
|
(hash-table-rehash-threshold object)) |
225 |
|
(format stream "~&It currently holds ~d entries." |
226 |
|
(lisp::hash-table-number-entries object))) |
227 |
|
|
228 |
|
|
229 |
|
|
230 |
|
;;; |
231 |
|
;;; trace-method and untrace-method accept method specs as arguments. A |
232 |
|
;;; method-spec should be a list like: |
233 |
|
;;; (<generic-function-spec> qualifiers* (specializers*)) |
234 |
|
;;; where <generic-function-spec> should be either a symbol or a list |
235 |
|
;;; of (SETF <symbol>). |
236 |
|
;;; |
237 |
|
;;; For example, to trace the method defined by: |
238 |
|
;;; |
239 |
|
;;; (defmethod foo ((x spaceship)) 'ss) |
240 |
|
;;; |
241 |
|
;;; You should say: |
242 |
|
;;; |
243 |
|
;;; (trace-method '(foo (spaceship))) |
244 |
|
;;; |
245 |
|
;;; You can also provide a method object in the place of the method |
246 |
|
;;; spec, in which case that method object will be traced. |
247 |
|
;;; |
248 |
|
;;; For untrace-method, if an argument is given, that method is untraced. |
249 |
|
;;; If no argument is given, all traced methods are untraced. |
250 |
|
;;; |
251 |
|
(defclass traced-method (method) |
252 |
|
((method :initarg :method) |
253 |
|
(function :initarg :function |
254 |
|
:reader method-function) |
255 |
|
(generic-function :initform nil |
256 |
|
:accessor method-generic-function))) |
257 |
|
|
258 |
|
(defmethod method-lambda-list ((m traced-method)) |
259 |
|
(with-slots (method) m (method-lambda-list method))) |
260 |
|
|
261 |
|
(defmethod method-specializers ((m traced-method)) |
262 |
|
(with-slots (method) m (method-specializers method))) |
263 |
|
|
264 |
|
(defmethod method-qualifiers ((m traced-method)) |
265 |
|
(with-slots (method) m (method-qualifiers method))) |
266 |
|
|
267 |
|
(defmethod accessor-method-slot-name ((m traced-method)) |
268 |
|
(with-slots (method) m (accessor-method-slot-name method))) |
269 |
|
|
270 |
|
(defvar *traced-methods* ()) |
271 |
|
|
272 |
|
(defun trace-method (spec &rest options) |
273 |
|
#+copy-&rest-arg (setq options (copy-list options)) |
274 |
|
(multiple-value-bind (gf omethod name) |
275 |
|
(parse-method-or-spec spec) |
276 |
|
(let* ((tfunction (trace-method-internal (method-function omethod) |
277 |
|
name |
278 |
|
options)) |
279 |
|
(tmethod (make-instance 'traced-method |
280 |
|
:method omethod |
281 |
|
:function tfunction))) |
282 |
|
(remove-method gf omethod) |
283 |
|
(add-method gf tmethod) |
284 |
|
(pushnew tmethod *traced-methods*) |
285 |
|
tmethod))) |
286 |
|
|
287 |
|
(defun untrace-method (&optional spec) |
288 |
|
(flet ((untrace-1 (m) |
289 |
|
(let ((gf (method-generic-function m))) |
290 |
|
(when gf |
291 |
|
(remove-method gf m) |
292 |
|
(add-method gf (slot-value m 'method)) |
293 |
|
(setq *traced-methods* (remove m *traced-methods*)))))) |
294 |
|
(if (not (null spec)) |
295 |
|
(multiple-value-bind (gf method) |
296 |
|
(parse-method-or-spec spec) |
297 |
|
(declare (ignore gf)) |
298 |
|
(if (memq method *traced-methods*) |
299 |
|
(untrace-1 method) |
300 |
|
(error "~S is not a traced method?" method))) |
301 |
|
(dolist (m *traced-methods*) (untrace-1 m))))) |
302 |
|
|
303 |
|
(defun trace-method-internal (ofunction name options) |
304 |
|
(eval `(untrace ,name)) |
305 |
|
(setf (symbol-function name) ofunction) |
306 |
|
(eval `(trace ,name ,@options)) |
307 |
|
(symbol-function name)) |
308 |
|
|
309 |
|
|
310 |
|
|
311 |
|
|
312 |
|
;(defun compile-method (spec) |
313 |
|
; (multiple-value-bind (gf method name) |
314 |
|
; (parse-method-or-spec spec) |
315 |
|
; (declare (ignore gf)) |
316 |
|
; (compile name (method-function method)) |
317 |
|
; (setf (method-function method) (symbol-function name)))) |
318 |
|
|
319 |
|
(defmacro undefmethod (&rest args) |
320 |
|
#+(or (not :lucid) :lcl3.0) |
321 |
|
(declare (arglist name {method-qualifier}* specializers)) |
322 |
|
`(undefmethod-1 ',args)) |
323 |
|
|
324 |
|
(defun undefmethod-1 (args) |
325 |
|
(multiple-value-bind (gf method) |
326 |
|
(parse-method-or-spec args) |
327 |
|
(when (and gf method) |
328 |
|
(remove-method gf method) |
329 |
|
method))) |
330 |
|
|
331 |
|
|
332 |
|
(pushnew :pcl *features*) |
333 |
|
(pushnew :portable-commonloops *features*) |
334 |
|
(pushnew :pcl-structures *features*) |
335 |
|
|
336 |
|
#+cmu |
337 |
|
(when (find-package "OLD-PCL") |
338 |
|
(setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) |
339 |
|
(symbol-function 'pcl::print-object))) |
340 |
|
|
341 |
|
|
342 |
|
;;;; MAKE-LOAD-FORM |
343 |
|
|
344 |
|
#+cmu17 |
345 |
|
(export '(cl::make-load-form cl::make-load-form-saving-slots) "CL") |
346 |
|
|
347 |
|
#+cmu17 |
348 |
|
(progn |
349 |
|
(defgeneric make-load-form (object &optional environment)) |
350 |
|
|
351 |
|
(defmethod make-load-form ((object structure-object) &optional environment) |
352 |
|
(declare (ignore environment)) |
353 |
|
(kernel:make-structure-load-form object)) |
354 |
|
|
355 |
|
(defmethod make-load-form ((object wrapper) &optional env) |
356 |
|
(declare (ignore env)) |
357 |
|
(let ((pname (kernel:class-proper-name (kernel:layout-class object)))) |
358 |
|
(unless pname |
359 |
|
(error "Can't dump wrapper for anonymous class:~% ~S" |
360 |
|
(kernel:layout-class object))) |
361 |
|
`(kernel:class-layout (lisp:find-class ',pname)))) |
362 |
|
|
363 |
|
(defun make-load-form-saving-slots (object &key slot-names environment) |
364 |
|
(declare (ignore environment)) |
365 |
|
(when slot-names |
366 |
|
(warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ |
367 |
|
slots:~% ~S" |
368 |
|
object)) |
369 |
|
:just-dump-it-normally)) |
370 |
|
|
371 |
|
|
372 |
|
;;; The following are hacks to deal with CMU CL having two different CLASS |
373 |
|
;;; classes. |
374 |
|
;;; |
375 |
|
#+cmu17 |
376 |
|
(defun coerce-to-pcl-class (class) |
377 |
|
(if (typep class 'lisp:class) |
378 |
|
(or (kernel:class-pcl-class class) |
379 |
|
(find-structure-class (lisp:class-name class))) |
380 |
|
class)) |
381 |
|
|
382 |
|
#+cmu17 |
383 |
|
(progn |
384 |
|
(defmethod make-instance ((class lisp:class) &rest stuff) |
385 |
|
(apply #'make-instance (coerce-to-pcl-class class) stuff)) |
386 |
|
(defmethod change-class (instance (class lisp:class)) |
387 |
|
(apply #'change-class instance (coerce-to-pcl-class class)))) |
388 |
|
|
389 |
|
#+cmu17 |
390 |
|
(macrolet ((frob (&rest names) |
391 |
|
`(progn |
392 |
|
,@(mapcar #'(lambda (name) |
393 |
|
`(defmethod ,name ((class lisp:class)) |
394 |
|
(funcall #',name |
395 |
|
(coerce-to-pcl-class class)))) |
396 |
|
names)))) |
397 |
|
(frob |
398 |
|
class-direct-slots |
399 |
|
class-prototype |
400 |
|
class-precedence-list |
401 |
|
class-direct-default-initargs |
402 |
|
class-direct-superclasses |
403 |
|
compute-class-precedence-list |
404 |
|
class-default-initargs class-finalized-p |
405 |
|
class-direct-subclasses class-slots |
406 |
|
make-instances-obsolete)) |