/[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.3 by ram, Sat Oct 19 17:22:23 1991 UTC revision 1.4 by ram, Mon Jun 1 18:37:55 1992 UTC
# Line 32  Line 32 
32  #+Lucid  #+Lucid
33  (progn  (progn
34    
 (defvar *old-arglist*)  
   
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)
# Line 45  Line 43 
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 *old-arglist* function other-args)))))            (t (apply (original-definition 'sys::arglist)
47                        function other-args)))))
48    
49  (eval-when (eval load)  (redefine-function 'sys::arglist 'pcl-arglist)
   (unless (boundp '*old-arglist*)  
     (setq *old-arglist* (symbol-function 'sys::arglist))  
     (setf (symbol-function 'sys::arglist) #'pcl-arglist)))  
50    
51  )  )
52    
# Line 61  Line 57 
57    
58  (defgeneric describe-object (object stream))  (defgeneric describe-object (object stream))
59    
60  #-Genera (progn  #-Genera
61    (progn
 #-cmu  
 (defvar *old-describe* ())  
62    
63  #-cmu  (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
64  (eval-when (load)    (let (#+Lispm (*describe-no-complaints* no-complaints))
65    (unless *old-describe* (setq *old-describe* (symbol-function 'describe)))      #+Lispm (declare (special *describe-no-complaints*))
66    (setf (symbol-function 'describe)      (describe-object object *standard-output*)
67          #+Lispm      (values)))
         #'(lambda (object &optional no-complaints)  
             (let ((*describe-no-complaints* no-complaints))  
               (declare (special *describe-no-complaints*))  
               (describe-object object *standard-output*)  
               (values)))  
         #-Lispm  
         #'(lambda (object)  
             (describe-object object *standard-output*)  
             (values))))  
68    
69  (defmethod describe-object (object stream)  (defmethod describe-object (object stream)
   #-cmu  
70    (let ((*standard-output* stream))    (let ((*standard-output* stream))
71      (funcall *old-describe* object))      (funcall (original-definition 'describe) object)))
72    #+cmu  
73    (describe object stream))  (redefine-function 'describe 'pcl-describe)
74    
75  (defmethod describe-object ((object standard-object) stream)  )
76    
77    (defmethod describe-object ((object slot-object) stream)
78    (let* ((class (class-of object))    (let* ((class (class-of object))
79           (slotds (slots-to-inspect class object))           (slotds (slots-to-inspect class object))
80           (max-slot-name-length 0)           (max-slot-name-length 0)
# Line 109  Line 95 
95                           name max-slot-name-length value))))                           name max-slot-name-length value))))
96        ;; Figure out a good width for the slot-name column.        ;; Figure out a good width for the slot-name column.
97        (dolist (slotd slotds)        (dolist (slotd slotds)
98          (adjust-slot-name-length (slotd-name slotd))          (adjust-slot-name-length (slot-definition-name slotd))
99          (case (slotd-allocation slotd)          (case (slot-definition-allocation slotd)
100            (:instance (push slotd instance-slotds))            (:instance (push slotd instance-slotds))
101            (:class  (push slotd class-slotds))            (:class  (push slotd class-slotds))
102            (otherwise (push slotd other-slotds))))            (otherwise (push slotd other-slotds))))
# Line 120  Line 106 
106        (when instance-slotds        (when instance-slotds
107          (format stream "~% The following slots have :INSTANCE allocation:")          (format stream "~% The following slots have :INSTANCE allocation:")
108          (dolist (slotd (nreverse instance-slotds))          (dolist (slotd (nreverse instance-slotds))
109            (describe-slot (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
110                           (slot-value-or-default object (slotd-name slotd)))))                           (slot-value-or-default object (slot-definition-name slotd)))))
111    
112        (when class-slotds        (when class-slotds
113          (format stream "~% The following slots have :CLASS allocation:")          (format stream "~% The following slots have :CLASS allocation:")
114          (dolist (slotd (nreverse class-slotds))          (dolist (slotd (nreverse class-slotds))
115            (describe-slot (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
116                           (slot-value-or-default object (slotd-name slotd)))))                           (slot-value-or-default object (slot-definition-name slotd)))))
117    
118        (when other-slotds        (when other-slotds
119          (format stream "~% The following slots have allocation as shown:")          (format stream "~% The following slots have allocation as shown:")
120          (dolist (slotd (nreverse other-slotds))          (dolist (slotd (nreverse other-slotds))
121            (describe-slot (slotd-name slotd)            (describe-slot (slot-definition-name slotd)
122                           (slot-value-or-default object (slotd-name slotd))                           (slot-value-or-default object (slot-definition-name slotd))
123                           (slotd-allocation slotd))))                           (slot-definition-allocation slotd))))
124        (values))))        (values))))
125    
126  #+cmu  (defmethod slots-to-inspect ((class slot-class) (object slot-object))
127      (class-slots class))
128    
129  (defmethod describe-object ((fun standard-generic-function) stream)  (defmethod describe-object ((fun standard-generic-function) stream)
130    (format stream "~A is a generic function.~%" fun)    (format stream "~A is a generic function.~%" fun)
131    (format stream "Its arguments are:~%  ~S~%"    (format stream "Its arguments are:~%  ~S~%"
132            (generic-function-pretty-arglist fun))            (generic-function-pretty-arglist fun))
133    (format stream "Its methods are:")    (format stream "Its methods are:")
134    (dolist (meth (generic-function-methods fun))    (dolist (meth (generic-function-methods fun))
135      (format stream "~2%**** ~{~S ~}~:S =>~%"      (format stream "~2%**** ~{~S ~}~:S =>~%"
136              (method-qualifiers meth)              (method-qualifiers meth)
137              (unparse-specializers meth))              (unparse-specializers meth))
138      (describe-object (method-function meth) stream)))      (describe-object (method-function meth) stream)))
139    
   
 (defmethod slots-to-inspect ((class std-class) (object standard-object))  
   (class-slots class))  
   
140  ;;;  ;;;
141  ;;;  ;;;
142  ;;;  ;;;
143    (defvar *describe-classes-as-objects-p* nil)
144    
145  (defmethod describe-object ((class class) stream)  (defmethod describe-object ((class class) stream)
146    (flet ((pretty-class (c) (or (class-name c) c)))    (flet ((pretty-class (c) (or (class-name c) c)))
147      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))      (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
# Line 173  Line 159 
159            (mapcar #'pretty-class (class-direct-superclasses class))            (mapcar #'pretty-class (class-direct-superclasses class))
160            (mapcar #'pretty-class (class-direct-subclasses class))            (mapcar #'pretty-class (class-direct-subclasses class))
161            (mapcar #'pretty-class (class-precedence-list class))            (mapcar #'pretty-class (class-precedence-list class))
162            (length (specializer-methods class))))))            (length (specializer-direct-methods class)))))
163      (when *describe-classes-as-objects-p*
164        (call-next-method)))
165    
166    
167    
# Line 280  Line 268 
268        (remove-method gf method)        (remove-method gf method)
269        method)))        method)))
270    
271  ); #-genera progn  
272    (pushnew :pcl *features*)
273    (pushnew :portable-commonloops *features*)
274    (pushnew :pcl-structures *features*)

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5