- (sort instance-slots #'<
- :key #'slot-definition-location)))
- (nslots (length nlayout))
- (nwrapper-class-slots (compute-class-slots class-slots))
- (owrapper (class-wrapper class))
- (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
- (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
- (nwrapper
- (cond ((null owrapper)
- (make-wrapper nslots class))
- ((and (equal nlayout olayout)
- (not
- (iterate ((o (list-elements owrapper-class-slots))
- (n (list-elements nwrapper-class-slots)))
- (unless (eq (car o) (car n)) (return t)))))
- owrapper)
- (t
- ;; This will initialize the new wrapper to have the
- ;; same state as the old wrapper. We will then have
- ;; to change that. This may seem like wasted work
- ;; (and it is), but the spec requires that we call
- ;; MAKE-INSTANCES-OBSOLETE.
- (make-instances-obsolete class)
- (class-wrapper class)))))
-
- (with-slots (wrapper slots) class
- (update-lisp-class-layout class nwrapper)
- (setf slots eslotds
- (wrapper-instance-slots-layout nwrapper) nlayout
- (wrapper-class-slots nwrapper) nwrapper-class-slots
- (wrapper-no-of-instance-slots nwrapper) nslots
- wrapper nwrapper))
-
+ (sort instance-slots #'<
+ :key #'slot-definition-location)))
+ (nslots (length nlayout))
+ (nwrapper-class-slots (compute-class-slots class-slots))
+ (owrapper (when (class-finalized-p class)
+ (class-wrapper class)))
+ (olayout (when owrapper
+ (wrapper-instance-slots-layout owrapper)))
+ (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+ (nwrapper
+ (cond ((null owrapper)
+ (make-wrapper nslots class))
+ ((and (equal nlayout olayout)
+ (not
+ (loop for o in owrapper-class-slots
+ for n in nwrapper-class-slots
+ do (unless (eq (car o) (car n)) (return t)))))
+ owrapper)
+ (t
+ ;; This will initialize the new wrapper to have the
+ ;; same state as the old wrapper. We will then have
+ ;; to change that. This may seem like wasted work
+ ;; (and it is), but the spec requires that we call
+ ;; MAKE-INSTANCES-OBSOLETE.
+ (make-instances-obsolete class)
+ (class-wrapper class)))))
+
+ (update-lisp-class-layout class nwrapper)
+ (setf (slot-value class 'slots) eslotds
+ (slot-value class 'slot-vector) (make-slot-vector eslotds)
+ (wrapper-instance-slots-layout nwrapper) nlayout
+ (wrapper-class-slots nwrapper) nwrapper-class-slots
+ (layout-length nwrapper) nslots
+ (slot-value class 'wrapper) nwrapper)
+ (do* ((slots (slot-value class 'slots) (cdr slots))
+ (dupes nil))
+ ((null slots)
+ (when dupes
+ (style-warn
+ "~@<slot names with the same SYMBOL-NAME but ~
+ different SYMBOL-PACKAGE (possible package problem) ~
+ for class ~S:~4I~@:_~<~@{~S~^~:@_~}~:>~@:>"
+ class dupes)))
+ (let* ((slot (car slots))
+ (oslots (remove (slot-definition-name slot) (cdr slots)
+ :test #'string/=
+ :key #'slot-definition-name)))
+ (when oslots
+ (pushnew (cons (slot-definition-name slot)
+ (mapcar #'slot-definition-name oslots))
+ dupes
+ :test #'string= :key #'car))))
+ (setf (slot-value class 'finalized-p) t)