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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Wed Jun 5 23:00:11 2002 UTC (11 years, 10 months ago) by pmai
Branch: MAIN
Changes since 1.13: +3 -3 lines
Make change-class ANSI-compliant, by allowing the passing of
initargs.  This fix is thanks to Espen S. Johnsen, who noted that
update-instance-for-different-class already supported the passing of
initargs, so that the fix is only to make change-class accept
initargs, and pass them along to u-i-f-d-c.  Also fixes a probably
undetected bug in change-class with a lisp::class second argument
(bogus apply in env.lisp).
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 pmai 1.14 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.14 2002/06/05 23:00:11 pmai 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 wlott 1.1
44     (defgeneric describe-object (object stream))
45    
46     (defmethod describe-object (object stream)
47 pw 1.8 (describe object stream))
48 wlott 1.1
49 ram 1.4 (defmethod describe-object ((object slot-object) stream)
50 ram 1.6 (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 wlott 1.1 (flet ((adjust-slot-name-length (name)
57 ram 1.6 (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 wlott 1.1 ;; Figure out a good width for the slot-name column.
69 ram 1.6 (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 wlott 1.1
78     (when instance-slotds
79 ram 1.6 (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 wlott 1.1
84     (when class-slotds
85 ram 1.6 (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 wlott 1.1
90 ram 1.6 (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 wlott 1.1 (values))))
97 ram 1.2
98 ram 1.4 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
99     (class-slots class))
100    
101 ram 1.6 (defvar *describe-metaobjects-as-objects-p* nil)
102 ram 1.5
103 ram 1.2 (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 ram 1.4 (generic-function-pretty-arglist fun))
107 ram 1.6 (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 ram 1.2
118 wlott 1.1 ;;;
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 ram 1.6 class (pretty-class (class-of class)))
126 wlott 1.1 (let ((name (class-name class)))
127 ram 1.6 (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 wlott 1.1 (ft "The direct superclasses are: ~:S, and the direct~%~
133 ram 1.6 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 wlott 1.1
142 ram 1.6 (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 pw 1.12 (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 ram 1.6 (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 pw 1.9 (let ((users (package-used-by-list object)))
162 ram 1.6 (when users
163     (format stream "It is used by the packages ~{~S~^, ~}.~%"
164     (mapcar #'package-name users)))))
165 wlott 1.1
166 ram 1.6 (defmethod describe-object ((object package) stream)
167     (describe-package object stream))
168 ram 1.5
169 ram 1.6 (defmethod describe-object ((object hash-table) stream)
170 phg 1.7 (format stream "~&~S is an ~a hash table."
171     object
172 pw 1.12 (lisp::hash-table-test object))
173 phg 1.7 (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 ram 1.6 (format stream "~&Its rehash-threshold is ~d."
178 pw 1.8 (hash-table-rehash-threshold object))
179 ram 1.6 (format stream "~&It currently holds ~d entries."
180     (lisp::hash-table-number-entries object)))
181 ram 1.5
182 ram 1.6
183    
184 wlott 1.1 ;;;
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 ram 1.6 (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 wlott 1.1
212 ram 1.6 (defmethod method-lambda-list ((m traced-method))
213     (with-slots (method) m (method-lambda-list method)))
214 wlott 1.1
215 ram 1.6 (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 ram 1.5 (defvar *traced-methods* ())
225 wlott 1.1
226 ram 1.6 (defun trace-method (spec &rest options)
227 phg 1.7 #+copy-&rest-arg (setq options (copy-list options))
228 ram 1.6 (multiple-value-bind (gf omethod name)
229 ram 1.5 (parse-method-or-spec spec)
230 ram 1.6 (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 wlott 1.1
241     (defun untrace-method (&optional spec)
242 ram 1.6 (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 wlott 1.1
257 ram 1.6 (defun trace-method-internal (ofunction name options)
258 wlott 1.1 (eval `(untrace ,name))
259 ram 1.6 (setf (symbol-function name) ofunction)
260 wlott 1.1 (eval `(trace ,name ,@options))
261 ram 1.6 (symbol-function name))
262 wlott 1.1
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 ram 1.4
285     (pushnew :pcl *features*)
286     (pushnew :portable-commonloops *features*)
287     (pushnew :pcl-structures *features*)
288 pw 1.8
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 pw 1.12 (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 pw 1.8
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 pw 1.12 (defmethod make-instance ((class lisp:class) &rest stuff)
331     (apply #'make-instance (coerce-to-pcl-class class) stuff))
332 pmai 1.14 (defmethod change-class (instance (class lisp:class) &rest initargs)
333     (apply #'change-class instance (coerce-to-pcl-class class) initargs))
334 pw 1.8
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