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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Mon Aug 26 02:23:13 2002 UTC (11 years, 8 months ago) by pmai
Branch: MAIN
CVS Tags: LINKAGE_TABLE, PRE_LINKAGE_TABLE, UNICODE-BASE
Branch point for: UNICODE-BRANCH
Changes since 1.14: +5 -5 lines
Huge patch by Gerd Moellmann that removes PCL::ITERATE and PCL::GATHER*
in favor of normal CL constructs.  In a similar vein to SBCL, this patch
also replaces all uses of #'(lambda ...) by just (lambda ...), and
removes now-dated looking quotes in front of self-evaluating objects,
like keywords and t/nil.  The patch has been slightly frobbed by me,
to correct a couple of slight oversights, and make more effective use
of the loop facility in a number of places.
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
28 (ext:file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.15 2002/08/26 02:23:13 pmai Exp $")
30 ;;;
31 ;;; Basic environmental stuff.
32 ;;;
33
34 (in-package :pcl)
35
36 ;;;
37 ;;;
38 ;;;
39
40 ;;; ANSI compliance wants default structure printer to use #S(...) format.
41 (defmethod print-object ((object structure-object) stream)
42 (lisp::default-structure-print object stream 0))
43
44 (defgeneric describe-object (object stream))
45
46 (defmethod describe-object (object stream)
47 (describe object stream))
48
49 (defmethod describe-object ((object slot-object) stream)
50 (let* ((class (class-of object))
51 (slotds (slots-to-inspect class object))
52 (max-slot-name-length 0)
53 (instance-slotds ())
54 (class-slotds ())
55 (other-slotds ()))
56 (flet ((adjust-slot-name-length (name)
57 (setq max-slot-name-length
58 (max max-slot-name-length
59 (length (the string (symbol-name name))))))
60 (describe-slot (name value &optional (allocation () alloc-p))
61 (if alloc-p
62 (format stream
63 "~% ~A ~S ~VT ~S"
64 name allocation (+ max-slot-name-length 7) value)
65 (format stream
66 "~% ~A~VT ~S"
67 name max-slot-name-length value))))
68 ;; Figure out a good width for the slot-name column.
69 (dolist (slotd slotds)
70 (adjust-slot-name-length (slot-definition-name slotd))
71 (case (slot-definition-allocation slotd)
72 (:instance (push slotd instance-slotds))
73 (:class (push slotd class-slotds))
74 (otherwise (push slotd other-slotds))))
75 (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
76 (format stream "~%~S is an instance of class ~S:" object class)
77
78 (when instance-slotds
79 (format stream "~% The following slots have :INSTANCE allocation:")
80 (dolist (slotd (nreverse instance-slotds))
81 (describe-slot (slot-definition-name slotd)
82 (slot-value-or-default object (slot-definition-name slotd)))))
83
84 (when class-slotds
85 (format stream "~% The following slots have :CLASS allocation:")
86 (dolist (slotd (nreverse class-slotds))
87 (describe-slot (slot-definition-name slotd)
88 (slot-value-or-default object (slot-definition-name slotd)))))
89
90 (when other-slotds
91 (format stream "~% The following slots have allocation as shown:")
92 (dolist (slotd (nreverse other-slotds))
93 (describe-slot (slot-definition-name slotd)
94 (slot-value-or-default object (slot-definition-name slotd))
95 (slot-definition-allocation slotd))))
96 (values))))
97
98 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
99 (class-slots class))
100
101 (defvar *describe-metaobjects-as-objects-p* nil)
102
103 (defmethod describe-object ((fun standard-generic-function) stream)
104 (format stream "~A is a generic function.~%" fun)
105 (format stream "Its arguments are:~% ~S~%"
106 (generic-function-pretty-arglist fun))
107 (format stream "Its methods are:")
108 (dolist (meth (generic-function-methods fun))
109 (format stream "~2% ~{~S ~}~:S =>~%"
110 (method-qualifiers meth)
111 (unparse-specializers meth))
112 (describe-object (or (method-fast-function meth)
113 (method-function meth))
114 stream))
115 (when *describe-metaobjects-as-objects-p*
116 (call-next-method)))
117
118 ;;;
119 ;;;
120 ;;;
121 (defmethod describe-object ((class class) stream)
122 (flet ((pretty-class (c) (or (class-name c) c)))
123 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
124 (ft "~&~S is a class, it is an instance of ~S.~%"
125 class (pretty-class (class-of class)))
126 (let ((name (class-name class)))
127 (if name
128 (if (eq class (find-class name nil))
129 (ft "Its proper name is ~S.~%" name)
130 (ft "Its name is ~S, but this is not a proper name.~%" name))
131 (ft "It has no name (the name is NIL).~%")))
132 (ft "The direct superclasses are: ~:S, and the direct~%~
133 subclasses are: ~:S. The class precedence list is:~%~S~%~
134 There are ~D methods specialized for this class."
135 (mapcar #'pretty-class (class-direct-superclasses class))
136 (mapcar #'pretty-class (class-direct-subclasses class))
137 (mapcar #'pretty-class (class-precedence-list class))
138 (length (specializer-direct-methods class)))))
139 (when *describe-metaobjects-as-objects-p*
140 (call-next-method)))
141
142 (defun describe-package (object stream)
143 (unless (packagep object) (setq object (find-package object)))
144 (format stream "~&~S is a ~S.~%" object (type-of object))
145 (let ((nick (package-nicknames object)))
146 (when nick
147 (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
148 (butlast nick) (first (last nick)))))
149 (let* ((internal (lisp::package-internal-symbols object))
150 (internal-count (- (lisp::package-hashtable-size internal)
151 (lisp::package-hashtable-free internal)))
152 (external (lisp::package-external-symbols object))
153 (external-count (- (lisp::package-hashtable-size external)
154 (lisp::package-hashtable-free external))))
155 (format stream "It has ~D internal and ~D external symbols (~D total).~%"
156 internal-count external-count (+ internal-count external-count)))
157 (let ((used (package-use-list object)))
158 (when used
159 (format stream "It uses the packages ~{~S~^, ~}.~%"
160 (mapcar #'package-name used))))
161 (let ((users (package-used-by-list object)))
162 (when users
163 (format stream "It is used by the packages ~{~S~^, ~}.~%"
164 (mapcar #'package-name users)))))
165
166 (defmethod describe-object ((object package) stream)
167 (describe-package object stream))
168
169 (defmethod describe-object ((object hash-table) stream)
170 (format stream "~&~S is an ~a hash table."
171 object
172 (lisp::hash-table-test object))
173 (format stream "~&Its size is ~d buckets."
174 (lisp::hash-table-size object))
175 (format stream "~&Its rehash-size is ~d."
176 (lisp::hash-table-rehash-size object))
177 (format stream "~&Its rehash-threshold is ~d."
178 (hash-table-rehash-threshold object))
179 (format stream "~&It currently holds ~d entries."
180 (lisp::hash-table-number-entries object)))
181
182
183
184 ;;;
185 ;;; trace-method and untrace-method accept method specs as arguments. A
186 ;;; method-spec should be a list like:
187 ;;; (<generic-function-spec> qualifiers* (specializers*))
188 ;;; where <generic-function-spec> should be either a symbol or a list
189 ;;; of (SETF <symbol>).
190 ;;;
191 ;;; For example, to trace the method defined by:
192 ;;;
193 ;;; (defmethod foo ((x spaceship)) 'ss)
194 ;;;
195 ;;; You should say:
196 ;;;
197 ;;; (trace-method '(foo (spaceship)))
198 ;;;
199 ;;; You can also provide a method object in the place of the method
200 ;;; spec, in which case that method object will be traced.
201 ;;;
202 ;;; For untrace-method, if an argument is given, that method is untraced.
203 ;;; If no argument is given, all traced methods are untraced.
204 ;;;
205 (defclass traced-method (method)
206 ((method :initarg :method)
207 (function :initarg :function
208 :reader method-function)
209 (generic-function :initform nil
210 :accessor method-generic-function)))
211
212 (defmethod method-lambda-list ((m traced-method))
213 (with-slots (method) m (method-lambda-list method)))
214
215 (defmethod method-specializers ((m traced-method))
216 (with-slots (method) m (method-specializers method)))
217
218 (defmethod method-qualifiers ((m traced-method))
219 (with-slots (method) m (method-qualifiers method)))
220
221 (defmethod accessor-method-slot-name ((m traced-method))
222 (with-slots (method) m (accessor-method-slot-name method)))
223
224 (defvar *traced-methods* ())
225
226 (defun trace-method (spec &rest options)
227 #+copy-&rest-arg (setq options (copy-list options))
228 (multiple-value-bind (gf omethod name)
229 (parse-method-or-spec spec)
230 (let* ((tfunction (trace-method-internal (method-function omethod)
231 name
232 options))
233 (tmethod (make-instance 'traced-method
234 :method omethod
235 :function tfunction)))
236 (remove-method gf omethod)
237 (add-method gf tmethod)
238 (pushnew tmethod *traced-methods*)
239 tmethod)))
240
241 (defun untrace-method (&optional spec)
242 (flet ((untrace-1 (m)
243 (let ((gf (method-generic-function m)))
244 (when gf
245 (remove-method gf m)
246 (add-method gf (slot-value m 'method))
247 (setq *traced-methods* (remove m *traced-methods*))))))
248 (if (not (null spec))
249 (multiple-value-bind (gf method)
250 (parse-method-or-spec spec)
251 (declare (ignore gf))
252 (if (memq method *traced-methods*)
253 (untrace-1 method)
254 (error "~S is not a traced method?" method)))
255 (dolist (m *traced-methods*) (untrace-1 m)))))
256
257 (defun trace-method-internal (ofunction name options)
258 (eval `(untrace ,name))
259 (setf (symbol-function name) ofunction)
260 (eval `(trace ,name ,@options))
261 (symbol-function name))
262
263
264
265
266 ;(defun compile-method (spec)
267 ; (multiple-value-bind (gf method name)
268 ; (parse-method-or-spec spec)
269 ; (declare (ignore gf))
270 ; (compile name (method-function method))
271 ; (setf (method-function method) (symbol-function name))))
272
273 (defmacro undefmethod (&rest args)
274 (declare (arglist name {method-qualifier}* specializers))
275 `(undefmethod-1 ',args))
276
277 (defun undefmethod-1 (args)
278 (multiple-value-bind (gf method)
279 (parse-method-or-spec args)
280 (when (and gf method)
281 (remove-method gf method)
282 method)))
283
284
285 (pushnew :pcl *features*)
286 (pushnew :portable-commonloops *features*)
287 (pushnew :pcl-structures *features*)
288
289 (when (find-package "OLD-PCL")
290 (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
291 (symbol-function 'pcl::print-object)))
292
293
294 ;;;; MAKE-LOAD-FORM
295
296 (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
297
298 (defgeneric make-load-form (object &optional environment))
299
300 (defmethod make-load-form ((object structure-object) &optional environment)
301 (declare (ignore environment))
302 (kernel:make-structure-load-form object))
303
304 (defmethod make-load-form ((object wrapper) &optional env)
305 (declare (ignore env))
306 (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
307 (unless pname
308 (error "Can't dump wrapper for anonymous class:~% ~S"
309 (kernel:layout-class object)))
310 `(kernel:class-layout (lisp:find-class ',pname))))
311
312 (defun make-load-form-saving-slots (object &key slot-names environment)
313 (declare (ignore environment))
314 (when slot-names
315 (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
316 slots:~% ~S"
317 object))
318 :just-dump-it-normally)
319
320
321 ;;; The following are hacks to deal with CMU CL having two different CLASS
322 ;;; classes.
323 ;;;
324 (defun coerce-to-pcl-class (class)
325 (if (typep class 'lisp:class)
326 (or (kernel:class-pcl-class class)
327 (find-structure-class (lisp:class-name class)))
328 class))
329
330 (defmethod make-instance ((class lisp:class) &rest stuff)
331 (apply #'make-instance (coerce-to-pcl-class class) stuff))
332 (defmethod change-class (instance (class lisp:class) &rest initargs)
333 (apply #'change-class instance (coerce-to-pcl-class class) initargs))
334
335 (macrolet ((frob (&rest names)
336 `(progn
337 ,@(mapcar (lambda (name)
338 `(defmethod ,name ((class lisp:class))
339 (funcall #',name
340 (coerce-to-pcl-class class))))
341 names))))
342 (frob
343 class-direct-slots
344 class-prototype
345 class-precedence-list
346 class-direct-default-initargs
347 class-direct-superclasses
348 compute-class-precedence-list
349 class-default-initargs class-finalized-p
350 class-direct-subclasses class-slots
351 make-instances-obsolete))

  ViewVC Help
Powered by ViewVC 1.1.5