/[cmucl]/src/pcl/env.lisp
ViewVC logotype

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sat Aug 1 15:28:41 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.4: +251 -119 lines
This is July 92 PCL
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 (let ((*standard-output* stream))
71 (funcall-compiled (original-definition 'describe) object)))
72
73 (redefine-function 'describe 'pcl-describe)
74
75 )
76
77 (defmethod describe-object ((object slot-object) stream)
78 (format stream "~%~S is an instance of class ~S:" object (class-of object))
79 (describe-object-slots object stream))
80
81 (defmethod describe-object-slots
82 ((object slot-object)
83 stream
84 &key
85 (slots-to-inspect (slots-to-inspect (class-of object) object))
86 &allow-other-keys)
87 "Display the value of all the slots-to-inspect on this object."
88 (let* ((max-slot-name-length 0)
89 (instance-slotds ())
90 (class-slotds ())
91 (other-slotds ()))
92 (declare (type index max-slot-name-length))
93 (flet ((adjust-slot-name-length (name)
94 (setq max-slot-name-length
95 (the index
96 (max max-slot-name-length
97 (length (the simple-string
98 (symbol-name name)))))))
99 (describe-slot (name value &optional (allocation () alloc-p))
100 (if alloc-p
101 (format stream
102 "~% ~A ~S ~VT "
103 name allocation (+ max-slot-name-length 7))
104 (format stream
105 "~% ~A~VT "
106 name max-slot-name-length))
107 (prin1 value stream)))
108
109 ;; Figure out a good width for the slot-name column.
110 (dolist (slotd slots-to-inspect)
111 (adjust-slot-name-length (slot-definition-name slotd))
112 (case (slot-definition-allocation slotd)
113 (:instance (push slotd instance-slotds))
114 (:class (push slotd class-slotds))
115 (otherwise (push slotd other-slotds))))
116 (setq max-slot-name-length
117 (the index (min (the index (+ max-slot-name-length 3)) 30)))
118
119 (when instance-slotds
120 (format stream "~% The following slots have :INSTANCE allocation:")
121 (dolist (slotd (nreverse instance-slotds))
122 (describe-slot (slot-definition-name slotd)
123 (slot-value-or-default
124 object (slot-definition-name slotd)))))
125
126 (when class-slotds
127 (format stream "~% The following slots have :CLASS allocation:")
128 (dolist (slotd (nreverse class-slotds))
129 (describe-slot (slot-definition-name slotd)
130 (slot-value-or-default
131 object (slot-definition-name slotd)))))
132
133 (when other-slotds
134 (format stream "~% The following slots have allocation as shown:")
135 (dolist (slotd (nreverse other-slotds))
136 (describe-slot (slot-definition-name slotd)
137 (slot-value-or-default
138 object (slot-definition-name slotd))
139 (slot-definition-allocation slotd))))
140 (values))))
141
142 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
143 (class-slots class))
144
145 (defvar *describe-generic-functions-as-objects-p* nil)
146
147 (defmethod describe-object ((fun standard-generic-function) stream)
148 (format stream "~A is a generic function.~%" fun)
149 (format stream "Its arguments are:~% ~S~%"
150 (generic-function-pretty-arglist fun))
151 (if *describe-generic-functions-as-objects-p*
152 (describe-object-slots fun stream)
153 (progn
154 (format stream "Its methods are:")
155 (dolist (meth (generic-function-methods fun))
156 (format stream "~2%**** ~{~S ~}~:S =>~%"
157 (method-qualifiers meth)
158 (unparse-specializers meth))
159 (describe-object meth stream)))))
160
161 ;;;
162 ;;;
163 ;;;
164 (defvar *describe-classes-as-objects-p* nil)
165
166 (defmethod describe-object ((class class) stream)
167 (flet ((pretty-class (c) (or (class-name c) c)))
168 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
169 (ft "~&~S is a class, it is an instance of ~S.~%"
170 class (pretty-class (class-of class)))
171 (let ((name (class-name class)))
172 (if name
173 (if (eq class (find-class name nil))
174 (ft "Its proper name is ~S.~%" name)
175 (ft "Its name is ~S, but this is not a proper name.~%" name))
176 (ft "It has no name (the name is NIL).~%")))
177 (ft "The direct superclasses are: ~:S, and the direct~%~
178 subclasses are: ~:S. "
179 (mapcar #'pretty-class (class-direct-superclasses class))
180 (mapcar #'pretty-class (class-direct-subclasses class)))
181 (if (class-finalized-p class)
182 (ft "The class precedence list is:~%~S~%"
183 (mapcar #'pretty-class (class-precedence-list class)))
184 (ft "The class is not finalized.~%"))
185 (ft "There are ~D methods specialized for this class."
186 (length (the list (specializer-direct-methods class))))))
187 (when *describe-classes-as-objects-p*
188 (describe-object-slots class stream)))
189
190
191 (declaim (ftype (function (T &optional T) (values T T symbol))
192 parse-method-or-spec))
193 (defun parse-method-or-spec (spec &optional (errorp t))
194 (declare (values generic-function method method-name))
195 (let (gf method name temp)
196 (if (method-p spec)
197 (setq method spec
198 gf (method-generic-function method)
199 temp (and gf (generic-function-name gf))
200 name (if temp
201 (intern-function-name
202 (make-method-spec temp
203 (method-qualifiers method)
204 (unparse-specializers
205 (method-specializers method))))
206 (make-symbol (format nil "~S" method))))
207 (multiple-value-bind (gf-spec quals specls)
208 (parse-defmethod spec)
209 (declare (list quals specls))
210 (and (setq gf (and (or errorp (gboundp gf-spec))
211 (gdefinition gf-spec)))
212 (let ((nreq (compute-discriminating-function-arglist-info gf)))
213 (declare (type index nreq))
214 (setq specls (append (parse-specializers specls)
215 (make-list (the index (- nreq (length specls)))
216 :initial-element
217 *the-class-t*)))
218 (and
219 (setq method (get-method gf quals specls errorp))
220 (setq name
221 (intern-function-name (make-method-spec gf-spec
222 quals
223 specls))))))))
224 (values gf method name)))
225
226 (defmethod copy-instance-slots ((object1 slot-object)
227 (object2 slot-object)
228 &key
229 (exclude-slot-names NIL))
230 (let ((obj1-slot-names
231 (mapcar #'slot-definition-name (class-slots (class-of object1))))
232 (obj2-slot-names
233 (mapcar #'slot-definition-name (class-slots (class-of object2)))))
234 (declare (type list obj1-slot-names obj2-slot-names))
235 (dolist (slot-name obj1-slot-names)
236 (when (and (not (memq slot-name exclude-slot-names))
237 (memq slot-name obj2-slot-names))
238 (setf (slot-value object2 slot-name)
239 (slot-value object1 slot-name))))))
240
241 ;;;
242 ;;; trace-method and untrace-method accept method specs as arguments. A
243 ;;; method-spec should be a list like:
244 ;;; (<generic-function-spec> qualifiers* (specializers*))
245 ;;; where <generic-function-spec> should be either a symbol or a list
246 ;;; of (SETF <symbol>).
247 ;;;
248 ;;; For example, to trace the method defined by:
249 ;;;
250 ;;; (defmethod foo ((x spaceship)) 'ss)
251 ;;;
252 ;;; You should say:
253 ;;;
254 ;;; (trace-method '(foo (spaceship)))
255 ;;;
256 ;;; You can also provide a method object in the place of the method
257 ;;; spec, in which case that method object will be traced.
258 ;;;
259 ;;; For untrace-method, if an argument is given, that method is untraced.
260 ;;; If no argument is given, all traced methods are untraced.
261 ;;;
262
263 (defclass traced-method (standard-method)
264 ((method :initarg :method)))
265
266 (defvar *traced-methods* ())
267
268 (defmethod trace-method ((spec cons) &rest options)
269 (multiple-value-bind (gf method name)
270 (parse-method-or-spec spec)
271 (declare (ignore gf name))
272 (apply #'trace-method method options)))
273
274 (defmethod trace-method ((tmethod traced-method) &rest options)
275 (untrace-method tmethod)
276 (apply #'trace-method (slot-value tmethod 'method) options))
277
278 (defmethod trace-method ((method standard-method) &rest options)
279 (let* ((gf (method-generic-function method))
280 (base-name (symbol-name (method-function-name method)))
281 (tmethod (make-instance 'traced-method :method method))
282 (function (method-function method))
283 (t-function
284 (if function
285 (trace-function-internal
286 function (gentemp base-name) options)))
287 (optimized-fn (method-optimized-function method))
288 (t-optimized-fn
289 (if optimized-fn
290 (trace-function-internal
291 optimized-fn (gentemp base-name) options)))
292 (traced-function-names
293 (append (if function (list t-function))
294 (if optimized-fn (list t-optimized-fn)))))
295 (declare (type simple-string base-name)
296 (type symbol t-function t-optimized-fn))
297 (copy-instance-slots method tmethod
298 :exclude-slot-names
299 '(function optimized-function cached-functions-alist
300 generic-function))
301 (when function
302 (setf (slot-value tmethod 'function)
303 (symbol-function t-function)))
304 (when optimized-fn
305 (setf (slot-value tmethod 'optimized-function)
306 (symbol-function t-optimized-fn)))
307 (setf (slot-value tmethod 'cached-functions-alist)
308 (mapcar
309 #'(lambda (cached-fn)
310 (let ((fn (cdr cached-fn)))
311 (cons
312 (car cached-fn)
313 (symbol-function
314 (the symbol
315 (cond ((eq fn function) t-function)
316 ((eq fn optimized-fn) t-optimized-fn)
317 (T
318 (let ((t-name
319 (trace-function-internal
320 fn
321 (gentemp base-name)
322 options)))
323 (push t-name traced-function-names)
324 t-name))))))))
325 (slot-value method 'cached-functions-alist)))
326 (remove-method gf method)
327 (add-method gf tmethod)
328 (push (cons tmethod traced-function-names) *traced-methods*)
329 tmethod))
330
331 (defun untrace-method (&optional spec)
332 (flet ((untrace-1 (method-cons-traces)
333 (let* ((m (car method-cons-traces))
334 (gf (method-generic-function m)))
335 (when gf
336 (remove-method gf m)
337 (add-method gf (slot-value m 'method))))
338 (untrace-method-function-names (cdr method-cons-traces))
339 (setq *traced-methods*
340 (remove method-cons-traces *traced-methods* :test #'eq))))
341 (cond ((consp spec)
342 (multiple-value-bind (gf method)
343 (parse-method-or-spec spec)
344 (declare (ignore gf))
345 (let ((old-trace (assq method *traced-methods*)))
346 (if old-trace
347 (untrace-1 old-trace)
348 (error "~S is not a traced method?" method)))))
349 ((typep spec 'standard-method)
350 (let ((old-trace (assq spec *traced-methods*)))
351 (if old-trace
352 (untrace-1 old-trace)
353 (error "~S is not a traced method?" spec))))
354 ((null spec)
355 (dolist (trace *traced-methods*) (untrace-1 trace)))
356 (T (error
357 "Untrace-method needs method, method specifier, or nothing.")))))
358
359 (defun trace-function-internal (function name options)
360 (eval `(untrace ,name))
361 (setf (symbol-function name) function)
362 (eval `(trace ,name ,@options))
363 name)
364
365 (defun untrace-method-function-names (names)
366 (dolist (name names)
367 (setf (symbol-function name) NIL))
368 (eval `(untrace ,@names)))
369
370 (defun trace-methods (gf)
371 (let ((methods (generic-function-methods gf)))
372 (dolist (method methods)
373 (trace-method method))
374 methods))
375
376
377
378 ;(defun compile-method (spec)
379 ; (multiple-value-bind (gf method name)
380 ; (parse-method-or-spec spec)
381 ; (declare (ignore gf))
382 ; (compile name (method-function method))
383 ; (setf (method-function method) (symbol-function name))))
384
385 (defmacro undefmethod (&rest args)
386 #+(or (not :lucid) :lcl3.0)
387 (declare (arglist name {method-qualifier}* specializers))
388 `(undefmethod-1 ',args))
389
390 (defun undefmethod-1 (args)
391 (multiple-value-bind (gf method)
392 (parse-method-or-spec args)
393 (when (and gf method)
394 (remove-method gf method)
395 method)))
396
397
398 (pushnew :pcl *features*)
399 (pushnew :portable-commonloops *features*)
400 (pushnew :pcl-structures *features*)
401
402 #+cmu
403 (when (find-package "OLD-PCL")
404 (setf (symbol-function 'old-pcl::print-object)
405 (symbol-function 'pcl::print-object)))
406

  ViewVC Help
Powered by ViewVC 1.1.5