/[gcl]/gcl/pcl/gcl_pcl_env.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_env.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26