0.9.14.29:

	Make REINITIALIZE-INSTANCE (well, SHARED-INITIALIZE in fact, but
	I'm pretty sure that's OK) call FINALIZE-INHERITANCE rather than
	UPDATE-CLASS if the class has already been finalized, as
	required by AMOP.

diff --git a/NEWS b/NEWS
index 54afc8b..cfc0b4b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -30,6 +30,9 @@ changes in sbcl-0.9.15 relative to sbcl-0.9.14:
   * fixed bug: SPECIALIZER metaobjects (including anonymous classes
     and EQL-SPECIALIZERs) can be used as specializers to DEFMETHOD.
     (reported by Pascal Costanza)
+  * fixed bug: FINALIZE-INHERITANCE is called from
+    REINITIALIZE-INSTANCE on classes when the class has previously
+    been finalized, as required by AMOP.
   * minor code generation optimizations:
     ** better register allocation in CLOS dispatching functions
     ** overflow detection when coercing signed bytes to fixnums on x86-64 

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 28bbf00..02862cf 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -408,27 +408,10 @@
                     (push old collect)))))
           (nreverse collect)))
   (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
-  (do* ((slots (slot-value class 'slots) (cdr slots))
-        (dupes nil))
-       ((null slots) (when dupes
-                       (style-warn
-                        ;; FIXME: the indentation request ("~4I")
-                        ;; below appears not to do anything.  Finding
-                        ;; out why would be nice.  -- CSR, 2003-04-24
-                        "~@<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))))
+  (if (class-finalized-p class)
+      ;; required by AMOP, "Reinitialization of Class Metaobjects"
+      (finalize-inheritance class)
+      (update-class class nil))
   (add-slot-accessors class direct-slots)
   (make-preliminary-layout class))
 
@@ -880,7 +863,25 @@
               (wrapper-instance-slots-layout nwrapper) nlayout
               (wrapper-class-slots nwrapper) nwrapper-class-slots
               (wrapper-no-of-instance-slots nwrapper) nslots
-              wrapper nwrapper))
+              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)
       (unless (eq owrapper nwrapper)
         (update-pv-table-cache-info class)

diff --git a/tests/mop-18.impure-cload.lisp b/tests/mop-18.impure-cload.lisp
new file mode 100644 (file)
index 0000000..925c4ae
--- /dev/null
+++ b/tests/mop-18.impure-cload.lisp
@@ -0,0 +1,80 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file tests the protocol for Reinitialization of Class Metaobjects
+
+(defpackage "MOP-18"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-18")
+
+(defvar *in-reinitialize-instance* nil)
+
+(defvar *finalized-class* nil)
+
+(defclass test-standard-class (standard-class) ())
+
+(defmethod validate-superclass
+    ((class test-standard-class) (superclass standard-class))
+  t)
+
+(defmethod finalize-inheritance :before ((class test-standard-class))
+  (when *in-reinitialize-instance*
+    (setf *finalized-class* class)))
+
+(defmethod reinitialize-instance :around 
+    ((class test-standard-class) &key &allow-other-keys)
+  (let ((*in-reinitialize-instance* t))
+    (call-next-method)))
+
+(defclass test-standard-object () ((slot))
+  (:metaclass test-standard-class))
+
+(unless (class-finalized-p (find-class 'test-standard-object))
+  (finalize-inheritance (find-class 'test-standard-object)))
+
+(assert (class-slots (find-class 'test-standard-object)))
+(assert (null *finalized-class*))
+(reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
+(assert (eq *finalized-class* (find-class 'test-standard-object)))
+(assert (null (class-slots (find-class 'test-standard-object))))
+\f
+(defclass test-funcallable-standard-class (funcallable-standard-class) ())
+
+(defmethod validate-superclass
+    ((class test-funcallable-standard-class) 
+     (superclass funcallable-standard-class))
+  t)
+
+(defmethod finalize-inheritance :before 
+    ((class test-funcallable-standard-class))
+  (when *in-reinitialize-instance*
+    (setf *finalized-class* class)))
+
+(defmethod reinitialize-instance :around 
+    ((class test-funcallable-standard-class) &key &allow-other-keys)
+  (let ((*in-reinitialize-instance* t))
+    (call-next-method)))
+
+(defclass test-funcallable-standard-object () ((slot))
+  (:metaclass test-funcallable-standard-class))
+
+(unless (class-finalized-p (find-class 'test-funcallable-standard-object))
+  (finalize-inheritance (find-class 'test-funcallable-standard-object)))
+
+(assert (class-slots (find-class 'test-funcallable-standard-object)))
+(assert (eq *finalized-class* (find-class 'test-standard-object)))
+(reinitialize-instance (find-class 'test-funcallable-standard-object) 
+                       :direct-slots nil)
+(assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
+(assert (null (class-slots (find-class 'test-funcallable-standard-object))))
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index dcae6c5..55655dd 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.14.28"
+"0.9.14.29"