Changeset 12576

Timestamp:

03/28/10 20:13:14 (13 years ago)

Author:

ehuelsmann

Message:

Re #38: Merge the METACLASS branch to trunk.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• Condition.java (modified) (2 diffs)
• Layout.java (modified) (7 diffs)
• Lisp.java (modified) (1 diff)
• LispClass.java (modified) (8 diffs)
• LispObject.java (modified) (1 diff)
• Primitives.java (modified) (11 diffs)
• SlotClass.java (modified) (8 diffs)
• SlotDefinition.java (modified) (3 diffs)
• StandardClass.java (modified) (16 diffs)
• StandardGenericFunction.java (modified) (1 diff)
• StandardMethod.java (modified) (1 diff)
• StandardObject.java (modified) (5 diffs)
• StandardObjectFunctions.java (modified) (1 diff)
• Symbol.java (modified) (3 diffs)
• clos.lisp (modified) (23 diffs)
• compiler-pass2.lisp (modified) (4 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -686 +686 @@
         autoload(Symbol.SET_SCHAR, "StringFunctions");
 
-        autoload(Symbol.SET_CLASS_SLOTS, "SlotClass");
+        autoload(Symbol._SET_CLASS_SLOTS, "SlotClass");
         autoload(Symbol._CLASS_SLOTS, "SlotClass");
 

trunk/abcl/src/org/armedbear/lisp/Condition.java

@@ -142 +142 @@
   public LispObject typeOf()
   {
-    LispClass c = getLispClass();
-    if (c != null)
-      return c.getName();
+    LispObject c = getLispClass();
+    if (c instanceof LispClass)
+        return ((LispClass)c).getName();
+    else if (c != null)
+      return Symbol.CLASS_NAME.execute(c);
     return Symbol.CONDITION;
   }
@@ -151 +153 @@
   public LispObject classOf()
   {
-    LispClass c = getLispClass();
+    LispObject c = getLispClass();
     if (c != null)
       return c;

trunk/abcl/src/org/armedbear/lisp/Layout.java

@@ -38 +38 @@
 public class Layout extends LispObject
 {
-  private final LispClass lispClass;
+  private final LispObject lispClass;
   public final EqHashTable slotTable;
 
@@ -46 +46 @@
   private boolean invalid;
 
-  public Layout(LispClass lispClass, LispObject instanceSlots, LispObject sharedSlots)
+  public Layout(LispObject lispClass, LispObject instanceSlots, LispObject sharedSlots)
   {
     this.lispClass = lispClass;
@@ -65 +65 @@
   }
 
-  public Layout(LispClass lispClass, LispObject[] instanceSlotNames,
+  public Layout(LispObject lispClass, LispObject[] instanceSlotNames,
                 LispObject sharedSlots)
   {
@@ -104 +104 @@
   }
 
-  public LispClass getLispClass()
+  public LispObject getLispClass()
   {
     return lispClass;
@@ -160 +160 @@
 
       {
-          return new Layout(checkClass(first), checkList(second),
-                              checkList(third));
+          return new Layout(first, checkList(second), checkList(third));
       }
 
@@ -236 +235 @@
 
       {
-                final Layout layOutFirst = checkLayout(first);
+            final Layout layOutFirst = checkLayout(first);
             final LispObject slotNames[] = layOutFirst.slotNames;
             final int limit = slotNames.length;
@@ -264 +263 @@
       public LispObject execute(LispObject arg)
       {
-        final LispClass lispClass = checkClass(arg);
-        Layout oldLayout = lispClass.getClassLayout();
-        Layout newLayout = new Layout(oldLayout);
-        lispClass.setClassLayout(newLayout);
-        oldLayout.invalidate();
+        final LispObject lispClass = arg;
+        LispObject oldLayout;
+        if (lispClass instanceof LispClass)
+            oldLayout = ((LispClass)lispClass).getClassLayout();
+        else
+            oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass);
+
+        Layout newLayout = new Layout((Layout)oldLayout);
+        if (lispClass instanceof LispClass)
+          ((LispClass)lispClass).setClassLayout(newLayout);
+        else
+          Symbol.CLASS_LAYOUT.getSymbolSetfFunction()
+              .execute(newLayout, lispClass);
+        ((Layout)oldLayout).invalidate();
         return arg;
       }

trunk/abcl/src/org/armedbear/lisp/Lisp.java

@@ -1654 +1654 @@
   }
   
-  public final static LispClass checkClass(LispObject obj) 
-
-   {
-          if (obj instanceof LispClass)         
-                  return (LispClass) obj;                         
-          return (LispClass)// Not reached.                    
-                type_error(obj, Symbol.CLASS);
-   }   
-
   public final static Layout checkLayout(LispObject obj) 
 

trunk/abcl/src/org/armedbear/lisp/LispClass.java

@@ -49 +49 @@
   }
 
+  public static LispObject addClass(Symbol symbol, LispObject c)
+  {
+    synchronized (map)
+      {
+        map.put(symbol, c);
+      }
+    return c;
+  }
+
   public static void removeClass(Symbol symbol)
   {
@@ -69 +78 @@
   {
     final Symbol symbol = checkSymbol(name);
-    final LispClass c;
-    synchronized (map)
-      {
-        c = (LispClass) map.get(symbol);
+    final LispObject c;
+    synchronized (map)
+      {
+        c = map.get(symbol);
       }
     if (c != null)
@@ -180 +189 @@
   }
 
-  public void setClassLayout(Layout layout)
-  {
-    classLayout = layout;
+  public void setClassLayout(LispObject layout)
+  {
+    classLayout = layout == NIL ? null : (Layout)layout;
   }
 
@@ -202 +211 @@
   }
 
-  public final boolean isFinalized()
+  public boolean isFinalized()
   {
     return finalized;
   }
 
-  public final void setFinalized(boolean b)
+  public void setFinalized(boolean b)
   {
     finalized = b;
@@ -292 +301 @@
   public boolean subclassp(LispObject obj)
   {
-    LispObject cpl = getCPL();
+    return false;
+  }
+
+  public static boolean subclassp(LispObject cls, LispObject obj)
+  {
+    LispObject cpl;
+
+    if (cls instanceof LispClass)
+      cpl = ((LispClass)cls).getCPL();
+    else
+      cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls);
+
     while (cpl != NIL)
       {
@@ -299 +319 @@
         cpl = ((Cons)cpl).cdr;
       }
+
+    if (cls instanceof LispClass)
+      // additional checks (currently because of JavaClass)
+      return ((LispClass)cls).subclassp(obj);
+
     return false;
   }
@@ -341 +366 @@
             return second;
           }
-        final LispClass c = checkClass(second);
-        addClass(name, c);
+        addClass(name, second);
         return second;
       }
@@ -355 +379 @@
 
       {
-        final LispClass c = checkClass(first);
-        return c.subclassp(second) ? T : NIL;
+        return LispClass.subclassp(first, second) ? T : NIL;
       }
     };

trunk/abcl/src/org/armedbear/lisp/LispObject.java

@@ -678 +678 @@
   }
 
+  public LispObject getSymbolSetfFunction()
+  {
+    return type_error(this, Symbol.SYMBOL);
+  }
+
+  public LispObject getSymbolSetfFunctionOrDie()
+  {
+    return type_error(this, Symbol.SYMBOL);
+  }
+
   public String writeToString()
   {

trunk/abcl/src/org/armedbear/lisp/Primitives.java

@@ -5317 +5317 @@
         @Override
         public LispObject execute(LispObject arg) {
-            return checkClass(arg).getName();
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getName();
+
+            return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
         }
     };
@@ -5332 +5335 @@
 
         {
-            checkClass(first).setName(checkSymbol(second));
-            return second;
+            if (second instanceof LispClass)
+                ((LispClass)second).setName(checkSymbol(first));
+            else
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
+                                                           checkSymbol(first));
+            return first;
         }
     };
 
     // ### class-layout
-    private static final Primitive CLASS_LAYOUT = new pf_class_layout();
-    private static final class pf_class_layout extends Primitive {
-        pf_class_layout() {
-            super("class-layout", PACKAGE_SYS, true, "class");
-        }
-
-        @Override
-        public LispObject execute(LispObject arg) {
-            Layout layout = checkClass(arg).getClassLayout();
+    private static final Primitive CLASS_LAYOUT = new pf__class_layout();
+    private static final class pf__class_layout extends Primitive {
+        pf__class_layout() {
+            super("%class-layout", PACKAGE_SYS, true, "class");
+        }
+
+        @Override
+        public LispObject execute(LispObject arg) {
+            Layout layout;
+            if (arg instanceof LispClass)
+              layout = ((LispClass)arg).getClassLayout();
+            else
+              layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
+
             return layout != null ? layout : NIL;
         }
@@ -5362 +5374 @@
 
         {
-            if (second instanceof Layout) {
-                checkClass(first).setClassLayout((Layout)second);
-                return second;
-            }
-            return type_error(second, Symbol.LAYOUT);
-        }
-    };
-
-    // ### class-direct-superclasses
-    private static final Primitive CLASS_DIRECT_SUPERCLASSES = new pf_class_direct_superclasses();
-    private static final class pf_class_direct_superclasses extends Primitive {
-        pf_class_direct_superclasses() {
-            super("class-direct-superclasses", PACKAGE_SYS, true);
-        }
-
-        @Override
-        public LispObject execute(LispObject arg) {
-            return checkClass(arg).getDirectSuperclasses();
+            if (first == NIL || first instanceof Layout) {
+                if (second instanceof LispClass)
+                  ((LispClass)second).setClassLayout(first);
+                else
+                  ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
+                return first;
+            }
+            return type_error(first, Symbol.LAYOUT);
+        }
+    };
+
+    // ### %class-direct-superclasses
+    private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
+    private static final class pf__class_direct_superclasses extends Primitive {
+        pf__class_direct_superclasses() {
+            super("%class-direct-superclasses", PACKAGE_SYS, true);
+        }
+
+        @Override
+        public LispObject execute(LispObject arg) {
+            if (arg instanceof LispClass)
+              return ((LispClass)arg).getDirectSuperclasses();
+            else
+              return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
         }
     };
@@ -5392 +5410 @@
         @Override
         public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setDirectSuperclasses(second);
-            return second;
-        }
-    };
-
-    // ### class-direct-subclasses
-    private static final Primitive CLASS_DIRECT_SUBCLASSES = new pf_class_direct_subclasses();
-    private static final class pf_class_direct_subclasses extends Primitive {
-        pf_class_direct_subclasses() {
-            super("class-direct-subclasses", PACKAGE_SYS, true);
-        }
-
-        @Override
-        public LispObject execute(LispObject arg) {
-            return checkClass(arg).getDirectSubclasses();
+        {
+            if (second instanceof LispClass)
+              ((LispClass)second).setDirectSuperclasses(first);
+            else
+              ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
+            return first;
+        }
+    };
+
+    // ### %class-direct-subclasses
+    private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
+    private static final class pf__class_direct_subclasses extends Primitive {
+        pf__class_direct_subclasses() {
+            super("%class-direct-subclasses", PACKAGE_SYS, true);
+        }
+
+        @Override
+        public LispObject execute(LispObject arg) {
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getDirectSubclasses();
+            else
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
         }
     };
@@ -5422 +5445 @@
         @Override
         public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setDirectSubclasses(second);
-            return second;
+        {
+            if (second instanceof LispClass)
+                ((LispClass)second).setDirectSubclasses(first);
+            else
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
+            return first;
         }
     };
@@ -5438 +5463 @@
         @Override
         public LispObject execute(LispObject arg) {
-            return checkClass(arg).getCPL();
-        }
-    };
-
-    // ### set-class-precedence-list
-    private static final Primitive SET_CLASS_PRECEDENCE_LIST = new pf_set_class_precedence_list();
-    private static final class pf_set_class_precedence_list extends Primitive {
-        pf_set_class_precedence_list() {
-            super("set-class-precedence-list", PACKAGE_SYS, true);
-        }
-
-        @Override
-        public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setCPL(second);
-            return second;
-        }
-    };
-
-    // ### class-direct-methods
-    private static final Primitive CLASS_DIRECT_METHODS = new pf_class_direct_methods();
-    private static final class pf_class_direct_methods extends Primitive {
-        pf_class_direct_methods() {
-            super("class-direct-methods", PACKAGE_SYS, true);
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getCPL();
+            else
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
+        }
+    };
+
+    // ### %set-class-precedence-list
+    private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
+    private static final class pf__set_class_precedence_list extends Primitive {
+        pf__set_class_precedence_list() {
+            super("%set-class-precedence-list", PACKAGE_SYS, true);
+        }
+
+        @Override
+        public LispObject execute(LispObject first, LispObject second)
+        {
+            if (second instanceof LispClass)
+                ((LispClass)second).setCPL(first);
+            else
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
+            return first;
+        }
+    };
+
+    // ### %class-direct-methods
+    private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
+    private static final class pf__class_direct_methods extends Primitive {
+        pf__class_direct_methods() {
+            super("%class-direct-methods", PACKAGE_SYS, true);
         }
 
         @Override
         public LispObject execute(LispObject arg)
-
-        {
-            return checkClass(arg).getDirectMethods();
+        {
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getDirectMethods();
+            else
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
         }
     };
@@ -5482 +5514 @@
         @Override
         public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setDirectMethods(second);
-            return second;
+        {
+            if (second instanceof LispClass)
+                ((LispClass)second).setDirectMethods(first);
+            else
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
+            return first;
         }
     };
@@ -5501 +5535 @@
 
         {
-            return checkClass(arg).getDocumentation();
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getDocumentation();
+            else
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
         }
     };
@@ -5515 +5552 @@
         @Override
         public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setDocumentation(second);
+        {
+            if (first instanceof LispClass)
+                ((LispClass)first).setDocumentation(second);
+            else
+                ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
             return second;
         }
     };
 
-    // ### class-finalized-p
-    private static final Primitive CLASS_FINALIZED_P = new pf_class_finalized_p();
-    private static final class pf_class_finalized_p extends Primitive {
-        pf_class_finalized_p() {
-            super("class-finalized-p", PACKAGE_SYS, true);
-        }
-
-        @Override
-        public LispObject execute(LispObject arg) {
-            return checkClass(arg).isFinalized() ? T : NIL;
+    // ### %class-finalized-p
+    private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
+    private static final class pf__class_finalized_p extends Primitive {
+        pf__class_finalized_p() {
+            super("%class-finalized-p", PACKAGE_SYS, true);
+        }
+
+        @Override
+        public LispObject execute(LispObject arg) {
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).isFinalized() ? T : NIL;
+            else
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
         }
     };
@@ -5544 +5586 @@
         @Override
         public LispObject execute(LispObject first, LispObject second)
-
-        {
-            checkClass(first).setFinalized(second != NIL);
-            return second;
+        {
+            if (second instanceof LispClass)
+                ((LispClass)second).setFinalized(first != NIL);
+            else
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
+            return first;
         }
     };
@@ -5560 +5604 @@
         @Override
         public LispObject execute(LispObject arg) {
-            return arg instanceof LispClass ? T : NIL;
+            return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
         }
     };

trunk/abcl/src/org/armedbear/lisp/SlotClass.java

@@ -179 +179 @@
     // ### class-direct-slots
     private static final Primitive CLASS_DIRECT_SLOTS =
-        new Primitive("class-direct-slots", PACKAGE_SYS, true)
+        new Primitive("%class-direct-slots", PACKAGE_SYS, true)
     {
         @Override
@@ -201 +201 @@
 
         {
-                if (first instanceof SlotClass) {
-                  ((SlotClass)first).setDirectSlotDefinitions(second);
-                return second;
+                if (second instanceof SlotClass) {
+                  ((SlotClass)second).setDirectSlotDefinitions(first);
+                return first;
             }
                 else {
-                return type_error(first, Symbol.STANDARD_CLASS);
+                return type_error(second, Symbol.STANDARD_CLASS);
             }
         }
@@ -228 +228 @@
 
     // ### set-class-slots
-    private static final Primitive SET_CLASS_SLOTS =
-        new Primitive(Symbol.SET_CLASS_SLOTS, "class slot-definitions")
+    private static final Primitive _SET_CLASS_SLOTS =
+        new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions")
     {
         @Override
@@ -235 +235 @@
 
         {
-            if (first instanceof SlotClass) {
-              ((SlotClass)first).setSlotDefinitions(second);
-              return second;
+            if (second instanceof SlotClass) {
+              ((SlotClass)second).setSlotDefinitions(first);
+              return first;
             }
             else {
-              return type_error(first, Symbol.STANDARD_CLASS);
+              return type_error(second, Symbol.STANDARD_CLASS);
             }
         }
@@ -247 +247 @@
     // ### class-direct-default-initargs
     private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS =
-        new Primitive("class-direct-default-initargs", PACKAGE_SYS, true)
+        new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true)
     {
         @Override
@@ -269 +269 @@
 
         {
-            if (first instanceof SlotClass) {
-              ((SlotClass)first).setDirectDefaultInitargs(second);
-              return second;
-            }
-            return type_error(first, Symbol.STANDARD_CLASS);
+            if (second instanceof SlotClass) {
+              ((SlotClass)second).setDirectDefaultInitargs(first);
+              return first;
+            }
+            return type_error(second, Symbol.STANDARD_CLASS);
         }
     };
@@ -279 +279 @@
     // ### class-default-initargs
     private static final Primitive CLASS_DEFAULT_INITARGS =
-        new Primitive("class-default-initargs", PACKAGE_SYS, true)
+        new Primitive("%class-default-initargs", PACKAGE_SYS, true)
     {
         @Override
@@ -301 +301 @@
 
         {
-            if (first instanceof SlotClass) {
-                ((SlotClass)first).setDefaultInitargs(second);
-                return second;
-            }
-            return type_error(first, Symbol.STANDARD_CLASS);
-        }
-    };
-
-    // ### compute-class-default-initargs
-    private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS =
-        new Primitive("compute-class-default-initargs", PACKAGE_SYS, true)
-    {
-        @Override
-        public LispObject execute(LispObject arg)
-
-        {
-            final SlotClass c;
-            if (arg instanceof SlotClass) {
-                c = (SlotClass) arg;
-            }
-            else {
-                return type_error(arg, Symbol.STANDARD_CLASS);
-            }
-            return c.computeDefaultInitargs();
-        }
-    };
+            if (second instanceof SlotClass) {
+                ((SlotClass)second).setDefaultInitargs(first);
+                return first;
+            }
+            return type_error(second, Symbol.STANDARD_CLASS);
+        }
+    };
+
 }

trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

@@ -70 +70 @@
     slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
   }
-  
+
+  public SlotDefinition(LispObject name, LispObject readers,
+                        Function initFunction)
+  {
+    this();
+    Debug.assertTrue(name instanceof Symbol);
+    slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name;
+    slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = initFunction;
+    slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = NIL;
+    slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] =
+      new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName()));
+    slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers;
+    slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
+  }
+
   public static SlotDefinition checkSlotDefinition(LispObject obj) {
           if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
@@ -148 +162 @@
 
   // ### set-slot-definition-initfunction
-  private static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
+  static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
     new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true,
                   "slot-definition initfunction")
@@ -174 +188 @@
 
   // ### set-slot-definition-initform
-  private static final Primitive SET_SLOT_DEFINITION_INITFORM =
+  static final Primitive SET_SLOT_DEFINITION_INITFORM =
     new Primitive("set-slot-definition-initform", PACKAGE_SYS, true,
                   "slot-definition initform")

trunk/abcl/src/org/armedbear/lisp/StandardClass.java

@@ -39 +39 @@
 {
 
-  private static Symbol symName = PACKAGE_MOP.intern("NAME");
-  private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
-  private static Symbol symDirectSuperclasses
+  public static Symbol symName = PACKAGE_MOP.intern("NAME");
+  public static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
+  public static Symbol symDirectSuperclasses
     = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
-  private static Symbol symDirectSubclasses
+  public static Symbol symDirectSubclasses
     = PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
-  private static Symbol symClassPrecedenceList
-    = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
-  private static Symbol symDirectMethods
+  public static Symbol symPrecedenceList
+    = PACKAGE_MOP.intern("PRECEDENCE-LIST");
+  public static Symbol symDirectMethods
     = PACKAGE_MOP.intern("DIRECT-METHODS");
-  private static Symbol symDocumentation
+  public static Symbol symDocumentation
     = PACKAGE_MOP.intern("DOCUMENTATION");
-  private static Symbol symDirectSlots
+  public static Symbol symDirectSlots
     = PACKAGE_MOP.intern("DIRECT-SLOTS");
-  private static Symbol symSlots
+  public static Symbol symSlots
     = PACKAGE_MOP.intern("SLOTS");
-  private static Symbol symDirectDefaultInitargs
+  public static Symbol symDirectDefaultInitargs
     = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
-  private static Symbol symDefaultInitargs
+  public static Symbol symDefaultInitargs
     = PACKAGE_MOP.intern("DEFAULT-INITARGS");
+  public static Symbol symFinalizedP
+    = PACKAGE_MOP.intern("FINALIZED-P");
 
   static Layout layoutStandardClass =
@@ -66 +68 @@
                       symDirectSuperclasses,
                       symDirectSubclasses,
-                      symClassPrecedenceList,
+                      symPrecedenceList,
                       symDirectMethods,
                       symDocumentation,
@@ -72 +74 @@
                       symSlots,
                       symDirectDefaultInitargs,
-                      symDefaultInitargs),
+                      symDefaultInitargs,
+                      symFinalizedP),
                  NIL)
       {
@@ -87 +90 @@
       setDirectSuperclasses(NIL);
       setDirectSubclasses(NIL);
+      setClassLayout(layoutStandardClass);
       setCPL(NIL);
       setDirectMethods(NIL);
@@ -94 +98 @@
       setDirectDefaultInitargs(NIL);
       setDefaultInitargs(NIL);
+      setFinalized(false);
   }
 
@@ -101 +106 @@
             symbol, directSuperclasses);
       setDirectSubclasses(NIL);
+      setClassLayout(layoutStandardClass);
       setCPL(NIL);
       setDirectMethods(NIL);
@@ -108 +114 @@
       setDirectDefaultInitargs(NIL);
       setDefaultInitargs(NIL);
+      setFinalized(false);
   }
 
@@ -130 +137 @@
 
   @Override
-  public void setClassLayout(Layout newLayout)
+  public void setClassLayout(LispObject newLayout)
   {
     setInstanceSlotValue(symLayout, newLayout);
@@ -148 +155 @@
 
   @Override
+  public final boolean isFinalized()
+  {
+    return getInstanceSlotValue(symFinalizedP) != NIL;
+  }
+
+  @Override
+  public final void setFinalized(boolean b)
+  {
+    setInstanceSlotValue(symFinalizedP, b ? T : NIL);
+  }
+
+  @Override
   public LispObject getDirectSubclasses()
   {
@@ -162 +181 @@
   public LispObject getCPL()
   {
-    return getInstanceSlotValue(symClassPrecedenceList);
+    return getInstanceSlotValue(symPrecedenceList);
   }
 
@@ -170 +189 @@
     LispObject obj1 = cpl[0];
     if (obj1.listp() && cpl.length == 1)
-      setInstanceSlotValue(symClassPrecedenceList, obj1);
+      setInstanceSlotValue(symPrecedenceList, obj1);
     else
       {
@@ -177 +196 @@
         for (int i = cpl.length; i-- > 0;)
             l = new Cons(cpl[i], l);
-        setInstanceSlotValue(symClassPrecedenceList, l);
+        setInstanceSlotValue(symPrecedenceList, l);
       }
   }
@@ -253 +272 @@
   }
 
-
+  @Override
+  public LispObject typeOf()
+  {
+    return Symbol.STANDARD_CLASS;
+  }
 
   @Override
@@ -298 +321 @@
   }
 
+  private static final LispObject standardClassSlotDefinitions()
+  {
+      // (CONSTANTLY NIL)
+    Function initFunction = new Function() {
+      @Override
+      public LispObject execute()
+      {
+         return NIL;
+      }
+    };
+
+    return
+        list(helperMakeSlotDefinition("NAME", initFunction),
+             helperMakeSlotDefinition("LAYOUT", initFunction),
+             helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction),
+             helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction),
+             helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction),
+             helperMakeSlotDefinition("DIRECT-METHODS", initFunction),
+             helperMakeSlotDefinition("DIRECT-SLOTS", initFunction),
+             helperMakeSlotDefinition("SLOTS", initFunction),
+             helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction),
+             helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction),
+             helperMakeSlotDefinition("FINALIZED-P", initFunction));
+  }
+
+
+
+  private static final SlotDefinition helperMakeSlotDefinition(String name,
+                                                               Function init)
+  {
+    return
+        new SlotDefinition(PACKAGE_MOP.intern(name),   // name
+             list(PACKAGE_MOP.intern("CLASS-" + name)), // readers
+             init);
+  }
+
   private static final StandardClass addStandardClass(Symbol name,
                                                       LispObject directSuperclasses)
@@ -322 +381 @@
 
     STANDARD_CLASS.setClassLayout(layoutStandardClass);
-    STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
+    STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
   }
 
@@ -617 +676 @@
 
     // Condition classes.
+    STANDARD_CLASS.finalizeClass();
     ARITHMETIC_ERROR.finalizeClass();
     CELL_ERROR.finalizeClass();

trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

@@ -210 +210 @@
       {
         StringBuilder sb = new StringBuilder();
-        sb.append(getLispClass().getName().writeToString());
+        LispObject className;
+        LispObject lispClass = getLispClass();
+        if (lispClass instanceof LispClass)
+          className = ((LispClass)lispClass).getName();
+        else
+          className = Symbol.CLASS_NAME.execute(lispClass);
+
+        sb.append(className.writeToString());
         sb.append(' ');
         sb.append(name.writeToString());

trunk/abcl/src/org/armedbear/lisp/StandardMethod.java

@@ -157 +157 @@
           {
             StringBuilder sb = new StringBuilder();
-            sb.append(getLispClass().getName().writeToString());
+            LispObject className;
+            LispObject lispClass = getLispClass();
+            if (lispClass instanceof LispClass)
+              className = ((LispClass)lispClass).getName();
+            else
+              className = Symbol.CLASS_NAME.execute(lispClass);
+
+            sb.append(className.writeToString());
             sb.append(' ');
             sb.append(name.writeToString());

trunk/abcl/src/org/armedbear/lisp/StandardObject.java

@@ -47 +47 @@
 
 
+  protected StandardObject(Layout layout)
+  {
+    this(layout, layout.getLength());
+  }
+
   protected StandardObject(Layout layout, int length)
   {
@@ -99 +104 @@
   }
 
-  public final LispClass getLispClass()
+  public final LispObject getLispClass()
   {
     return layout.getLispClass();
+  }
+
+  private LispObject helperGetClassName()
+  {
+    final LispObject c1 = layout.getLispClass();
+    if (c1 instanceof LispClass)
+        return ((LispClass)c1).getName();
+    else
+        return LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);
+  }
+
+  private LispObject helperGetCPL()
+  {
+    final LispObject c1 = layout.getLispClass();
+    if (c1 instanceof LispClass)
+        return ((LispClass)c1).getCPL();
+    else
+        return LispThread.currentThread().execute(Symbol.CLASS_PRECEDENCE_LIST, c1);
   }
 
@@ -111 +134 @@
     // CLASS-OF if it has a proper name, and otherwise returns the class
     // itself."
-    final LispClass c1 = layout.getLispClass();
+    final LispObject c1 = layout.getLispClass();
+    LispObject name;
+    if (c1 instanceof LispClass)
+        name = ((LispClass)c1).getName();
+    else
+        name = LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);
+
     // The proper name of a class is "a symbol that names the class whose
     // name is that symbol".
-    final LispObject name = c1.getName();
     if (name != NIL && name != UNBOUND_VALUE)
       {
         // TYPE-OF.9
-        final LispObject c2 = LispClass.findClass(checkSymbol(name));
+        final LispObject c2 = LispClass.findClass(name, false);
         if (c2 == c1)
           return name;
@@ -138 +166 @@
     if (type == StandardClass.STANDARD_OBJECT)
       return T;
-    LispClass cls = layout != null ? layout.getLispClass() : null;
+    LispObject cls = layout != null ? layout.getLispClass() : null;
     if (cls != null)
       {
         if (type == cls)
           return T;
-        if (type == cls.getName())
+        if (type == helperGetClassName())
           return T;
-        LispObject cpl = cls.getCPL();
+        LispObject cpl = helperGetCPL();
         while (cpl != NIL)
           {
             if (type == cpl.car())
               return T;
-            if (type == ((LispClass)cpl.car()).getName())
-              return T;
+
+            LispObject otherName;
+            LispObject otherClass = cpl.car();
+            if (otherClass instanceof LispClass) {
+              if (type == ((LispClass)otherClass).getName())
+                return T;
+            }
+            else
+            if (type == LispThread
+                .currentThread().execute(Symbol.CLASS_NAME, otherClass))
+                return T;
+
             cpl = cpl.cdr();
           }
@@ -184 +222 @@
     Debug.assertTrue(layout.isInvalid());
     Layout oldLayout = layout;
-    LispClass cls = oldLayout.getLispClass();
-    Layout newLayout = cls.getClassLayout();
+    LispObject cls = oldLayout.getLispClass();
+    Layout newLayout;
+
+    if (cls instanceof LispClass)
+        newLayout = ((LispClass)cls).getClassLayout();
+    else
+        newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls);
+
     Debug.assertTrue(!newLayout.isInvalid());
-    StandardObject newInstance = new StandardObject(cls);
+    StandardObject newInstance = new StandardObject(newLayout);
     Debug.assertTrue(newInstance.layout == newLayout);
     LispObject added = NIL;

trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java

@@ -48 +48 @@
           return new StandardClass();
         if (arg instanceof StandardClass)
-                return ((StandardClass)arg).allocateInstance();
+            return ((StandardClass)arg).allocateInstance();
+        if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
+            Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg);
+            return new StandardObject(layout);
+        }
         return type_error(arg, Symbol.STANDARD_CLASS);
       }

trunk/abcl/src/org/armedbear/lisp/Symbol.java

@@ -391 +391 @@
   }
 
+  @Override
+  public final LispObject getSymbolSetfFunction()
+  {
+    return get(this, Symbol.SETF_FUNCTION, NIL);
+  }
+
+
+  @Override
   public final LispObject getSymbolSetfFunctionOrDie()
-
   {
     LispObject obj = get(this, Symbol.SETF_FUNCTION, null);
@@ -2922 +2929 @@
 
   // MOP.
+  public static final Symbol CLASS_LAYOUT =
+    PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT");
+  public static final Symbol CLASS_PRECEDENCE_LIST =
+    PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST");
   public static final Symbol STANDARD_READER_METHOD =
     PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
@@ -2966 +2977 @@
   public static final Symbol OUTPUT_OBJECT =
     PACKAGE_SYS.addExternalSymbol("OUTPUT-OBJECT");
-  public static final Symbol SET_CLASS_SLOTS =
-    PACKAGE_SYS.addExternalSymbol("SET-CLASS-SLOTS");
+  public static final Symbol _SET_CLASS_SLOTS =
+    PACKAGE_SYS.addExternalSymbol("%SET-CLASS-SLOTS");
   public static final Symbol SETF_FUNCTION =
     PACKAGE_SYS.addExternalSymbol("SETF-FUNCTION");

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -54 +54 @@
 (export '(class-precedence-list class-slots))
 
-(defun class-slots (class)
-  (%class-slots class))
+;; Don't use DEFVAR, because that disallows loading clos.lisp
+;; after compiling it: the binding won't get assigned to T anymore
+(defparameter *clos-booting* t)
+
+(defmacro define-class->%class-forwarder (name)
+  (let* (($name (if (consp name) (cadr name) name))
+         (%name (intern (concatenate 'string
+                                     "%"
+                                     (if (consp name)
+                                         (symbol-name 'set-) "")
+                                     (symbol-name $name))
+                        (symbol-package $name))))
+    `(progn
+       (declaim (notinline ,name))
+       (defun ,name (&rest args)
+         (apply #',%name args)))))
+
+(define-class->%class-forwarder class-name)
+(define-class->%class-forwarder (setf class-name))
+(define-class->%class-forwarder class-slots)
+(define-class->%class-forwarder (setf class-slots))
+(define-class->%class-forwarder class-direct-slots)
+(define-class->%class-forwarder (setf class-direct-slots))
+(define-class->%class-forwarder class-layout)
+(define-class->%class-forwarder (setf class-layout))
+(define-class->%class-forwarder class-direct-superclasses)
+(define-class->%class-forwarder (setf class-direct-superclasses))
+(define-class->%class-forwarder class-direct-subclasses)
+(define-class->%class-forwarder (setf class-direct-subclasses))
+(define-class->%class-forwarder class-direct-methods)
+(define-class->%class-forwarder (setf class-direct-methods))
+(define-class->%class-forwarder class-precedence-list)
+(define-class->%class-forwarder (setf class-precedence-list))
+(define-class->%class-forwarder class-finalized-p)
+(define-class->%class-forwarder (setf class-finalized-p))
+(define-class->%class-forwarder class-default-initargs)
+(define-class->%class-forwarder (setf class-default-initargs))
+(define-class->%class-forwarder class-direct-default-initargs)
+(define-class->%class-forwarder (setf class-direct-default-initargs))
+
+(defun no-applicable-method (generic-function &rest args)
+  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
+         generic-function
+         args))
+
+
 
 (defmacro push-on-end (value location)
@@ -86 +130 @@
             (mapplist fun (cddr x)))))
 
-(defsetf class-layout %set-class-layout)
-(defsetf class-direct-superclasses %set-class-direct-superclasses)
-(defsetf class-direct-subclasses %set-class-direct-subclasses)
-(defsetf class-direct-methods %set-class-direct-methods)
-(defsetf class-direct-slots %set-class-direct-slots)
-;; (defsetf class-slots %set-class-slots)
-(defsetf class-direct-default-initargs %set-class-direct-default-initargs)
-(defsetf class-default-initargs %set-class-default-initargs)
-(defsetf class-finalized-p %set-class-finalized-p)
 (defsetf std-instance-layout %set-std-instance-layout)
 (defsetf standard-instance-access %set-standard-instance-access)
@@ -254 +289 @@
 ;;; finalize-inheritance
 
+(defun std-compute-class-default-initargs (class)
+  (mapcan #'(lambda (c)
+              (copy-list
+               (class-direct-default-initargs c)))
+          (class-precedence-list class)))
+
 (defun std-finalize-inheritance (class)
-  (set-class-precedence-list
-   class
+  (setf (class-precedence-list class)
    (funcall (if (eq (class-of class) (find-class 'standard-class))
                 #'std-compute-class-precedence-list
                 #'compute-class-precedence-list)
             class))
-  (dolist (class (%class-precedence-list class))
+  (dolist (class (class-precedence-list class))
     (when (typep class 'forward-referenced-class)
       (return-from std-finalize-inheritance)))
-  (set-class-slots class
+  (setf (class-slots class)
                    (funcall (if (eq (class-of class) (find-class 'standard-class))
                                 #'std-compute-slots
-                                #'compute-slots)
-                            class))
+                     #'compute-slots) class))
   (let ((old-layout (class-layout class))
         (length 0)
         (instance-slots '())
         (shared-slots '()))
-    (dolist (slot (%class-slots class))
+    (dolist (slot (class-slots class))
       (case (%slot-definition-allocation slot)
         (:instance
@@ -293 +332 @@
                (old-location (layout-slot-location old-layout slot-name)))
           (unless old-location
-            (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name))
+            (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
                    (initfunction (%slot-definition-initfunction slot-definition)))
               (when initfunction
@@ -299 +338 @@
     (setf (class-layout class)
           (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
-  (setf (class-default-initargs class) (compute-class-default-initargs class))
+  (setf (class-default-initargs class)
+        (std-compute-class-default-initargs class))
   (setf (class-finalized-p class) t))
 
@@ -393 +433 @@
 (defun std-compute-slots (class)
   (let* ((all-slots (mapappend #'class-direct-slots
-                               (%class-precedence-list class)))
+                               (class-precedence-list class)))
          (all-names (remove-duplicates
                      (mapcar #'%slot-definition-name all-slots))))
@@ -432 +472 @@
 
 (defun find-slot-definition (class slot-name)
-  (dolist (slot (%class-slots class) nil)
+  (dolist (slot (class-slots class) nil)
     (when (eq slot-name (%slot-definition-name slot))
       (return slot))))
@@ -482 +522 @@
 
 (defun std-slot-exists-p (instance slot-name)
-  (not (null (find slot-name (%class-slots (class-of instance))
+  (not (null (find slot-name (class-slots (class-of instance))
                    :key #'%slot-definition-name))))
 
@@ -500 +540 @@
   (declare (ignore metaclass))
   (let ((class (std-allocate-instance (find-class 'standard-class))))
-    (%set-class-name class name)
-    (setf (class-direct-subclasses class) ())
-    (setf (class-direct-methods class) ())
+    (%set-class-name name class)
+    (%set-class-layout nil class)
+    (%set-class-direct-subclasses ()  class)
+    (%set-class-direct-methods ()  class)
     (%set-class-documentation class documentation)
     (std-after-initialization-for-classes class
@@ -538 +579 @@
   (getf canonical-slot :name))
 
-(defun ensure-class (name &rest all-keys &allow-other-keys)
+(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
   ;; Check for duplicate slots.
+  (remf all-keys :metaclass)
   (let ((slots (getf all-keys :direct-slots)))
     (dolist (s1 slots)
@@ -564 +606 @@
         (error "Attempt to define a subclass of a built-in-class: ~S" class))))
   (let ((old-class (find-class name nil)))
-    (cond ((and old-class (eq name (%class-name old-class)))
+    (cond ((and old-class (eq name (class-name old-class)))
            (cond ((typep old-class 'built-in-class)
                   (error "The symbol ~S names a built-in class." name))
@@ -583 +625 @@
                   old-class)))
           (t
-           (let ((class (apply #'make-instance-standard-class
-                               (find-class 'standard-class)
+           (let ((class (apply (if metaclass
+                                   #'make-instance
+                                   #'make-instance-standard-class)
+                               (or metaclass
+                                   (find-class 'standard-class))
                                :name name all-keys)))
              (%set-find-class name class)
@@ -832 +877 @@
           gf)
         (progn
-          (when (fboundp function-name)
+          (when (and (null *clos-booting*)
+                     (fboundp function-name))
             (error 'program-error
                    :format-control "~A already names an ordinary function, macro, or special operator."
@@ -1781 +1827 @@
                    )))
 
-(fmakunbound 'class-name)
-(fmakunbound '(setf class-name))
-
-(defgeneric class-name (class))
-
-(defmethod class-name ((class class))
-  (%class-name class))
-
-(defgeneric (setf class-name) (new-value class))
-
-(defmethod (setf class-name) (new-value (class class))
-  (%set-class-name class new-value))
-
-(when (autoloadp 'class-precedence-list)
-  (fmakunbound 'class-precedence-list))
-
-(defgeneric class-precedence-list (class))
-
-(defmethod class-precedence-list ((class class))
-  (%class-precedence-list class))
+(defmacro redefine-class-forwarder (name slot &optional alternative-name)
+  (let* (($name (if (consp name) (cadr name) name))
+         (%name (intern (concatenate 'string
+                                     "%"
+                                     (if (consp name)
+                                         (symbol-name 'set-) "")
+                                     (symbol-name $name))
+                        (find-package "SYS"))))
+    (unless alternative-name
+      (setf alternative-name name))
+    (if (consp name)
+        `(progn ;; setter
+           (defgeneric ,alternative-name (new-value class))
+           (defmethod ,alternative-name (new-value (class built-in-class))
+             (,%name new-value class))
+           (defmethod ,alternative-name (new-value (class forward-referenced-class))
+             (,%name new-value class))
+           (defmethod ,alternative-name (new-value (class structure-class))
+             (,%name new-value class))
+           (defmethod ,alternative-name (new-value (class standard-class))
+             (setf (slot-value class ',slot) new-value))
+           ,@(unless (eq name alternative-name)
+                     `((setf (get ',$name 'SETF-FUNCTION)
+                             (symbol-function ',alternative-name))))
+           )
+        `(progn ;; getter
+           (defgeneric ,alternative-name (class))
+           (defmethod ,alternative-name ((class built-in-class))
+             (,%name class))
+           (defmethod ,alternative-name ((class forward-referenced-class))
+             (,%name class))
+           (defmethod ,alternative-name ((class structure-class))
+             (,%name class))
+           (defmethod ,alternative-name ((class standard-class))
+             (slot-value class ',slot))
+           ,@(unless (eq name alternative-name)
+                     `((setf (symbol-function ',$name)
+                             (symbol-function ',alternative-name))))
+           ) )))
+
+(redefine-class-forwarder class-name name)
+(redefine-class-forwarder (setf class-name) name)
+(redefine-class-forwarder class-slots slots)
+(redefine-class-forwarder (setf class-slots) slots)
+(redefine-class-forwarder class-direct-slots direct-slots)
+(redefine-class-forwarder (setf class-direct-slots) direct-slots)
+(redefine-class-forwarder class-layout layout)
+(redefine-class-forwarder (setf class-layout) layout)
+(redefine-class-forwarder class-direct-superclasses direct-superclasses)
+(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
+(redefine-class-forwarder class-direct-subclasses direct-subclasses)
+(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
+(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
+(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
+(redefine-class-forwarder class-precedence-list precedence-list)
+(redefine-class-forwarder (setf class-precedence-list) precedence-list)
+(redefine-class-forwarder class-finalized-p finalized-p)
+(redefine-class-forwarder (setf class-finalized-p) finalized-p)
+(redefine-class-forwarder class-default-initargs default-initargs)
+(redefine-class-forwarder (setf class-default-initargs) default-initargs)
+(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
+(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
 
 
@@ -1951 +2039 @@
 
 (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
-  (dolist (dsd (%class-slots class))
+  (dolist (dsd (class-slots class))
     (when (eq (sys::dsd-name dsd) slot-name)
       (return-from slot-exists-p-using-class t)))
@@ -1987 +2075 @@
 (defmethod allocate-instance ((class structure-class) &rest initargs)
   (declare (ignore initargs))
-  (%make-structure (%class-name class)
-                   (make-list (length (%class-slots class))
+  (%make-structure (class-name class)
+                   (make-list (length (class-slots class))
                               :initial-element +slot-unbound+)))
 
@@ -2013 +2101 @@
      `(,instance ,@initargs)
          (list instance)))))
-    (slots (%class-slots (class-of instance))))
+    (slots (class-slots (class-of instance))))
       (do* ((tail initargs (cddr tail))
             (initarg (car tail) (car tail)))
@@ -2096 +2184 @@
        :format-control "Invalid initarg ~S."
        :format-arguments (list initarg))))
-  (dolist (slot (%class-slots (class-of instance)))
+  (dolist (slot (class-slots (class-of instance)))
     (let ((slot-name (%slot-definition-name slot)))
       (multiple-value-bind (init-key init-value foundp)
@@ -2121 +2209 @@
 (defmethod change-class ((old-instance standard-object) (new-class standard-class)
                          &rest initargs)
-  (let ((old-slots (%class-slots (class-of old-instance)))
-        (new-slots (%class-slots new-class))
+  (let ((old-slots (class-slots (class-of old-instance)))
+        (new-slots (class-slots new-class))
         (new-instance (allocate-instance new-class)))
     ;; "The values of local slots specified by both the class CTO and the class
@@ -2154 +2242 @@
                        (slot-exists-p old slot-name))
                     (mapcar #'%slot-definition-name
-                            (%class-slots (class-of new))))))
+                            (class-slots (class-of new))))))
     (check-initargs new added-slots initargs)
     (apply #'shared-initialize new added-slots initargs)))
@@ -2341 +2429 @@
 (defmethod make-load-form ((class class) &optional environment)
   (declare (ignore environment))
-  (let ((name (%class-name class)))
+  (let ((name (class-name class)))
     (unless (and name (eq (find-class name nil) class))
       (error 'simple-type-error
@@ -2356 +2444 @@
     (error "Method combination error in CLOS dispatch:~%    ~A" message)))
 
+(fmakunbound 'no-applicable-method)
 (defgeneric no-applicable-method (generic-function &rest args))
 
@@ -2394 +2483 @@
 (defgeneric function-keywords (method))
 
+(setf *clos-booting* nil)
+
 (defgeneric class-prototype (class))
 

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -3403 +3403 @@
                     (CHAR=              p2-test-char=)
                     (CHARACTERP         p2-test-characterp)
-                    (CLASSP             p2-test-classp)
                     (CONSP              p2-test-consp)
                     (CONSTANTP          p2-test-constantp)
@@ -3543 +3542 @@
 (defun p2-test-special-variable-p (form)
   (p2-test-predicate form "isSpecialVariable"))
-
-(defun p2-test-classp (form)
-  (p2-test-instanceof-predicate form +lisp-class-class+))
 
 (defun p2-test-symbolp (form)
@@ -4827 +4823 @@
 (defun p2-characterp (form target representation)
   (p2-instanceof-predicate form target representation +lisp-character-class+))
-
-(defun p2-classp (form target representation)
-  (p2-instanceof-predicate form target representation +lisp-class-class+))
 
 (defun p2-consp (form target representation)
@@ -8875 +8868 @@
   (install-p2-handler 'char=               'p2-char=)
   (install-p2-handler 'characterp          'p2-characterp)
-  (install-p2-handler 'classp              'p2-classp)
   (install-p2-handler 'coerce-to-function  'p2-coerce-to-function)
   (install-p2-handler 'cons                'p2-cons)