clos: ensure correct class stamps

- we did not distinguish between classes that had no slots and classes that
  had no been iniutialized - that led to incorrect class stamps

- structures had no initial class stamp matching their structure

- structures when slot names chagned had their stamp increased despite not
  really changing

src/c/clos/instance.d

@@ -43,11 +43,6 @@ si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size)
 cl_object
 si_instance_obsolete_p(cl_object x)
 {
-  /* Each class has a slot class_stamp and each instance has a slot
-     stamp. When an instance stamp its class class_stamp don't match,
-     then the instance is obsolete. Structure stamp is always 0. */
-  if (x->instance.stamp == 0)
-    return ECL_NIL;
   return (x->instance.stamp != ECL_CLASS_OF(x)->instance.class_stamp)
     ? ECL_T : ECL_NIL;
 }

src/c/structure.d

@@ -50,6 +50,7 @@ si_structure_subtype_p(cl_object x, cl_object y)
   ECL_STRUCT_LENGTH(x) = --narg;
   ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object));
   x->instance.slotds = ECL_UNBOUND;
+  x->instance.stamp = ECL_CLASS_OF(x)->instance.class_stamp;
   if (narg >= ECL_SLOTS_LIMIT)
     FEerror("Limit on structure size exceeded: ~S slots requested.",
             1, ecl_make_fixnum(narg));

src/clos/boot.lsp

@@ -117,6 +117,7 @@
     ;;
     ;; 3) Finalize
     ;;
+    (mapc #'si::instance-new-stamp all-classes)
     (mapc #'si::instance-sig-set all-classes)
     ;;
     ;; 4) This is needed for further optimization

src/clos/change.lsp

@@ -251,6 +251,10 @@
   (si::instance-new-stamp class)
   class)
 
+;;; Structures can't be redefined in an incompatible way.
+(defmethod make-instances-obsolete ((class structure-class))
+  class)
+
 (defun remove-optional-slot-accessors (class)
   (declare (class class)
            (optimize (safety 0))

src/clos/combin.lsp

@@ -359,10 +359,10 @@
   (let ((form (compute-effective-method gf method-combination applicable-methods)))
     (let ((aux form) f)
       (if (and (listp aux)
-                 (eq (pop aux) 'funcall)
-                 (functionp (setf f (pop aux)))
-                 (eq (pop aux) '.combined-method-args.)
-                 (eq (pop aux) '*next-methods*))
+               (eq (pop aux) 'funcall)
+               (functionp (setf f (pop aux)))
+               (eq (pop aux) '.combined-method-args.)
+               (eq (pop aux) '*next-methods*))
           f
           (effective-method-function form t)))))
 

src/clos/standard.lsp

@@ -98,13 +98,10 @@
 
 (defmethod allocate-instance ((class class) &rest initargs)
   (declare (ignore initargs))
-  ;; As pointed out in the CLASP source code (after Dr. Strandh), the
-  ;; class is already finalized, because initargs can't be computed
-  ;; without finalizing the class. We keep the next form to be on a
-  ;; safe side, but under normal circumstances it is never executed.
-  (unless (class-finalized-p class)
-    ;; FIXME! Inefficient! We should keep a list of dependent classes.
-    (finalize-inheritance class))
+  ;; As pointed out in the CLASP source code (after Dr. Strandh), the class is
+  ;; already finalized, because initargs can't be computed without finalizing
+  ;; the class. -- jd 2021-12-10
+  (assert (class-finalized-p class))
   (let ((x (si::allocate-raw-instance nil class (class-size class))))
     (si::instance-sig-set x)
     x))
@@ -307,8 +304,9 @@ because it contains a reference to the undefined class~%  ~A"
           (finalize-inheritance x))))
 
     (setf (class-precedence-list class) cpl)
-    (let ((oslotds (and (slot-boundp class 'slots) (class-slots class)))
-          (nslotds (compute-slots class)))
+    (let* ((oslotds-p (slot-boundp class 'slots))
+           (oslotds (and oslotds-p (class-slots class)))
+           (nslotds (compute-slots class)))
       (setf (class-slots class) nslotds
             (class-size class) (compute-instance-size nslotds)
             (class-default-initargs class) (compute-default-initargs class)
@@ -356,8 +354,13 @@ because it contains a reference to the undefined class~%  ~A"
       ;; Make all class instances obsolete when slot definitions are
       ;; not compatible.
       ;;
-      (unless (slot-definitions-compatible-p oslotds nslotds)
-        (make-instances-obsolete class)))
+      (cond ((null oslotds-p)
+             ;; Assign the initial class stamp when the class had no slots.
+             ;; That is because for structure class MAKE-INSTANCES-OBSOLETE
+             ;; doesn't update the stamp.
+             (si::instance-new-stamp class))
+            ((not (slot-definitions-compatible-p oslotds nslotds))
+             (make-instances-obsolete class))))
     ;;
     ;; Clear the different type caches for type comparisons and so on.
     ;;