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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18.2.3 - (hide annotations)
Wed Mar 19 16:33:23 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.18.2.2: +10 -10 lines
	* pcl/*.lisp: Changes for lisp:class = pcl:class.
1 wlott 1.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 pw 1.12
28 dtc 1.10 (ext:file-comment
29 gerd 1.18.2.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.18.2.3 2003/03/19 16:33:23 gerd Exp $")
30 dtc 1.10 ;;;
31 wlott 1.1 ;;; Basic environmental stuff.
32     ;;;
33    
34 phg 1.7 (in-package :pcl)
35 wlott 1.1
36     ;;;
37     ;;;
38     ;;;
39 pw 1.13
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 pmai 1.18
44     ;;; Condition printing
45     (defmethod print-object ((object condition) stream)
46     (conditions::real-print-condition object stream))
47 wlott 1.1
48     (defgeneric describe-object (object stream))
49    
50     (defmethod describe-object (object stream)
51 pw 1.8 (describe object stream))
52 wlott 1.1
53 ram 1.4 (defmethod describe-object ((object slot-object) stream)
54 ram 1.6 (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 wlott 1.1 (flet ((adjust-slot-name-length (name)
61 ram 1.6 (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 wlott 1.1 ;; Figure out a good width for the slot-name column.
73 ram 1.6 (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 gerd 1.18.2.1 (:class (push slotd class-slotds))
78 ram 1.6 (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 wlott 1.1
82     (when instance-slotds
83 ram 1.6 (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 wlott 1.1
88     (when class-slotds
89 ram 1.6 (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 wlott 1.1
94 ram 1.6 (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 wlott 1.1 (values))))
101 ram 1.2
102 ram 1.4 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
103     (class-slots class))
104    
105 ram 1.6 (defvar *describe-metaobjects-as-objects-p* nil)
106 ram 1.5
107 gerd 1.17 (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 ram 1.2
126 wlott 1.1 ;;;
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 gerd 1.17 (ft "~&~@<~S is a class, it is an instance of ~S.~@:>~%"
133 ram 1.6 class (pretty-class (class-of class)))
134 wlott 1.1 (let ((name (class-name class)))
135 ram 1.6 (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 wlott 1.1 (ft "The direct superclasses are: ~:S, and the direct~%~
141 ram 1.6 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 gerd 1.17 (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 gerd 1.18.2.1 (ft " ~a, documentation ~s~%" name doc))))
153 ram 1.6 (when *describe-metaobjects-as-objects-p*
154     (call-next-method)))
155 wlott 1.1
156 ram 1.6 (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 pw 1.12 (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 ram 1.6 (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 pw 1.9 (let ((users (package-used-by-list object)))
176 ram 1.6 (when users
177     (format stream "It is used by the packages ~{~S~^, ~}.~%"
178     (mapcar #'package-name users)))))
179 wlott 1.1
180 ram 1.6 (defmethod describe-object ((object package) stream)
181     (describe-package object stream))
182 ram 1.5
183 ram 1.6 (defmethod describe-object ((object hash-table) stream)
184 phg 1.7 (format stream "~&~S is an ~a hash table."
185     object
186 pw 1.12 (lisp::hash-table-test object))
187 phg 1.7 (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 ram 1.6 (format stream "~&Its rehash-threshold is ~d."
192 pw 1.8 (hash-table-rehash-threshold object))
193 ram 1.6 (format stream "~&It currently holds ~d entries."
194     (lisp::hash-table-number-entries object)))
195 ram 1.5
196 ram 1.6
197    
198 wlott 1.1 ;;;
199 gerd 1.18.2.1 ;;; Value is a list of all (possible) method function names of
200     ;;; generic function GF.
201     ;;;
202     (defun debug::all-method-function-names (gf)
203     (loop with gf = (if (symbolp gf) (gdefinition gf) gf)
204     for method in (generic-function-methods gf)
205     as name = (nth-value 2 (parse-method-or-spec method))
206     collect name
207     collect (list* 'fast-method (cdr name))))
208    
209     (defun debug::all-method-functions-in-package (pkg)
210     (let ((gfs ()))
211     (map-all-generic-functions
212     (lambda (gf)
213     (multiple-value-bind (valid base)
214     (ext:valid-function-name-p (generic-function-name gf))
215     (declare (ignore valid))
216     (when (and (symbolp base)
217     (eq (symbol-package base) pkg))
218     (push gf gfs)))))
219     (loop for gf in gfs nconc (debug::all-method-function-names gf))))
220    
221     ;;;
222     ;;; Reinitialize method function NAME from its fdefinitions.
223     ;;;
224     (defun profile::reinitialize-method-function (name)
225     (multiple-value-bind (gf method method-name)
226     (parse-method-or-spec (cdr name))
227     (declare (ignore gf method-name))
228     (with-slots (function fast-function) method
229     (ecase (car name)
230     (method
231     (when function
232     (setq function (fdefinition name))))
233     (fast-method
234     (when fast-function
235     (let* ((new (fdefinition name))
236     (plist (method-function-plist new)))
237     ;;
238     ;; This is necessary so that, for instance, the arg-info of
239     ;; the function can be determined.
240     (unless plist
241     (setf (method-function-plist new)
242     (method-function-plist fast-function)))
243     (setq fast-function new))))))))
244 wlott 1.1
245     (defmacro undefmethod (&rest args)
246     `(undefmethod-1 ',args))
247    
248     (defun undefmethod-1 (args)
249     (multiple-value-bind (gf method)
250     (parse-method-or-spec args)
251     (when (and gf method)
252     (remove-method gf method)
253     method)))
254    
255 ram 1.4
256     (pushnew :pcl *features*)
257     (pushnew :portable-commonloops *features*)
258     (pushnew :pcl-structures *features*)
259 gerd 1.18.2.1 (pushnew :gerds-pcl *features*)
260 pw 1.8
261     (when (find-package "OLD-PCL")
262     (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
263     (symbol-function 'pcl::print-object)))
264    
265    
266     ;;;; MAKE-LOAD-FORM
267    
268     (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
269    
270 pw 1.12 (defgeneric make-load-form (object &optional environment))
271    
272     (defmethod make-load-form ((object structure-object) &optional environment)
273     (declare (ignore environment))
274     (kernel:make-structure-load-form object))
275    
276     (defmethod make-load-form ((object wrapper) &optional env)
277     (declare (ignore env))
278     (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
279     (unless pname
280 gerd 1.18.2.1 (error "~@<Can't dump wrapper for anonymous class ~S.~@:>"
281 pw 1.12 (kernel:layout-class object)))
282 gerd 1.18.2.3 `(kernel:%class-layout (kernel::find-class ',pname))))
283 pw 1.12
284     (defun make-load-form-saving-slots (object &key slot-names environment)
285     (declare (ignore environment))
286     (when slot-names
287 gerd 1.18.2.1 (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>"
288     :slot-names 'make-load-form object))
289 pw 1.12 :just-dump-it-normally)
290 pw 1.8
291    
292     ;;; The following are hacks to deal with CMU CL having two different CLASS
293     ;;; classes.
294     ;;;
295     (defun coerce-to-pcl-class (class)
296 gerd 1.18.2.3 (if (typep class 'kernel::class)
297     (or (kernel:%class-pcl-class class)
298     (find-structure-class (kernel:%class-name class)))
299 pw 1.8 class))
300    
301 gerd 1.18.2.2 (eval-when (compile)
302     (setq *inhibit-class-name-canonicalization* t))
303    
304 gerd 1.18.2.3 (defmethod make-instance ((class kernel::class) &rest stuff)
305 pw 1.12 (apply #'make-instance (coerce-to-pcl-class class) stuff))
306 gerd 1.18.2.3 (defmethod change-class (instance (class kernel::class) &rest initargs)
307 pmai 1.14 (apply #'change-class instance (coerce-to-pcl-class class) initargs))
308 pw 1.8
309     (macrolet ((frob (&rest names)
310     `(progn
311 pmai 1.15 ,@(mapcar (lambda (name)
312 gerd 1.18.2.3 `(defmethod ,name ((class kernel::class))
313     (funcall #',name
314     (coerce-to-pcl-class class))))
315 pw 1.8 names))))
316 gerd 1.18.2.2 (frob class-direct-slots
317     class-prototype
318     class-precedence-list
319     class-direct-default-initargs
320     class-direct-superclasses
321     compute-class-precedence-list
322     class-default-initargs class-finalized-p
323     class-direct-subclasses class-slots
324     make-instances-obsolete))
325    
326     (eval-when (compile)
327     (setq *inhibit-class-name-canonicalization* nil))
328    
329    
330    

  ViewVC Help
Powered by ViewVC 1.1.5