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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Sun May 4 13:11:21 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.20: +3 -3 lines
	Code cleanup.  Use EXTENSIONS package to reduce clutter.

	* src/pcl/defsys.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/pkg.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/*.lisp: Remove ext: prefixes.

	* src/pcl/low.lisp (symbolicate*): Renamed from symbolicate.
	* src/pcl/std-class.lisp (shared-initialize):
	* src/pcl/defs.lisp (get-built-in-class-symbol)
	(get-built-in-wrapper-symbol):
	* src/pcl/braid.lisp (initial-classes-and-wrappers)
	(bootstrap-meta-braid): Use symbolicate*.

	* src/pcl/macros.lisp (dolist-carefully): Removed.
	(true, false, zero): Moved to defclass.lisp.
	(printing-random-thing-internal): Removed.
	(printing-random-thing): Removed.
	(rassq): Removed.
	(*keyword-package*): Removed.
	(make-keyword): Removed; import from cl.
	(memq, delq, assq): Macros removed, import from ext.
	(get-declaration): Moved to boot.lisp, where it's used.

	* src/pcl/boot.lisp (get-declaration): Moved here from
	macros.lisp.

	* src/pcl/methods.lisp (named-object-print-function, print-object):
	* src/pcl/low.lisp (print-std-instance):
	* src/pcl/dfun.lisp (print-dfun-info):
	* src/pcl/cache.lisp (print-cache, print-wrapper):
	* src/pcl/boot.lisp (make-early-gf):
	Use print-unreadable-object instead of printing-random-thing.

	* src/pcl/defclass.lisp (true, false, zero): Moved here from
	macros.lisp.

	* src/pcl/methods.lisp (legal-qualifiers-p)
	(legal-specializers-p): Use dolist.
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 (file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.21 2003/05/04 13:11:21 gerd 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 (defun method-specialized-lambda-list (method)
108 (loop with specializers = (unparse-specializers method)
109 for elt in (method-lambda-list method)
110 collect (if specializers
111 (list elt (pop specializers))
112 elt)))
113
114 (defmethod describe-object ((gf standard-generic-function) stream)
115 (format stream "~A is a generic function.~%" gf)
116 (let* ((gf-name (generic-function-name gf))
117 (doc (documentation gf-name 'function)))
118 (format stream "Its lambda-list is:~% ~S~%"
119 (generic-function-lambda-list gf))
120 (when doc
121 (format stream "Generic function documentation:~% ~s~%" doc))
122 (format stream "Its methods are:~%")
123 (loop for method in (generic-function-methods gf) and i from 1
124 as doc = (plist-value method 'documentation) do
125 (format stream " ~d: ~a ~@[~{~s ~}~]~:s~%"
126 i gf-name (method-qualifiers method)
127 (method-specialized-lambda-list method))
128 (when doc
129 (format stream " Method documentation: ~s~%" doc)))
130 (when *describe-metaobjects-as-objects-p*
131 (call-next-method))))
132
133 ;;;
134 ;;;
135 ;;;
136 (defmethod describe-object ((class class) stream)
137 (flet ((pretty-class (c) (or (class-name c) c)))
138 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
139 (ft "~&~@<~S is a class, it is an instance of ~S.~@:>~%"
140 class (pretty-class (class-of class)))
141 (let ((name (class-name class)))
142 (if name
143 (if (eq class (find-class name nil))
144 (ft "Its proper name is ~S.~%" name)
145 (ft "Its name is ~S, but this is not a proper name.~%" name))
146 (ft "It has no name (the name is NIL).~%")))
147 (ft "The direct superclasses are: ~:S, and the direct~%~
148 subclasses are: ~:S. The class precedence list is:~%~S~%~
149 There are ~D methods specialized for this class."
150 (mapcar #'pretty-class (class-direct-superclasses class))
151 (mapcar #'pretty-class (class-direct-subclasses class))
152 (mapcar #'pretty-class (class-precedence-list class))
153 (length (specializer-direct-methods class)))
154 (unless (typep class 'condition-class)
155 (loop initially (ft "~&Its direct slots are:~%")
156 for slotd in (class-direct-slots class)
157 as name = (slot-definition-name slotd)
158 as doc = (slot-value slotd 'documentation) do
159 (ft " ~a, documentation ~s~%" name doc)))))
160 (when *describe-metaobjects-as-objects-p*
161 (call-next-method)))
162
163 (defun describe-package (object stream)
164 (unless (packagep object) (setq object (find-package object)))
165 (format stream "~&~S is a ~S.~%" object (type-of object))
166 (let ((nick (package-nicknames object)))
167 (when nick
168 (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
169 (butlast nick) (first (last nick)))))
170 (let* ((internal (lisp::package-internal-symbols object))
171 (internal-count (- (lisp::package-hashtable-size internal)
172 (lisp::package-hashtable-free internal)))
173 (external (lisp::package-external-symbols object))
174 (external-count (- (lisp::package-hashtable-size external)
175 (lisp::package-hashtable-free external))))
176 (format stream "It has ~D internal and ~D external symbols (~D total).~%"
177 internal-count external-count (+ internal-count external-count)))
178 (let ((used (package-use-list object)))
179 (when used
180 (format stream "It uses the packages ~{~S~^, ~}.~%"
181 (mapcar #'package-name used))))
182 (let ((users (package-used-by-list object)))
183 (when users
184 (format stream "It is used by the packages ~{~S~^, ~}.~%"
185 (mapcar #'package-name users)))))
186
187 (defmethod describe-object ((object package) stream)
188 (describe-package object stream))
189
190 (defmethod describe-object ((object hash-table) stream)
191 (format stream "~&~S is an ~a hash table."
192 object
193 (lisp::hash-table-test object))
194 (format stream "~&Its size is ~d buckets."
195 (lisp::hash-table-size object))
196 (format stream "~&Its rehash-size is ~d."
197 (lisp::hash-table-rehash-size object))
198 (format stream "~&Its rehash-threshold is ~d."
199 (hash-table-rehash-threshold object))
200 (format stream "~&It currently holds ~d entries."
201 (lisp::hash-table-number-entries object)))
202
203
204
205 ;;;
206 ;;; Value is a list of all (possible) method function names of
207 ;;; generic function GF.
208 ;;;
209 (defun debug::all-method-function-names (gf)
210 (loop with gf = (if (symbolp gf) (gdefinition gf) gf)
211 for method in (generic-function-methods gf)
212 as name = (nth-value 2 (parse-method-or-spec method))
213 collect name
214 collect (list* 'fast-method (cdr name))))
215
216 (defun debug::all-method-functions-in-package (pkg)
217 (let ((gfs ()))
218 (map-all-generic-functions
219 (lambda (gf)
220 (multiple-value-bind (valid base)
221 (valid-function-name-p (generic-function-name gf))
222 (declare (ignore valid))
223 (when (and (symbolp base)
224 (eq (symbol-package base) pkg))
225 (push gf gfs)))))
226 (loop for gf in gfs nconc (debug::all-method-function-names gf))))
227
228 ;;;
229 ;;; Reinitialize method function NAME from its fdefinitions.
230 ;;;
231 (defun profile::reinitialize-method-function (name)
232 (multiple-value-bind (gf method method-name)
233 (parse-method-or-spec (cdr name))
234 (declare (ignore gf method-name))
235 (with-slots (function fast-function) method
236 (ecase (car name)
237 (method
238 (when function
239 (setq function (fdefinition name))))
240 (fast-method
241 (when fast-function
242 (let* ((new (fdefinition name))
243 (plist (method-function-plist new)))
244 ;;
245 ;; This is necessary so that, for instance, the arg-info of
246 ;; the function can be determined.
247 (unless plist
248 (setf (method-function-plist new)
249 (method-function-plist fast-function)))
250 (setq fast-function new))))))))
251
252 (defmacro undefmethod (&rest args)
253 `(undefmethod-1 ',args))
254
255 (defun undefmethod-1 (args)
256 (multiple-value-bind (gf method)
257 (parse-method-or-spec args)
258 (when (and gf method)
259 (remove-method gf method)
260 method)))
261
262
263 (pushnew :pcl *features*)
264 (pushnew :portable-commonloops *features*)
265 (pushnew :pcl-structures *features*)
266 (pushnew :gerds-pcl *features*)
267
268 (when (find-package "OLD-PCL")
269 (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
270 (symbol-function 'pcl::print-object)))
271
272
273 ;;;; MAKE-LOAD-FORM
274
275 (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
276
277 (defgeneric make-load-form (object &optional environment))
278
279 (defmethod make-load-form ((object structure-object) &optional environment)
280 (declare (ignore environment))
281 (kernel:make-structure-load-form object))
282
283 (defmethod make-load-form ((object wrapper) &optional env)
284 (declare (ignore env))
285 (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
286 (unless pname
287 (error "~@<Can't dump wrapper for anonymous class ~S.~@:>"
288 (kernel:layout-class object)))
289 `(kernel:%class-layout (kernel::find-class ',pname))))
290
291 (defmethod make-load-form ((class class) &optional env)
292 (declare (ignore env))
293 (let ((name (class-name class)))
294 (unless (and name (eq (find-class name nil) class))
295 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
296 class))
297 `(find-class ',name)))
298
299 (defun make-load-form-saving-slots (object &key slot-names environment)
300 (declare (ignore environment))
301 (when slot-names
302 (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>"
303 :slot-names 'make-load-form object))
304 :just-dump-it-normally)
305

  ViewVC Help
Powered by ViewVC 1.1.5