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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Sat Feb 15 23:41:31 2003 UTC (11 years, 2 months ago) by pmai
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.17: +5 -1 lines
Entomotomy Bug: condition-reporting-not-via-print-object

This change causes condition printing (generally) and condition reporting
(in particular) to go via print-object, once PCL is loaded, as required
by ANSI.  Note that the :report option of define-condition still goes
through the old non-print-object mechanism (which is allowed by ANSI),
but that this mechanism is now invoked via a default method of print-object
specialized on condition.  Hence user-defined methods on print-object
are now effective, instead of being bypassed through the old mechanism.
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.18 2003/02/15 23:41:31 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 ;;; Condition printing
45 (defmethod print-object ((object condition) stream)
46 (conditions::real-print-condition object stream))
47
48 (defgeneric describe-object (object stream))
49
50 (defmethod describe-object (object stream)
51 (describe object stream))
52
53 (defmethod describe-object ((object slot-object) stream)
54 (let* ((class (class-of object))
55 (slotds (slots-to-inspect class object))
56 (max-slot-name-length 0)
57 (instance-slotds ())
58 (class-slotds ())
59 (other-slotds ()))
60 (flet ((adjust-slot-name-length (name)
61 (setq max-slot-name-length
62 (max max-slot-name-length
63 (length (the string (symbol-name name))))))
64 (describe-slot (name value &optional (allocation () alloc-p))
65 (if alloc-p
66 (format stream
67 "~% ~A ~S ~VT ~S"
68 name allocation (+ max-slot-name-length 7) value)
69 (format stream
70 "~% ~A~VT ~S"
71 name max-slot-name-length value))))
72 ;; Figure out a good width for the slot-name column.
73 (dolist (slotd slotds)
74 (adjust-slot-name-length (slot-definition-name slotd))
75 (case (slot-definition-allocation slotd)
76 (:instance (push slotd instance-slotds))
77 (:class (push slotd class-slotds))
78 (otherwise (push slotd other-slotds))))
79 (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
80 (format stream "~%~S is an instance of class ~S:" object class)
81
82 (when instance-slotds
83 (format stream "~% The following slots have :INSTANCE allocation:")
84 (dolist (slotd (nreverse instance-slotds))
85 (describe-slot (slot-definition-name slotd)
86 (slot-value-or-default object (slot-definition-name slotd)))))
87
88 (when class-slotds
89 (format stream "~% The following slots have :CLASS allocation:")
90 (dolist (slotd (nreverse class-slotds))
91 (describe-slot (slot-definition-name slotd)
92 (slot-value-or-default object (slot-definition-name slotd)))))
93
94 (when other-slotds
95 (format stream "~% The following slots have allocation as shown:")
96 (dolist (slotd (nreverse other-slotds))
97 (describe-slot (slot-definition-name slotd)
98 (slot-value-or-default object (slot-definition-name slotd))
99 (slot-definition-allocation slotd))))
100 (values))))
101
102 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
103 (class-slots class))
104
105 (defvar *describe-metaobjects-as-objects-p* nil)
106
107 (defmethod describe-object ((gf standard-generic-function) stream)
108 (format stream "~A is a generic function.~%" gf)
109 (let* ((gf-name (generic-function-name gf))
110 (doc (documentation gf-name 'function)))
111 (format stream "Its arguments are:~% ~S~%"
112 (generic-function-pretty-arglist gf))
113 (when doc
114 (format stream "Generic function documentation:~% ~s~%" doc))
115 (format stream "Its methods are:~%")
116 (loop for method in (generic-function-methods gf) and i from 1
117 as doc = (plist-value method 'documentation) do
118 (format stream " ~d: ~a ~@[~{~s ~}~]~:s~%"
119 i gf-name (method-qualifiers method)
120 (unparse-specializers method))
121 (when doc
122 (format stream " Method documentation: ~s~%" doc)))
123 (when *describe-metaobjects-as-objects-p*
124 (call-next-method))))
125
126 ;;;
127 ;;;
128 ;;;
129 (defmethod describe-object ((class class) stream)
130 (flet ((pretty-class (c) (or (class-name c) c)))
131 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
132 (ft "~&~@<~S is a class, it is an instance of ~S.~@:>~%"
133 class (pretty-class (class-of class)))
134 (let ((name (class-name class)))
135 (if name
136 (if (eq class (find-class name nil))
137 (ft "Its proper name is ~S.~%" name)
138 (ft "Its name is ~S, but this is not a proper name.~%" name))
139 (ft "It has no name (the name is NIL).~%")))
140 (ft "The direct superclasses are: ~:S, and the direct~%~
141 subclasses are: ~:S. The class precedence list is:~%~S~%~
142 There are ~D methods specialized for this class."
143 (mapcar #'pretty-class (class-direct-superclasses class))
144 (mapcar #'pretty-class (class-direct-subclasses class))
145 (mapcar #'pretty-class (class-precedence-list class))
146 (length (specializer-direct-methods class)))
147 (loop initially
148 (ft "~&Its direct slots are:~%")
149 for slotd in (class-direct-slots class)
150 as name = (slot-definition-name slotd)
151 as doc = (slot-value slotd 'documentation) do
152 (ft " ~a~@[, documentation ~s~]~%" name doc))))
153 (when *describe-metaobjects-as-objects-p*
154 (call-next-method)))
155
156 (defun describe-package (object stream)
157 (unless (packagep object) (setq object (find-package object)))
158 (format stream "~&~S is a ~S.~%" object (type-of object))
159 (let ((nick (package-nicknames object)))
160 (when nick
161 (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
162 (butlast nick) (first (last nick)))))
163 (let* ((internal (lisp::package-internal-symbols object))
164 (internal-count (- (lisp::package-hashtable-size internal)
165 (lisp::package-hashtable-free internal)))
166 (external (lisp::package-external-symbols object))
167 (external-count (- (lisp::package-hashtable-size external)
168 (lisp::package-hashtable-free external))))
169 (format stream "It has ~D internal and ~D external symbols (~D total).~%"
170 internal-count external-count (+ internal-count external-count)))
171 (let ((used (package-use-list object)))
172 (when used
173 (format stream "It uses the packages ~{~S~^, ~}.~%"
174 (mapcar #'package-name used))))
175 (let ((users (package-used-by-list object)))
176 (when users
177 (format stream "It is used by the packages ~{~S~^, ~}.~%"
178 (mapcar #'package-name users)))))
179
180 (defmethod describe-object ((object package) stream)
181 (describe-package object stream))
182
183 (defmethod describe-object ((object hash-table) stream)
184 (format stream "~&~S is an ~a hash table."
185 object
186 (lisp::hash-table-test object))
187 (format stream "~&Its size is ~d buckets."
188 (lisp::hash-table-size object))
189 (format stream "~&Its rehash-size is ~d."
190 (lisp::hash-table-rehash-size object))
191 (format stream "~&Its rehash-threshold is ~d."
192 (hash-table-rehash-threshold object))
193 (format stream "~&It currently holds ~d entries."
194 (lisp::hash-table-number-entries object)))
195
196
197
198 ;;;
199 ;;; trace-method and untrace-method accept method specs as arguments. A
200 ;;; method-spec should be a list like:
201 ;;; (<generic-function-spec> qualifiers* (specializers*))
202 ;;; where <generic-function-spec> should be either a symbol or a list
203 ;;; of (SETF <symbol>).
204 ;;;
205 ;;; For example, to trace the method defined by:
206 ;;;
207 ;;; (defmethod foo ((x spaceship)) 'ss)
208 ;;;
209 ;;; You should say:
210 ;;;
211 ;;; (trace-method '(foo (spaceship)))
212 ;;;
213 ;;; You can also provide a method object in the place of the method
214 ;;; spec, in which case that method object will be traced.
215 ;;;
216 ;;; For untrace-method, if an argument is given, that method is untraced.
217 ;;; If no argument is given, all traced methods are untraced.
218 ;;;
219 (defclass traced-method (method)
220 ((method :initarg :method)
221 (function :initarg :function
222 :reader method-function)
223 (generic-function :initform nil
224 :accessor method-generic-function)))
225
226 (defmethod method-lambda-list ((m traced-method))
227 (with-slots (method) m (method-lambda-list method)))
228
229 (defmethod method-specializers ((m traced-method))
230 (with-slots (method) m (method-specializers method)))
231
232 (defmethod method-qualifiers ((m traced-method))
233 (with-slots (method) m (method-qualifiers method)))
234
235 (defmethod accessor-method-slot-name ((m traced-method))
236 (with-slots (method) m (accessor-method-slot-name method)))
237
238 (defvar *traced-methods* ())
239
240 (defun trace-method (spec &rest options)
241 (multiple-value-bind (gf omethod name)
242 (parse-method-or-spec spec)
243 (let* ((tfunction (trace-method-internal (method-function omethod)
244 name
245 options))
246 (tmethod (make-instance 'traced-method
247 :method omethod
248 :function tfunction)))
249 (remove-method gf omethod)
250 (add-method gf tmethod)
251 (pushnew tmethod *traced-methods*)
252 tmethod)))
253
254 (defun untrace-method (&optional spec)
255 (flet ((untrace-1 (m)
256 (let ((gf (method-generic-function m)))
257 (when gf
258 (remove-method gf m)
259 (add-method gf (slot-value m 'method))
260 (setq *traced-methods* (remove m *traced-methods*))))))
261 (if (not (null spec))
262 (multiple-value-bind (gf method)
263 (parse-method-or-spec spec)
264 (declare (ignore gf))
265 (if (memq method *traced-methods*)
266 (untrace-1 method)
267 (error "~S is not a traced method?" method)))
268 (dolist (m *traced-methods*) (untrace-1 m)))))
269
270 (defun trace-method-internal (ofunction name options)
271 (eval `(untrace ,name))
272 (setf (symbol-function name) ofunction)
273 (eval `(trace ,name ,@options))
274 (symbol-function name))
275
276
277
278
279 ;(defun compile-method (spec)
280 ; (multiple-value-bind (gf method name)
281 ; (parse-method-or-spec spec)
282 ; (declare (ignore gf))
283 ; (compile name (method-function method))
284 ; (setf (method-function method) (symbol-function name))))
285
286 (defmacro undefmethod (&rest args)
287 (declare (arglist name {method-qualifier}* specializers))
288 `(undefmethod-1 ',args))
289
290 (defun undefmethod-1 (args)
291 (multiple-value-bind (gf method)
292 (parse-method-or-spec args)
293 (when (and gf method)
294 (remove-method gf method)
295 method)))
296
297
298 (pushnew :pcl *features*)
299 (pushnew :portable-commonloops *features*)
300 (pushnew :pcl-structures *features*)
301
302 (when (find-package "OLD-PCL")
303 (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
304 (symbol-function 'pcl::print-object)))
305
306
307 ;;;; MAKE-LOAD-FORM
308
309 (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
310
311 (defgeneric make-load-form (object &optional environment))
312
313 (defmethod make-load-form ((object structure-object) &optional environment)
314 (declare (ignore environment))
315 (kernel:make-structure-load-form object))
316
317 (defmethod make-load-form ((object wrapper) &optional env)
318 (declare (ignore env))
319 (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
320 (unless pname
321 (error "Can't dump wrapper for anonymous class:~% ~S"
322 (kernel:layout-class object)))
323 `(kernel:class-layout (lisp:find-class ',pname))))
324
325 (defun make-load-form-saving-slots (object &key slot-names environment)
326 (declare (ignore environment))
327 (when slot-names
328 (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
329 slots:~% ~S"
330 object))
331 :just-dump-it-normally)
332
333
334 ;;; The following are hacks to deal with CMU CL having two different CLASS
335 ;;; classes.
336 ;;;
337 (defun coerce-to-pcl-class (class)
338 (if (typep class 'lisp:class)
339 (or (kernel:class-pcl-class class)
340 (find-structure-class (lisp:class-name class)))
341 class))
342
343 (defmethod make-instance ((class lisp:class) &rest stuff)
344 (apply #'make-instance (coerce-to-pcl-class class) stuff))
345 (defmethod change-class (instance (class lisp:class) &rest initargs)
346 (apply #'change-class instance (coerce-to-pcl-class class) initargs))
347
348 (macrolet ((frob (&rest names)
349 `(progn
350 ,@(mapcar (lambda (name)
351 `(defmethod ,name ((class lisp:class))
352 (funcall #',name
353 (coerce-to-pcl-class class))))
354 names))))
355 (frob
356 class-direct-slots
357 class-prototype
358 class-precedence-list
359 class-direct-default-initargs
360 class-direct-superclasses
361 compute-class-precedence-list
362 class-default-initargs class-finalized-p
363 class-direct-subclasses class-slots
364 make-instances-obsolete))

  ViewVC Help
Powered by ViewVC 1.1.5