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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Thu Nov 28 16:23:33 2002 UTC (11 years, 4 months ago) by pmai
Branch: MAIN
Changes since 1.15: +1 -2 lines
Flushed the #+copy-&rest-arg controlled copying of rest arguments, since
the code was both unused in CMUCL, and was erroneous in places, too.  This
brings us in line with SBCL which removed the code early on.
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.16 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.16 2002/11/28 16:23:33 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     (multiple-value-bind (gf omethod name)
228 ram 1.5 (parse-method-or-spec spec)
229 ram 1.6 (let* ((tfunction (trace-method-internal (method-function omethod)
230     name
231     options))
232     (tmethod (make-instance 'traced-method
233     :method omethod
234     :function tfunction)))
235     (remove-method gf omethod)
236     (add-method gf tmethod)
237     (pushnew tmethod *traced-methods*)
238     tmethod)))
239 wlott 1.1
240     (defun untrace-method (&optional spec)
241 ram 1.6 (flet ((untrace-1 (m)
242     (let ((gf (method-generic-function m)))
243     (when gf
244     (remove-method gf m)
245     (add-method gf (slot-value m 'method))
246     (setq *traced-methods* (remove m *traced-methods*))))))
247     (if (not (null spec))
248     (multiple-value-bind (gf method)
249     (parse-method-or-spec spec)
250     (declare (ignore gf))
251     (if (memq method *traced-methods*)
252     (untrace-1 method)
253     (error "~S is not a traced method?" method)))
254     (dolist (m *traced-methods*) (untrace-1 m)))))
255 wlott 1.1
256 ram 1.6 (defun trace-method-internal (ofunction name options)
257 wlott 1.1 (eval `(untrace ,name))
258 ram 1.6 (setf (symbol-function name) ofunction)
259 wlott 1.1 (eval `(trace ,name ,@options))
260 ram 1.6 (symbol-function name))
261 wlott 1.1
262    
263    
264    
265     ;(defun compile-method (spec)
266     ; (multiple-value-bind (gf method name)
267     ; (parse-method-or-spec spec)
268     ; (declare (ignore gf))
269     ; (compile name (method-function method))
270     ; (setf (method-function method) (symbol-function name))))
271    
272     (defmacro undefmethod (&rest args)
273     (declare (arglist name {method-qualifier}* specializers))
274     `(undefmethod-1 ',args))
275    
276     (defun undefmethod-1 (args)
277     (multiple-value-bind (gf method)
278     (parse-method-or-spec args)
279     (when (and gf method)
280     (remove-method gf method)
281     method)))
282    
283 ram 1.4
284     (pushnew :pcl *features*)
285     (pushnew :portable-commonloops *features*)
286     (pushnew :pcl-structures *features*)
287 pw 1.8
288     (when (find-package "OLD-PCL")
289     (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
290     (symbol-function 'pcl::print-object)))
291    
292    
293     ;;;; MAKE-LOAD-FORM
294    
295     (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
296    
297 pw 1.12 (defgeneric make-load-form (object &optional environment))
298    
299     (defmethod make-load-form ((object structure-object) &optional environment)
300     (declare (ignore environment))
301     (kernel:make-structure-load-form object))
302    
303     (defmethod make-load-form ((object wrapper) &optional env)
304     (declare (ignore env))
305     (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
306     (unless pname
307     (error "Can't dump wrapper for anonymous class:~% ~S"
308     (kernel:layout-class object)))
309     `(kernel:class-layout (lisp:find-class ',pname))))
310    
311     (defun make-load-form-saving-slots (object &key slot-names environment)
312     (declare (ignore environment))
313     (when slot-names
314     (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
315     slots:~% ~S"
316     object))
317     :just-dump-it-normally)
318 pw 1.8
319    
320     ;;; The following are hacks to deal with CMU CL having two different CLASS
321     ;;; classes.
322     ;;;
323     (defun coerce-to-pcl-class (class)
324     (if (typep class 'lisp:class)
325     (or (kernel:class-pcl-class class)
326     (find-structure-class (lisp:class-name class)))
327     class))
328    
329 pw 1.12 (defmethod make-instance ((class lisp:class) &rest stuff)
330     (apply #'make-instance (coerce-to-pcl-class class) stuff))
331 pmai 1.14 (defmethod change-class (instance (class lisp:class) &rest initargs)
332     (apply #'change-class instance (coerce-to-pcl-class class) initargs))
333 pw 1.8
334     (macrolet ((frob (&rest names)
335     `(progn
336 pmai 1.15 ,@(mapcar (lambda (name)
337     `(defmethod ,name ((class lisp:class))
338     (funcall #',name
339     (coerce-to-pcl-class class))))
340 pw 1.8 names))))
341     (frob
342     class-direct-slots
343     class-prototype
344     class-precedence-list
345     class-direct-default-initargs
346     class-direct-superclasses
347     compute-class-precedence-list
348     class-default-initargs class-finalized-p
349     class-direct-subclasses class-slots
350     make-instances-obsolete))

  ViewVC Help
Powered by ViewVC 1.1.5