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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7.1.3 - (show annotations) (vendor branch)
Mon Dec 20 14:28:31 1993 UTC (20 years, 4 months ago) by ram
Branch: cmu
Changes since 1.7.1.2: +1 -1 lines
In export, make-load-form-dumping-slots => make-load-form-saving-slots.
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))

  ViewVC Help
Powered by ViewVC 1.1.5