[armedbear-cvs] r14092 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Wed Aug 15 00:12:24 2012
New Revision: 14092

Log:
Don't clobber class hierarchy when defining forward-referenced classes

- Use initargs when calling change-class for the class metaobject

- Robustify make-instances-obsolete against non-finalized
  classes (e.g. forward-referenced-class)

- Report and diagnosis by Stas Boukarev to armedbear-devel on August 11,
  2012 ("Forward referenced classes woes")

- Fixes ansi tests DEFCLASS.FORWARD-REF.3, DEFCLASS.FORWARD-REF.4

Modified:
   trunk/abcl/src/org/armedbear/lisp/Layout.java
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Layout.java	Tue Aug 14 14:53:16 2012	(r14091)
+++ trunk/abcl/src/org/armedbear/lisp/Layout.java	Wed Aug 15 00:12:24 2012	(r14092)
@@ -265,10 +265,20 @@
       {
         final LispObject lispClass = arg;
         LispObject oldLayout;
-        if (lispClass instanceof LispClass)
-            oldLayout = ((LispClass)lispClass).getClassLayout();
-        else
-            oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass);
+        // Non-finalized classes might not have a valid layout, but they do
+        // not have instances either so we can abort.
+        if (lispClass instanceof LispClass) {
+          if (!((LispClass)lispClass).isFinalized())
+            return arg;
+          oldLayout = ((LispClass)lispClass).getClassLayout();
+        } else if (lispClass instanceof StandardObject) {
+          if (((StandardObject)arg)
+              .getInstanceSlotValue(StandardClass.symFinalizedP) == NIL)
+            return arg;
+          oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass);
+        } else {
+          return error(new TypeError(arg, Symbol.CLASS));
+        }
 
         Layout newLayout = new Layout((Layout)oldLayout);
         if (lispClass instanceof LispClass)

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Tue Aug 14 14:53:16 2012	(r14091)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Wed Aug 15 00:12:24 2012	(r14092)
@@ -3125,7 +3125,7 @@
   (setf all-keys (copy-list all-keys))  ; since we modify it
   (remf all-keys :metaclass)
   (unless (classp metaclass) (setf metaclass (find-class metaclass)))
-  (change-class class metaclass)
+  (apply #'change-class class metaclass all-keys)
   (apply #'reinitialize-instance class
          :name name
          :direct-superclasses (canonicalize-direct-superclasses