Changeset 831

Timestamp:

Jun 23, 2004, 10:29:26 AM (20 years ago)

Author:

Gary Byers

Message:

UPDATE-SLOTS fix.

File:

• trunk/ccl/level-1/l1-clos.lisp (modified) (1 diff)

trunk/ccl/level-1/l1-clos.lisp

@@ -280 +280 @@
 
 (defun update-slots (class eslotds)
-  (multiple-value-bind (instance-slots class-slots)
-      (extract-instance-and-class-slotds eslotds)
-    (let* ((new-ordering
-            (let* ((v (make-array (the fixnum (length instance-slots))))
-                   (i 0))
-              (declare (simple-vector v) (fixnum i))
-              (dolist (e instance-slots v)
-                (setf (svref v i)
-                      (%slot-definition-name e))
-                (incf i))))
-           (old-wrapper (%class-own-wrapper class))
-           (old-ordering (if old-wrapper (%wrapper-instance-slots old-wrapper)))
-           (new-wrapper
-            (cond ((null old-wrapper)
-                   (%cons-wrapper class))
-                  ((and old-wrapper *update-slots-preserve-existing-wrapper*)
-                   old-wrapper)
-                  ((and (equalp old-ordering new-ordering)
-                        (null class-slots))
-                   old-wrapper)
-                  (t
-                   (make-instances-obsolete class)
-                   ;;; Is this right ?
-                   #|(%class.own-wrapper class)|#
-                   (%cons-wrapper class)))))
-      (setf (%class-slots class) eslotds)
-      (setf (%wrapper-instance-slots new-wrapper) new-ordering
-            (%wrapper-class-slots new-wrapper) (%class-get class :class-slots)
-            (%class-own-wrapper class) new-wrapper)
-      (setup-slot-lookup new-wrapper eslotds))))
+  (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds))
+         (new-ordering
+          (let* ((v (make-array (the fixnum (length instance-slots))))
+                 (i 0))
+            (declare (simple-vector v) (fixnum i))
+            (dolist (e instance-slots v)
+              (setf (svref v i)
+                    (%slot-definition-name e))
+              (incf i))))
+         (old-wrapper (%class-own-wrapper class))
+         (new-wrapper
+          (cond ((null old-wrapper)
+                 (%cons-wrapper class))
+                ((and old-wrapper *update-slots-preserve-existing-wrapper*)
+                 old-wrapper)
+                (t
+                 (make-instances-obsolete class)
+                 (%cons-wrapper class)))))
+    (setf (%class-slots class) eslotds)
+    (setf (%wrapper-instance-slots new-wrapper) new-ordering
+          (%wrapper-class-slots new-wrapper) (%class-get class :class-slots)
+          (%class-own-wrapper class) new-wrapper)
+    (setup-slot-lookup new-wrapper eslotds)))