/[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.62 by gerd, Thu May 8 17:29:03 2003 UTC revision 1.63 by gerd, Sat May 10 19:09:01 2003 UTC
# Line 1580  Line 1580 
1580  ;;;  ;;;
1581  ;;; Conditions  ;;; Conditions
1582  ;;;  ;;;
 (defmethod class-direct-slots ((class condition-class)) ())  
 (defmethod class-slots ((class condition-class)) ())  
1583  (defmethod class-default-initargs ((class condition-class)) ())  (defmethod class-default-initargs ((class condition-class)) ())
1584  (defmethod class-direct-default-initargs ((class condition-class)) ())  (defmethod class-direct-default-initargs ((class condition-class)) ())
1585    
1586  (defmethod shared-initialize :after ((class condition-class) slot-names  (defmethod shared-initialize :after ((class condition-class) slot-names
1587                                       &key direct-superclasses)                                       &key direct-slots direct-superclasses)
1588    (declare (ignore slot-names))    (declare (ignore slot-names))
1589    (let ((kernel-class (kernel::find-class (class-name class))))    (let ((kernel-class (kernel::find-class (class-name class))))
1590      (with-slots (wrapper class-precedence-list prototype predicate-name      (with-slots (wrapper class-precedence-list prototype predicate-name
1591                           (direct-supers direct-superclasses))                           (direct-supers direct-superclasses))
1592          class          class
1593          (setf (slot-value class 'direct-slots)
1594                (mapcar (lambda (pl) (make-direct-slotd class pl))
1595                        direct-slots))
1596        (setf (slot-value class 'finalized-p) t)        (setf (slot-value class 'finalized-p) t)
1597        (setf (kernel:%class-pcl-class kernel-class) class)        (setf (kernel:%class-pcl-class kernel-class) class)
1598        (setq direct-supers direct-superclasses)        (setq direct-supers direct-superclasses)
# Line 1600  Line 1601 
1601        (setq prototype (make-condition (class-name class)))        (setq prototype (make-condition (class-name class)))
1602        (add-direct-subclasses class direct-superclasses)        (add-direct-subclasses class direct-superclasses)
1603        (setq predicate-name (make-class-predicate-name (class-name class)))        (setq predicate-name (make-class-predicate-name (class-name class)))
1604        (make-class-predicate class predicate-name))))        (make-class-predicate class predicate-name)
1605          (setf (slot-value class 'slots) (compute-slots class)))))
1606    
1607    (defmethod direct-slot-definition-class
1608        ((class condition-class) &rest initargs)
1609      (declare (ignore initargs))
1610      (find-class 'condition-direct-slot-definition))
1611    
1612    (defmethod effective-slot-definition-class
1613        ((class condition-class) &rest initargs)
1614      (declare (ignore initargs))
1615      (find-class 'condition-effective-slot-definition))
1616    
1617    (defmethod finalize-inheritance ((class condition-class))
1618      nil)
1619    
1620    (defmethod compute-slots ((class condition-class))
1621      (mapcan (lambda (superclass)
1622                (mapcar (lambda (dslotd)
1623                          (compute-effective-slot-definition
1624                           class (slot-definition-name dslotd) (list dslotd)))
1625                        (class-direct-slots superclass)))
1626              (reverse (slot-value class 'class-precedence-list))))
1627    

Legend:
Removed from v.1.62  
changed lines
  Added in v.1.63

  ViewVC Help
Powered by ViewVC 1.1.5