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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Sun Dec 20 04:30:19 1998 UTC (15 years, 4 months ago) by dtc
Branch: MAIN
Changes since 1.9: +4 -0 lines
Add CMUCL style file-comments; from Peter Van Eynde.
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 dtc 1.10 #+cmu
28     (ext:file-comment
29     "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.10 1998/12/20 04:30:19 dtc Exp $")
30     ;;;
31 wlott 1.1 ;;; Basic environmental stuff.
32     ;;;
33    
34 phg 1.7 (in-package :pcl)
35 wlott 1.1
36     #+Lucid
37     (progn
38    
39     (defun pcl-arglist (function &rest other-args)
40     (let ((defn nil))
41     (cond ((and (fsc-instance-p function)
42 ram 1.6 (generic-function-p function))
43     (generic-function-pretty-arglist function))
44     ((and (symbolp function)
45     (fboundp function)
46     (setq defn (symbol-function function))
47     (fsc-instance-p defn)
48     (generic-function-p defn))
49     (generic-function-pretty-arglist defn))
50     (t (apply (original-definition 'sys::arglist)
51     function other-args)))))
52 wlott 1.1
53 ram 1.4 (redefine-function 'sys::arglist 'pcl-arglist)
54 wlott 1.1
55     )
56    
57    
58     ;;;
59     ;;;
60     ;;;
61    
62     (defgeneric describe-object (object stream))
63    
64 ram 1.4 #-Genera
65     (progn
66 ram 1.3
67 ram 1.4 (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
68     (let (#+Lispm (*describe-no-complaints* no-complaints))
69     #+Lispm (declare (special *describe-no-complaints*))
70     (describe-object object *standard-output*)
71     (values)))
72 wlott 1.1
73     (defmethod describe-object (object stream)
74 pw 1.8 #-cmu
75 ram 1.6 (cond ((or #+kcl (packagep object))
76     (describe-package object stream))
77     (t
78 pw 1.8 (funcall (original-definition 'describe) object)))
79     #+cmu
80     (describe object stream))
81 wlott 1.1
82 pw 1.8 #-cmu
83 ram 1.4 (redefine-function 'describe 'pcl-describe)
84    
85     )
86    
87     (defmethod describe-object ((object slot-object) stream)
88 ram 1.6 (let* ((class (class-of object))
89     (slotds (slots-to-inspect class object))
90     (max-slot-name-length 0)
91     (instance-slotds ())
92     (class-slotds ())
93     (other-slotds ()))
94 wlott 1.1 (flet ((adjust-slot-name-length (name)
95 ram 1.6 (setq max-slot-name-length
96     (max max-slot-name-length
97     (length (the string (symbol-name name))))))
98     (describe-slot (name value &optional (allocation () alloc-p))
99     (if alloc-p
100     (format stream
101     "~% ~A ~S ~VT ~S"
102     name allocation (+ max-slot-name-length 7) value)
103     (format stream
104     "~% ~A~VT ~S"
105     name max-slot-name-length value))))
106 wlott 1.1 ;; Figure out a good width for the slot-name column.
107 ram 1.6 (dolist (slotd slotds)
108     (adjust-slot-name-length (slot-definition-name slotd))
109     (case (slot-definition-allocation slotd)
110     (:instance (push slotd instance-slotds))
111     (:class (push slotd class-slotds))
112     (otherwise (push slotd other-slotds))))
113     (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
114     (format stream "~%~S is an instance of class ~S:" object class)
115 wlott 1.1
116     (when instance-slotds
117 ram 1.6 (format stream "~% The following slots have :INSTANCE allocation:")
118     (dolist (slotd (nreverse instance-slotds))
119     (describe-slot (slot-definition-name slotd)
120     (slot-value-or-default object (slot-definition-name slotd)))))
121 wlott 1.1
122     (when class-slotds
123 ram 1.6 (format stream "~% The following slots have :CLASS allocation:")
124     (dolist (slotd (nreverse class-slotds))
125     (describe-slot (slot-definition-name slotd)
126     (slot-value-or-default object (slot-definition-name slotd)))))
127 wlott 1.1
128 ram 1.6 (when other-slotds
129     (format stream "~% The following slots have allocation as shown:")
130     (dolist (slotd (nreverse other-slotds))
131     (describe-slot (slot-definition-name slotd)
132     (slot-value-or-default object (slot-definition-name slotd))
133     (slot-definition-allocation slotd))))
134 wlott 1.1 (values))))
135 ram 1.2
136 ram 1.4 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
137     (class-slots class))
138    
139 ram 1.6 (defvar *describe-metaobjects-as-objects-p* nil)
140 ram 1.5
141 ram 1.2 (defmethod describe-object ((fun standard-generic-function) stream)
142     (format stream "~A is a generic function.~%" fun)
143     (format stream "Its arguments are:~% ~S~%"
144 ram 1.4 (generic-function-pretty-arglist fun))
145 ram 1.6 (format stream "Its methods are:")
146     (dolist (meth (generic-function-methods fun))
147     (format stream "~2% ~{~S ~}~:S =>~%"
148     (method-qualifiers meth)
149     (unparse-specializers meth))
150     (describe-object (or (method-fast-function meth)
151     (method-function meth))
152     stream))
153     (when *describe-metaobjects-as-objects-p*
154     (call-next-method)))
155 ram 1.2
156 wlott 1.1 ;;;
157     ;;;
158     ;;;
159     (defmethod describe-object ((class class) stream)
160     (flet ((pretty-class (c) (or (class-name c) c)))
161     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
162     (ft "~&~S is a class, it is an instance of ~S.~%"
163 ram 1.6 class (pretty-class (class-of class)))
164 wlott 1.1 (let ((name (class-name class)))
165 ram 1.6 (if name
166     (if (eq class (find-class name nil))
167     (ft "Its proper name is ~S.~%" name)
168     (ft "Its name is ~S, but this is not a proper name.~%" name))
169     (ft "It has no name (the name is NIL).~%")))
170 wlott 1.1 (ft "The direct superclasses are: ~:S, and the direct~%~
171 ram 1.6 subclasses are: ~:S. The class precedence list is:~%~S~%~
172     There are ~D methods specialized for this class."
173     (mapcar #'pretty-class (class-direct-superclasses class))
174     (mapcar #'pretty-class (class-direct-subclasses class))
175     (mapcar #'pretty-class (class-precedence-list class))
176     (length (specializer-direct-methods class)))))
177     (when *describe-metaobjects-as-objects-p*
178     (call-next-method)))
179 wlott 1.1
180 ram 1.6 (defun describe-package (object stream)
181     (unless (packagep object) (setq object (find-package object)))
182     (format stream "~&~S is a ~S.~%" object (type-of object))
183     (let ((nick (package-nicknames object)))
184     (when nick
185     (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
186     (butlast nick) (first (last nick)))))
187     (let* (#+cmu (internal (lisp::package-internal-symbols object))
188     (internal-count #+cmu (- (lisp::package-hashtable-size internal)
189     (lisp::package-hashtable-free internal))
190     #-cmu 0)
191     #+cmu (external (lisp::package-external-symbols object))
192     (external-count #+cmu (- (lisp::package-hashtable-size external)
193     (lisp::package-hashtable-free external))
194     #-cmu 0))
195     #-cmu (do-external-symbols (sym object)
196     (declare (ignore sym))
197     (incf external-count))
198     #-cmu (do-symbols (sym object)
199     (declare (ignore sym))
200     (incf internal-count))
201     #-cmu (decf internal-count external-count)
202     (format stream "It has ~D internal and ~D external symbols (~D total).~%"
203     internal-count external-count (+ internal-count external-count)))
204     (let ((used (package-use-list object)))
205     (when used
206     (format stream "It uses the packages ~{~S~^, ~}.~%"
207     (mapcar #'package-name used))))
208 pw 1.9 (let ((users (package-used-by-list object)))
209 ram 1.6 (when users
210     (format stream "It is used by the packages ~{~S~^, ~}.~%"
211     (mapcar #'package-name users)))))
212 wlott 1.1
213 ram 1.6 #+cmu
214     (defmethod describe-object ((object package) stream)
215     (describe-package object stream))
216 ram 1.5
217 ram 1.6 #+cmu
218     (defmethod describe-object ((object hash-table) stream)
219 phg 1.7 (format stream "~&~S is an ~a hash table."
220     object
221     #-cmu17 (lisp::hash-table-kind object)
222     #+cmu17 (lisp::hash-table-test object))
223     (format stream "~&Its size is ~d buckets."
224     (lisp::hash-table-size object))
225     (format stream "~&Its rehash-size is ~d."
226     (lisp::hash-table-rehash-size object))
227 ram 1.6 (format stream "~&Its rehash-threshold is ~d."
228 pw 1.8 (hash-table-rehash-threshold object))
229 ram 1.6 (format stream "~&It currently holds ~d entries."
230     (lisp::hash-table-number-entries object)))
231 ram 1.5
232 ram 1.6
233    
234 wlott 1.1 ;;;
235     ;;; trace-method and untrace-method accept method specs as arguments. A
236     ;;; method-spec should be a list like:
237     ;;; (<generic-function-spec> qualifiers* (specializers*))
238     ;;; where <generic-function-spec> should be either a symbol or a list
239     ;;; of (SETF <symbol>).
240     ;;;
241     ;;; For example, to trace the method defined by:
242     ;;;
243     ;;; (defmethod foo ((x spaceship)) 'ss)
244     ;;;
245     ;;; You should say:
246     ;;;
247     ;;; (trace-method '(foo (spaceship)))
248     ;;;
249     ;;; You can also provide a method object in the place of the method
250     ;;; spec, in which case that method object will be traced.
251     ;;;
252     ;;; For untrace-method, if an argument is given, that method is untraced.
253     ;;; If no argument is given, all traced methods are untraced.
254     ;;;
255 ram 1.6 (defclass traced-method (method)
256     ((method :initarg :method)
257     (function :initarg :function
258     :reader method-function)
259     (generic-function :initform nil
260     :accessor method-generic-function)))
261 wlott 1.1
262 ram 1.6 (defmethod method-lambda-list ((m traced-method))
263     (with-slots (method) m (method-lambda-list method)))
264 wlott 1.1
265 ram 1.6 (defmethod method-specializers ((m traced-method))
266     (with-slots (method) m (method-specializers method)))
267    
268     (defmethod method-qualifiers ((m traced-method))
269     (with-slots (method) m (method-qualifiers method)))
270    
271     (defmethod accessor-method-slot-name ((m traced-method))
272     (with-slots (method) m (accessor-method-slot-name method)))
273    
274 ram 1.5 (defvar *traced-methods* ())
275 wlott 1.1
276 ram 1.6 (defun trace-method (spec &rest options)
277 phg 1.7 #+copy-&rest-arg (setq options (copy-list options))
278 ram 1.6 (multiple-value-bind (gf omethod name)
279 ram 1.5 (parse-method-or-spec spec)
280 ram 1.6 (let* ((tfunction (trace-method-internal (method-function omethod)
281     name
282     options))
283     (tmethod (make-instance 'traced-method
284     :method omethod
285     :function tfunction)))
286     (remove-method gf omethod)
287     (add-method gf tmethod)
288     (pushnew tmethod *traced-methods*)
289     tmethod)))
290 wlott 1.1
291     (defun untrace-method (&optional spec)
292 ram 1.6 (flet ((untrace-1 (m)
293     (let ((gf (method-generic-function m)))
294     (when gf
295     (remove-method gf m)
296     (add-method gf (slot-value m 'method))
297     (setq *traced-methods* (remove m *traced-methods*))))))
298     (if (not (null spec))
299     (multiple-value-bind (gf method)
300     (parse-method-or-spec spec)
301     (declare (ignore gf))
302     (if (memq method *traced-methods*)
303     (untrace-1 method)
304     (error "~S is not a traced method?" method)))
305     (dolist (m *traced-methods*) (untrace-1 m)))))
306 wlott 1.1
307 ram 1.6 (defun trace-method-internal (ofunction name options)
308 wlott 1.1 (eval `(untrace ,name))
309 ram 1.6 (setf (symbol-function name) ofunction)
310 wlott 1.1 (eval `(trace ,name ,@options))
311 ram 1.6 (symbol-function name))
312 wlott 1.1
313    
314    
315    
316     ;(defun compile-method (spec)
317     ; (multiple-value-bind (gf method name)
318     ; (parse-method-or-spec spec)
319     ; (declare (ignore gf))
320     ; (compile name (method-function method))
321     ; (setf (method-function method) (symbol-function name))))
322    
323     (defmacro undefmethod (&rest args)
324     #+(or (not :lucid) :lcl3.0)
325     (declare (arglist name {method-qualifier}* specializers))
326     `(undefmethod-1 ',args))
327    
328     (defun undefmethod-1 (args)
329     (multiple-value-bind (gf method)
330     (parse-method-or-spec args)
331     (when (and gf method)
332     (remove-method gf method)
333     method)))
334    
335 ram 1.4
336     (pushnew :pcl *features*)
337     (pushnew :portable-commonloops *features*)
338     (pushnew :pcl-structures *features*)
339 pw 1.8
340     #+cmu
341     (when (find-package "OLD-PCL")
342     (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
343     (symbol-function 'pcl::print-object)))
344    
345    
346     ;;;; MAKE-LOAD-FORM
347    
348     #+cmu17
349     (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
350    
351     #+cmu17
352     (progn
353     (defgeneric make-load-form (object &optional environment))
354    
355     (defmethod make-load-form ((object structure-object) &optional environment)
356     (declare (ignore environment))
357     (kernel:make-structure-load-form object))
358    
359     (defmethod make-load-form ((object wrapper) &optional env)
360     (declare (ignore env))
361     (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
362     (unless pname
363     (error "Can't dump wrapper for anonymous class:~% ~S"
364     (kernel:layout-class object)))
365     `(kernel:class-layout (lisp:find-class ',pname))))
366    
367     (defun make-load-form-saving-slots (object &key slot-names environment)
368     (declare (ignore environment))
369     (when slot-names
370     (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
371     slots:~% ~S"
372     object))
373     :just-dump-it-normally))
374    
375    
376     ;;; The following are hacks to deal with CMU CL having two different CLASS
377     ;;; classes.
378     ;;;
379     #+cmu17
380     (defun coerce-to-pcl-class (class)
381     (if (typep class 'lisp:class)
382     (or (kernel:class-pcl-class class)
383     (find-structure-class (lisp:class-name class)))
384     class))
385    
386     #+cmu17
387     (progn
388     (defmethod make-instance ((class lisp:class) &rest stuff)
389     (apply #'make-instance (coerce-to-pcl-class class) stuff))
390     (defmethod change-class (instance (class lisp:class))
391     (apply #'change-class instance (coerce-to-pcl-class class))))
392    
393     #+cmu17
394     (macrolet ((frob (&rest names)
395     `(progn
396     ,@(mapcar #'(lambda (name)
397     `(defmethod ,name ((class lisp:class))
398     (funcall #',name
399     (coerce-to-pcl-class class))))
400     names))))
401     (frob
402     class-direct-slots
403     class-prototype
404     class-precedence-list
405     class-direct-default-initargs
406     class-direct-superclasses
407     compute-class-precedence-list
408     class-default-initargs class-finalized-p
409     class-direct-subclasses class-slots
410     make-instances-obsolete))

  ViewVC Help
Powered by ViewVC 1.1.5