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

Diff of /src/pcl/env.lisp

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

revision 1.5 by ram, Sat Aug 1 15:28:41 1992 UTC revision 1.6 by ram, Mon Nov 9 15:19:18 1992 UTC
# Line 35  Line 35 
35  (defun pcl-arglist (function &rest other-args)  (defun pcl-arglist (function &rest other-args)
36    (let ((defn nil))    (let ((defn nil))
37      (cond ((and (fsc-instance-p function)      (cond ((and (fsc-instance-p function)
38                  (generic-function-p function))                  (generic-function-p function))
39             (generic-function-pretty-arglist function))             (generic-function-pretty-arglist function))
40            ((and (symbolp function)            ((and (symbolp function)
41                  (fboundp function)                  (fboundp function)
42                  (setq defn (symbol-function function))                  (setq defn (symbol-function function))
43                  (fsc-instance-p defn)                  (fsc-instance-p defn)
44                  (generic-function-p defn))                  (generic-function-p defn))
45             (generic-function-pretty-arglist defn))             (generic-function-pretty-arglist defn))
46            (t (apply (original-definition 'sys::arglist)            (t (apply (original-definition 'sys::arglist)
47                      function other-args)))))                      function other-args)))))
48    
49  (redefine-function 'sys::arglist 'pcl-arglist)  (redefine-function 'sys::arglist 'pcl-arglist)
50    
# Line 68  Line 68 
68    
69  (defmethod describe-object (object stream)  (defmethod describe-object (object stream)
70    (let ((*standard-output* stream))    (let ((*standard-output* stream))
71      (funcall-compiled (original-definition 'describe) object)))      (cond ((or #+kcl (packagep object))
72               (describe-package object stream))
73              (t
74               (funcall (original-definition 'describe) object)))))
75    
76  (redefine-function 'describe 'pcl-describe)  (redefine-function 'describe 'pcl-describe)
77    
78  )  )
79    
80  (defmethod describe-object ((object slot-object) stream)  (defmethod describe-object ((object slot-object) stream)
81    (format stream "~%~S is an instance of class ~S:" object (class-of object))    (let* ((class (class-of object))
82    (describe-object-slots object stream))           (slotds (slots-to-inspect class object))
83             (max-slot-name-length 0)
84  (defmethod describe-object-slots           (instance-slotds ())
85             ((object slot-object)           (class-slotds ())
86              stream           (other-slotds ()))
             &key  
             (slots-to-inspect (slots-to-inspect (class-of object) object))  
             &allow-other-keys)  
   "Display the value of all the slots-to-inspect on this object."  
   (let* ((max-slot-name-length 0)  
          (instance-slotds ())  
          (class-slotds ())  
          (other-slotds ()))  
     (declare (type index max-slot-name-length))  
87      (flet ((adjust-slot-name-length (name)      (flet ((adjust-slot-name-length (name)
88               (setq max-slot-name-length               (setq max-slot-name-length
89                     (the index                     (max max-slot-name-length
90                          (max max-slot-name-length                          (length (the string (symbol-name name))))))
91                               (length (the simple-string             (describe-slot (name value &optional (allocation () alloc-p))
92                                            (symbol-name name)))))))               (if alloc-p
93             (describe-slot (name value &optional (allocation () alloc-p))                   (format stream
94               (if alloc-p                           "~% ~A ~S ~VT  ~S"
95                   (format stream                           name allocation (+ max-slot-name-length 7) value)
96                           "~% ~A ~S ~VT  "                   (format stream
97                           name allocation (+ max-slot-name-length 7))                           "~% ~A~VT  ~S"
98                   (format stream                           name max-slot-name-length value))))
                          "~% ~A~VT  "  
                          name max-slot-name-length))  
              (prin1 value stream)))  
   
99        ;; Figure out a good width for the slot-name column.        ;; Figure out a good width for the slot-name column.
100        (dolist (slotd slots-to-inspect)        (dolist (slotd slotds)
101          (adjust-slot-name-length (slot-definition-name slotd))          (adjust-slot-name-length (slot-definition-name slotd))
102          (case (slot-definition-allocation slotd)          (case (slot-definition-allocation slotd)
103            (:instance (push slotd instance-slotds))            (:instance (push slotd instance-slotds))
104            (:class  (push slotd class-slotds))            (:class  (push slotd class-slotds))
105            (otherwise (push slotd other-slotds))))            (otherwise (push slotd other-slotds))))
106        (setq max-slot-name-length        (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
107              (the index (min (the index (+ max-slot-name-length 3)) 30)))        (format stream "~%~S is an instance of class ~S:" object class)
108    
109        (when instance-slotds        (when instance-slotds
110          (format stream "~% The following slots have :INSTANCE allocation:")          (format stream "~% The following slots have :INSTANCE allocation:")
111          (dolist (slotd (nreverse instance-slotds))          (dolist (slotd (nreverse instance-slotds))
112            (describe-slot (slot-definition-name slotd)            (describe-slot (slot-definition-name slotd)
113                           (slot-value-or-default                           (slot-value-or-default object (slot-definition-name slotd)))))
                            object (slot-definition-name slotd)))))  
114    
115        (when class-slotds        (when class-slotds
116          (format stream "~% The following slots have :CLASS allocation:")          (format stream "~% The following slots have :CLASS allocation:")
117          (dolist (slotd (nreverse class-slotds))          (dolist (slotd (nreverse class-slotds))
118            (describe-slot (slot-definition-name slotd)            (describe-slot (slot-definition-name slotd)
119                           (slot-value-or-default                           (slot-value-or-default object (slot-definition-name slotd)))))
120                              object (slot-definition-name slotd)))))  
121          (when other-slotds
122        (when other-slotds          (format stream "~% The following slots have allocation as shown:")
123          (format stream "~% The following slots have allocation as shown:")          (dolist (slotd (nreverse other-slotds))
124          (dolist (slotd (nreverse other-slotds))            (describe-slot (slot-definition-name slotd)
125            (describe-slot (slot-definition-name slotd)                           (slot-value-or-default object (slot-definition-name slotd))
126                           (slot-value-or-default                           (slot-definition-allocation slotd))))
                            object (slot-definition-name slotd))  
                          (slot-definition-allocation slotd))))  
127        (values))))        (values))))
128    
129  (defmethod slots-to-inspect ((class slot-class) (object slot-object))  (defmethod slots-to-inspect ((class slot-class) (object slot-object))
130    (class-slots class))    (class-slots class))
131    
132  (defvar *describe-generic-functions-as-objects-p* nil)  (defvar *describe-metaobjects-as-objects-p* nil)
133    
134  (defmethod describe-object ((fun standard-generic-function) stream)  (defmethod describe-object ((fun standard-generic-function) stream)
135    (format stream "~A is a generic function.~%" fun)    (format stream "~A is a generic function.~%" fun)
136    (format stream "Its arguments are:~%  ~S~%"    (format stream "Its arguments are:~%  ~S~%"
137            (generic-function-pretty-arglist fun))            (generic-function-pretty-arglist fun))
138    (if *describe-generic-functions-as-objects-p*    (format stream "Its methods are:")
139        (describe-object-slots fun stream)    (dolist (meth (generic-function-methods fun))
140        (progn      (format stream "~2%    ~{~S ~}~:S =>~%"
141          (format stream "Its methods are:")              (method-qualifiers meth)
142          (dolist (meth (generic-function-methods fun))              (unparse-specializers meth))
143            (format stream "~2%**** ~{~S ~}~:S =>~%"      (describe-object (or (method-fast-function meth)
144                    (method-qualifiers meth)                           (method-function meth))
145                    (unparse-specializers meth))                       stream))
146            (describe-object meth stream)))))    (when *describe-metaobjects-as-objects-p*
147        (call-next-method)))
148    
149  ;;;  ;;;
150  ;;;  ;;;
151  ;;;  ;;;
 (defvar *describe-classes-as-objects-p* nil)  
   
152  (defmethod describe-object ((class class) stream)  (defmethod describe-object ((class class) stream)
153    (flet ((pretty-class (c) (or (class-name c) c)))    (flet ((pretty-class (c) (or (class-name c) c)))
154      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
155        (ft "~&~S is a class, it is an instance of ~S.~%"        (ft "~&~S is a class, it is an instance of ~S.~%"
156            class (pretty-class (class-of class)))            class (pretty-class (class-of class)))
157        (let ((name (class-name class)))        (let ((name (class-name class)))
158          (if name          (if name
159              (if (eq class (find-class name nil))              (if (eq class (find-class name nil))
160                  (ft "Its proper name is ~S.~%" name)                  (ft "Its proper name is ~S.~%" name)
161                  (ft "Its name is ~S, but this is not a proper name.~%" name))                  (ft "Its name is ~S, but this is not a proper name.~%" name))
162              (ft "It has no name (the name is NIL).~%")))              (ft "It has no name (the name is NIL).~%")))
163        (ft "The direct superclasses are: ~:S, and the direct~%~        (ft "The direct superclasses are: ~:S, and the direct~%~
164             subclasses are: ~:S.  "             subclasses are: ~:S.  The class precedence list is:~%~S~%~
165            (mapcar #'pretty-class (class-direct-superclasses class))             There are ~D methods specialized for this class."
166            (mapcar #'pretty-class (class-direct-subclasses class)))            (mapcar #'pretty-class (class-direct-superclasses class))
167        (if (class-finalized-p class)            (mapcar #'pretty-class (class-direct-subclasses class))
168            (ft "The class precedence list is:~%~S~%"            (mapcar #'pretty-class (class-precedence-list class))
169                (mapcar #'pretty-class (class-precedence-list class)))            (length (specializer-direct-methods class)))))
170            (ft "The class is not finalized.~%"))    (when *describe-metaobjects-as-objects-p*
171        (ft "There are ~D methods specialized for this class."      (call-next-method)))
172            (length (the list (specializer-direct-methods class))))))  
173    (when *describe-classes-as-objects-p*  (defun describe-package (object stream)
174      (describe-object-slots class stream)))    (unless (packagep object) (setq object (find-package object)))
175      (format stream "~&~S is a ~S.~%" object (type-of object))
176      (let ((nick (package-nicknames object)))
177  (declaim (ftype (function (T &optional T) (values T T symbol))      (when nick
178                  parse-method-or-spec))        (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
179  (defun parse-method-or-spec (spec &optional (errorp t))                (butlast nick) (first (last nick)))))
180    (declare (values generic-function method method-name))    (let* (#+cmu (internal (lisp::package-internal-symbols object))
181    (let (gf method name temp)           (internal-count #+cmu (- (lisp::package-hashtable-size internal)
182      (if (method-p spec)                                    (lisp::package-hashtable-free internal))
183          (setq method spec                           #-cmu 0)
184                gf (method-generic-function method)           #+cmu (external (lisp::package-external-symbols object))
185                temp (and gf (generic-function-name gf))           (external-count #+cmu (- (lisp::package-hashtable-size external)
186                name (if temp                                    (lisp::package-hashtable-free external))
187                         (intern-function-name                           #-cmu 0))
188                           (make-method-spec temp      #-cmu (do-external-symbols (sym object)
189                                             (method-qualifiers method)              (declare (ignore sym))
190                                             (unparse-specializers              (incf external-count))
191                                               (method-specializers method))))      #-cmu (do-symbols (sym object)
192                         (make-symbol (format nil "~S" method))))              (declare (ignore sym))
193          (multiple-value-bind (gf-spec quals specls)              (incf internal-count))
194              (parse-defmethod spec)      #-cmu (decf internal-count external-count)
195            (declare (list quals specls))      (format stream "It has ~D internal and ~D external symbols (~D total).~%"
196            (and (setq gf (and (or errorp (gboundp gf-spec))              internal-count external-count (+ internal-count external-count)))
197                               (gdefinition gf-spec)))    (let ((used (package-use-list object)))
198                 (let ((nreq (compute-discriminating-function-arglist-info gf)))      (when used
199                   (declare (type index nreq))        (format stream "It uses the packages ~{~S~^, ~}.~%"
200                   (setq specls (append (parse-specializers specls)                (mapcar #'package-name used))))
201                                        (make-list (the index (- nreq (length specls)))    (let ((users (package-use-list object)))
202                                                   :initial-element      (when users
203                                                   *the-class-t*)))        (format stream "It is used by the packages ~{~S~^, ~}.~%"
204                   (and                (mapcar #'package-name users)))))
205                     (setq method (get-method gf quals specls errorp))  
206                     (setq name  #+cmu
207                           (intern-function-name (make-method-spec gf-spec  (defmethod describe-object ((object package) stream)
208                                                                   quals    (describe-package object stream))
209                                                                   specls))))))))  
210      (values gf method name)))  #+cmu
211    (defmethod describe-object ((object hash-table) stream)
212  (defmethod copy-instance-slots ((object1 slot-object)    (format stream "~&~S is an ~a hash table." object (lisp::hash-table-kind object))
213                                  (object2 slot-object)    (format stream "~&Its size is ~d buckets." (lisp::hash-table-size object))
214                                  &key    (format stream "~&Its rehash-size is ~d." (lisp::hash-table-rehash-size object))
215                                  (exclude-slot-names NIL))    (format stream "~&Its rehash-threshold is ~d."
216    (let ((obj1-slot-names            (lisp::hash-table-rehash-threshold object))
217           (mapcar #'slot-definition-name (class-slots (class-of object1))))    (format stream "~&It currently holds ~d entries."
218          (obj2-slot-names            (lisp::hash-table-number-entries object)))
219           (mapcar #'slot-definition-name (class-slots (class-of object2)))))  
     (declare (type list obj1-slot-names obj2-slot-names))  
     (dolist (slot-name obj1-slot-names)  
       (when (and (not (memq slot-name exclude-slot-names))  
                  (memq slot-name obj2-slot-names))  
         (setf (slot-value object2 slot-name)  
               (slot-value object1 slot-name))))))  
220    
221    
222  ;;;  ;;;
223  ;;; trace-method and untrace-method accept method specs as arguments.  A  ;;; trace-method and untrace-method accept method specs as arguments.  A
224  ;;; method-spec should be a list like:  ;;; method-spec should be a list like:
# Line 259  Line 240 
240  ;;; For untrace-method, if an argument is given, that method is untraced.  ;;; For untrace-method, if an argument is given, that method is untraced.
241  ;;; If no argument is given, all traced methods are untraced.  ;;; If no argument is given, all traced methods are untraced.
242  ;;;  ;;;
243    (defclass traced-method (method)
244         ((method :initarg :method)
245          (function :initarg :function
246                    :reader method-function)
247          (generic-function :initform nil
248                            :accessor method-generic-function)))
249    
250    (defmethod method-lambda-list ((m traced-method))
251      (with-slots (method) m (method-lambda-list method)))
252    
253    (defmethod method-specializers ((m traced-method))
254      (with-slots (method) m (method-specializers method)))
255    
256  (defclass traced-method (standard-method)  (defmethod method-qualifiers ((m traced-method))
257       ((method :initarg :method)))    (with-slots (method) m (method-qualifiers method)))
258    
259    (defmethod accessor-method-slot-name ((m traced-method))
260      (with-slots (method) m (accessor-method-slot-name method)))
261    
262  (defvar *traced-methods* ())  (defvar *traced-methods* ())
263    
264  (defmethod trace-method ((spec cons) &rest options)  (defun trace-method (spec &rest options)
265    (multiple-value-bind (gf method name)    (multiple-value-bind (gf omethod name)
266        (parse-method-or-spec spec)        (parse-method-or-spec spec)
267      (declare (ignore gf name))      (let* ((tfunction (trace-method-internal (method-function omethod)
268      (apply #'trace-method method options)))                                               name
269                                                 options))
270  (defmethod trace-method ((tmethod traced-method) &rest options)             (tmethod (make-instance 'traced-method
271    (untrace-method tmethod)                                     :method omethod
272    (apply #'trace-method (slot-value tmethod 'method) options))                                     :function tfunction)))
273          (remove-method gf omethod)
274  (defmethod trace-method ((method standard-method) &rest options)        (add-method gf tmethod)
275    (let* ((gf        (method-generic-function method))        (pushnew tmethod *traced-methods*)
276           (base-name (symbol-name (method-function-name method)))        tmethod)))
          (tmethod   (make-instance 'traced-method :method method))  
          (function  (method-function method))  
          (t-function  
            (if function  
                 (trace-function-internal  
                  function (gentemp base-name) options)))  
          (optimized-fn (method-optimized-function method))  
          (t-optimized-fn  
            (if optimized-fn  
                (trace-function-internal  
                  optimized-fn (gentemp base-name) options)))  
          (traced-function-names  
            (append (if function     (list t-function))  
                    (if optimized-fn (list t-optimized-fn)))))  
     (declare (type simple-string base-name)  
              (type symbol        t-function t-optimized-fn))  
     (copy-instance-slots method tmethod  
                          :exclude-slot-names  
                          '(function optimized-function cached-functions-alist  
                            generic-function))  
     (when function  
       (setf (slot-value tmethod 'function)  
             (symbol-function t-function)))  
     (when optimized-fn  
       (setf (slot-value tmethod 'optimized-function)  
             (symbol-function t-optimized-fn)))  
     (setf (slot-value tmethod 'cached-functions-alist)  
           (mapcar  
             #'(lambda (cached-fn)  
                 (let ((fn (cdr cached-fn)))  
                   (cons  
                     (car cached-fn)  
                     (symbol-function  
                       (the symbol  
                            (cond ((eq fn function) t-function)  
                                  ((eq fn optimized-fn) t-optimized-fn)  
                                  (T  
                                    (let ((t-name  
                                           (trace-function-internal  
                                             fn  
                                             (gentemp base-name)  
                                             options)))  
                                      (push t-name traced-function-names)  
                                      t-name))))))))  
             (slot-value method 'cached-functions-alist)))  
     (remove-method gf method)  
     (add-method gf tmethod)  
     (push (cons tmethod traced-function-names) *traced-methods*)  
     tmethod))  
277    
278  (defun untrace-method (&optional spec)  (defun untrace-method (&optional spec)
279    (flet ((untrace-1 (method-cons-traces)    (flet ((untrace-1 (m)
280             (let* ((m  (car method-cons-traces))             (let ((gf (method-generic-function m)))
281                    (gf (method-generic-function m)))               (when gf
282               (when gf                 (remove-method gf m)
283                 (remove-method gf m)                 (add-method gf (slot-value m 'method))
284                 (add-method gf (slot-value m 'method))))                 (setq *traced-methods* (remove m *traced-methods*))))))
285             (untrace-method-function-names (cdr method-cons-traces))      (if (not (null spec))
286             (setq *traced-methods*          (multiple-value-bind (gf method)
287                   (remove method-cons-traces *traced-methods* :test #'eq))))              (parse-method-or-spec spec)
288      (cond ((consp spec)            (declare (ignore gf))
289             (multiple-value-bind (gf method)            (if (memq method *traced-methods*)
290                 (parse-method-or-spec spec)                (untrace-1 method)
291               (declare (ignore gf))                (error "~S is not a traced method?" method)))
292               (let ((old-trace (assq method *traced-methods*)))          (dolist (m *traced-methods*) (untrace-1 m)))))
                (if old-trace  
                    (untrace-1 old-trace)  
                    (error "~S is not a traced method?" method)))))  
           ((typep spec 'standard-method)  
              (let ((old-trace (assq spec *traced-methods*)))  
                (if old-trace  
                    (untrace-1 old-trace)  
                    (error "~S is not a traced method?" spec))))  
           ((null spec)  
            (dolist (trace *traced-methods*) (untrace-1 trace)))  
           (T (error  
               "Untrace-method needs method, method specifier, or nothing.")))))  
293    
294  (defun trace-function-internal (function name options)  (defun trace-method-internal (ofunction name options)
295    (eval `(untrace ,name))    (eval `(untrace ,name))
296    (setf (symbol-function name) function)    (setf (symbol-function name) ofunction)
297    (eval `(trace ,name ,@options))    (eval `(trace ,name ,@options))
298    name)    (symbol-function name))
299    
 (defun untrace-method-function-names (names)  
   (dolist (name names)  
     (setf (symbol-function name) NIL))  
   (eval `(untrace ,@names)))  
   
 (defun trace-methods (gf)  
   (let ((methods (generic-function-methods gf)))  
     (dolist (method methods)  
       (trace-method method))  
     methods))  
300    
301    
302    
# Line 398  Line 323 
323  (pushnew :pcl *features*)  (pushnew :pcl *features*)
324  (pushnew :portable-commonloops *features*)  (pushnew :portable-commonloops *features*)
325  (pushnew :pcl-structures *features*)  (pushnew :pcl-structures *features*)
   
 #+cmu  
 (when (find-package "OLD-PCL")  
   (setf (symbol-function 'old-pcl::print-object)  
         (symbol-function 'pcl::print-object)))  
   

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5