/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Diff of /src/pcl/std-class.lisp

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

revision 1.1 by wlott, Sun Aug 12 03:48:21 1990 UTC revision 1.1.1.1 by ram, Sat Oct 19 16:45:50 1991 UTC
# Line 103  Line 103 
103  (defmethod class-slot-cells ((class std-class))  (defmethod class-slot-cells ((class std-class))
104    (plist-value class 'class-slot-cells))    (plist-value class 'class-slot-cells))
105    
 (defmethod find-slot-definition ((class std-class) slot-name)  
   (dolist (eslotd (class-slots class))  
     (when (eq (slotd-name eslotd) slot-name) (return eslotd))))  
   
106    
107  ;;;  ;;;
108  ;;; Class accessors that are even a little bit more complicated than those  ;;; Class accessors that are even a little bit more complicated than those
# Line 176  Line 172 
172  ;;; This hash table is used to store the direct methods and direct generic  ;;; This hash table is used to store the direct methods and direct generic
173  ;;; functions of EQL specializers.  Each value in the table is the cons.  ;;; functions of EQL specializers.  Each value in the table is the cons.
174  ;;;  ;;;
175  (defvar *eql-specializer-methods* (make-hash-table :test #'eql))  (defvar *specializer-with-object-methods* (make-hash-table :test #'eql))
176    
177  (defmethod add-method-on-specializer ((method method) (specializer eql-specializer))  (defmethod add-method-on-specializer ((method method) (specializer specializer-with-object))
178    (let* ((object (eql-specializer-object specializer))    (let* ((object (specializer-object specializer))
179           (entry (gethash object *eql-specializer-methods*)))           (entry (gethash object *specializer-with-object-methods*)))
180      (unless entry      (unless entry
181        (setq entry        (setq entry
182              (setf (gethash object *eql-specializer-methods*)              (setf (gethash object *specializer-with-object-methods*)
183                    (cons nil nil))))                    (cons nil nil))))
184      (setf (car entry) (adjoin method (car entry))      (setf (car entry) (adjoin method (car entry))
185            (cdr entry) ())            (cdr entry) ())
186      method))      method))
187    
188  (defmethod remove-method-on-specializer ((method method) (specializer eql-specializer))  (defmethod remove-method-on-specializer ((method method) (specializer specializer-with-object))
189    (let* ((object (eql-specializer-object specializer))    (let* ((object (specializer-object specializer))
190           (entry (gethash object *eql-specializer-methods*)))           (entry (gethash object *specializer-with-object-methods*)))
191      (when entry      (when entry
192        (setf (car entry) (remove method (car entry))        (setf (car entry) (remove method (car entry))
193              (cdr entry) ()))              (cdr entry) ()))
194      method))      method))
195    
196  (defmethod specializer-methods ((specializer eql-specializer))  (defmethod specializer-methods ((specializer specializer-with-object))
197    (car (gethash (eql-specializer-object specializer) *eql-specializer-methods*)))    (car (gethash (specializer-object specializer) *specializer-with-object-methods*)))
198    
199  (defmethod specializer-generic-functions ((specializer eql-specializer))  (defmethod specializer-generic-functions ((specializer specializer-with-object))
200    (let* ((object (eql-specializer-object specializer))    (let* ((object (specializer-object specializer))
201           (entry (gethash object *eql-specializer-methods*)))           (entry (gethash object *specializer-with-object-methods*)))
202      (when entry      (when entry
203        (or (cdr entry)        (or (cdr entry)
204            (setf (cdr entry)            (setf (cdr entry)
# Line 289  Line 285 
285  (defmethod shared-initialize :after  (defmethod shared-initialize :after
286             ((class std-class)             ((class std-class)
287              slot-names              slot-names
288              &key direct-superclasses              &key (direct-superclasses nil direct-superclasses-p)
289                   direct-slots                   (direct-slots nil direct-slots-p)
290                   direct-default-initargs)                   (direct-default-initargs nil direct-default-initargs-p))
291    (declare (ignore slot-names))    (declare (ignore slot-names))
292    (when (null direct-superclasses)    (setq direct-superclasses
293      (setq direct-superclasses  (list *the-class-standard-object*)))          (if direct-superclasses-p
294    (setq direct-slots              (setf (slot-value class 'direct-superclasses)
295          (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))                    (or direct-superclasses
296    (setf (slot-value class 'direct-superclasses) direct-superclasses                        (list *the-class-standard-object*)))
297          (slot-value class 'direct-slots) direct-slots)              (slot-value class 'direct-superclasses)))
298    (setf (plist-value class 'direct-default-initargs) direct-default-initargs)    (setq direct-slots
299            (if direct-slots-p
300                (setf (slot-value class 'direct-slots)
301                      (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
302                (slot-value class 'direct-slots)))
303      (if direct-default-initargs-p
304          (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
305          (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
306    (setf (plist-value class 'class-slot-cells)    (setf (plist-value class 'class-slot-cells)
307          (gathering1 (collecting)          (gathering1 (collecting)
308            (dolist (dslotd direct-slots)            (dolist (dslotd direct-slots)
# Line 315  Line 318 
318                                                 direct-slots                                                 direct-slots
319                                                 direct-default-initargs)                                                 direct-default-initargs)
320    (declare (ignore direct-default-initargs))    (declare (ignore direct-default-initargs))
321    (remove-direct-subclasses class direct-superclasses)    (remove-direct-subclasses class (class-direct-superclasses class))
322    (remove-slot-accessors    class (class-direct-slots class)))    (remove-slot-accessors    class (class-direct-slots class)))
323    
324  (defmethod reinitialize-instance :after ((class std-class)  (defmethod reinitialize-instance :after ((class std-class)
# Line 425  Line 428 
428                slots eslotds                slots eslotds
429                (wrapper-instance-slots-layout nwrapper) nlayout                (wrapper-instance-slots-layout nwrapper) nlayout
430                (wrapper-class-slots nwrapper) nwrapper-class-slots                (wrapper-class-slots nwrapper) nwrapper-class-slots
431                wrapper nwrapper)))))                wrapper nwrapper))
432          (dolist (eslotd eslotds)
433            (when (typep eslotd 'standard-effective-slot-definition)
434              (setf (slotd-class eslotd) class)
435              (setf (slotd-instance-index eslotd)
436                    (instance-slot-index nwrapper (slotd-name eslotd))))))))
437    
438  (defun compute-storage-info (cpl eslotds)  (defun compute-storage-info (cpl eslotds)
439    (let ((instance ())    (let ((instance ())
# Line 629  Line 637 
637    
638  (defun make-std-reader-method-function (slot-name)  (defun make-std-reader-method-function (slot-name)
639    #'(lambda (instance)    #'(lambda (instance)
640        (slot-value-using-class (wrapper-class (get-wrapper instance))        (slot-value instance slot-name)))
                               instance  
                               slot-name)))  
641    
642  (defun make-std-writer-method-function (slot-name)  (defun make-std-writer-method-function (slot-name)
643    #'(lambda (nv instance)    #'(lambda (nv instance)
644        (setf (slot-value-using-class (wrapper-class (get-wrapper instance))        (setf (slot-value instance slot-name) nv)))
                                     instance  
                                     slot-name)  
             nv)))  
645    
646    
647    
# Line 972  Line 975 
975    
976  (defmethod map-dependents ((metaobject dependent-update-mixin) function)  (defmethod map-dependents ((metaobject dependent-update-mixin) function)
977    (dolist (dependent (plist-value metaobject 'dependents))    (dolist (dependent (plist-value metaobject 'dependents))
978        (funcall function dependent)))
979    

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

  ViewVC Help
Powered by ViewVC 1.1.5