Changeset 14293


Ignore:
Timestamp:
12/05/12 15:15:24 (8 years ago)
Author:
rschlatte
Message:

Don't clobber class objects when re-initializing.

  • Also remove double-initialization via shared-initialize + one of intialize-instance / reinitialize-instance.
  • Reported by Pascal Costanza
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14289 r14293  
    866866;         canonicalized-slot))
    867867
     868(defun canonicalize-direct-superclass-list (class direct-superclasses)
     869  (cond (direct-superclasses)
     870        ((subtypep (class-of class) +the-funcallable-standard-class+)
     871         (list +the-funcallable-standard-object-class+))
     872        ((subtypep (class-of class) +the-standard-class+)
     873         (list +the-standard-object-class+))))
     874
    868875(defun std-after-initialization-for-classes (class
    869876                                             &key direct-superclasses direct-slots
    870877                                             direct-default-initargs
    871878                                             &allow-other-keys)
    872   (let ((supers (cond (direct-superclasses)
    873                       ((subtypep (class-of class)
    874                                  +the-funcallable-standard-class+)
    875                        (list +the-funcallable-standard-object-class+))
    876                       ((subtypep (class-of class) +the-standard-class+)
    877                        (list +the-standard-object-class+)))))
     879  (let ((supers (canonicalize-direct-superclass-list class direct-superclasses)))
    878880    (setf (class-direct-superclasses class) supers)
    879881    (dolist (superclass supers)
     
    37823784  (std-shared-initialize instance slot-names initargs))
    37833785
    3784 (defmethod shared-initialize :after ((instance standard-class) slot-names
    3785                                      &key direct-superclasses
    3786                                      direct-slots direct-default-initargs
    3787                                      &allow-other-keys)
    3788   (std-after-initialization-for-classes
    3789    instance :direct-superclasses direct-superclasses
    3790    :direct-slots direct-slots
    3791    :direct-default-initargs direct-default-initargs))
    3792 
    3793 (defmethod shared-initialize :after ((instance funcallable-standard-class)
    3794                                      slot-names &key direct-superclasses
    3795                                      direct-slots direct-default-initargs
    3796                                      &allow-other-keys)
    3797   (std-after-initialization-for-classes
    3798    instance :direct-superclasses direct-superclasses
    3799    :direct-slots direct-slots
    3800    :direct-default-initargs direct-default-initargs))
    3801 
    38023786(defmethod shared-initialize ((slot slot-definition) slot-names
    38033787                              &rest args
     
    39353919    (add-direct-subclass superclass class)))
    39363920
    3937 (defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
     3921(defun std-after-reinitialization-for-classes (class
     3922                                               &rest all-keys
     3923                                               &key (direct-superclasses nil direct-superclasses-p)
     3924                                               (direct-slots nil direct-slots-p)
     3925                                               (direct-default-initargs nil direct-default-initargs-p)
     3926                                               &allow-other-keys)
    39383927  (remhash class *make-instance-initargs-cache*)
    39393928  (remhash class *reinitialize-instance-initargs-cache*)
    39403929  (%make-instances-obsolete class)
    39413930  (setf (class-finalized-p class) nil)
    3942   ;; KLUDGE (rudi 2012-06-17) this calls add-direct-subclass again
    3943   (apply #'std-after-initialization-for-classes class all-keys)
     3931  (when direct-superclasses-p
     3932    (let* ((old-supers (class-direct-superclasses class))
     3933           (new-supers (canonicalize-direct-superclass-list
     3934                        class direct-superclasses)))
     3935      (setf (class-direct-superclasses class) new-supers)
     3936      (dolist (old-superclass (set-difference old-supers new-supers))
     3937        (remove-direct-subclass old-superclass class))
     3938      (dolist (new-superclass (set-difference new-supers old-supers))
     3939        (add-direct-subclass new-superclass class))))
     3940  (when direct-slots-p
     3941    ;; FIXME: maybe remove old reader and writer methods?
     3942    (let ((slots (mapcar #'(lambda (slot-properties)
     3943                             (apply #'make-direct-slot-definition class slot-properties))
     3944                         direct-slots)))
     3945      (setf (class-direct-slots class) slots)
     3946      (dolist (direct-slot slots)
     3947        (dolist (reader (slot-definition-readers direct-slot))
     3948          (add-reader-method class reader direct-slot))
     3949        (dolist (writer (slot-definition-writers direct-slot))
     3950          (add-writer-method class writer direct-slot)))))
     3951  (when direct-default-initargs-p
     3952    (setf (class-direct-default-initargs class) direct-default-initargs))
     3953  (maybe-finalize-class-subtree class)
    39443954  (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))
     3955
     3956(defmethod reinitialize-instance :after ((class standard-class)
     3957                                         &rest all-keys)
     3958  (apply #'std-after-reinitialization-for-classes class all-keys))
    39453959
    39463960(defmethod reinitialize-instance :after ((class funcallable-standard-class)
    39473961                                         &rest all-keys)
    3948   (remhash class *make-instance-initargs-cache*)
    3949   (remhash class *reinitialize-instance-initargs-cache*)
    3950   (%make-instances-obsolete class)
    3951   (setf (class-finalized-p class) nil)
    3952   ;; KLUDGE (rudi 2012-06-17) this calls add-direct-subclass again
    3953   (apply #'std-after-initialization-for-classes class all-keys)
    3954   (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))
     3962  (apply #'std-after-reinitialization-for-classes class all-keys))
    39553963
    39563964(defmethod reinitialize-instance :after ((gf standard-generic-function)
Note: See TracChangeset for help on using the changeset viewer.