Changeset 12527

Timestamp:

03/13/10 19:05:15 (11 years ago)

Author:

ehuelsmann

Message:

Make all class accessor functions generic functions instead

of normal ones, to support METACLASS. Additionally, make
it possible to store general objects in Layout.lispClass.

Because classes may be of a different Java type than

StandardClass?, fall back to the generic functions to access
the required fields from Java.

See #38.

Location:

branches/metaclass/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• Condition.java (modified) (2 diffs)
• Layout.java (modified) (7 diffs)
• LispClass.java (modified) (2 diffs)
• LispObject.java (modified) (1 diff)
• Primitives.java (modified) (8 diffs)
• SlotClass.java (modified) (8 diffs)
• SlotDefinition.java (modified) (19 diffs)
• StandardClass.java (modified) (10 diffs)
• StandardGenericFunction.java (modified) (1 diff)
• StandardMethod.java (modified) (1 diff)
• StandardObject.java (modified) (5 diffs)
• Symbol.java (modified) (3 diffs)
• clos.lisp (modified) (23 diffs)

branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java

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

branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java

@@ -138 +138 @@
   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;
   }
@@ -147 +149 @@
   public LispObject classOf()
   {
-    LispClass c = getLispClass();
+    LispObject c = getLispClass();
     if (c != null)
       return c;

branches/metaclass/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;
       }

branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java

@@ -180 +180 @@
   }
 
-  public void setClassLayout(Layout layout)
-  {
-    classLayout = layout;
+  public void setClassLayout(LispObject layout)
+  {
+    classLayout = layout == NIL ? null : (Layout)layout;
   }
 
@@ -202 +202 @@
   }
 
-  public final boolean isFinalized()
+  public boolean isFinalized()
   {
     return finalized;
   }
 
-  public final void setFinalized(boolean b)
+  public void setFinalized(boolean b)
   {
     finalized = b;

branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java

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

branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java

@@ -5332 +5332 @@
 
         {
-            checkClass(first).setName(checkSymbol(second));
-            return second;
+            checkClass(second).setName(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");
+    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");
         }
 
@@ -5362 +5362 @@
 
         {
-            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);
+            if (first == NIL || first instanceof Layout) {
+                checkClass(second).setClassLayout(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);
         }
 
@@ -5394 +5394 @@
 
         {
-            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);
+            checkClass(second).setDirectSuperclasses(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);
         }
 
@@ -5424 +5424 @@
 
         {
-            checkClass(first).setDirectSubclasses(second);
-            return second;
+            checkClass(second).setDirectSubclasses(first);
+            return first;
         }
     };
@@ -5442 +5442 @@
     };
 
-    // ### 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);
+    // ### %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(second).setCPL(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);
         }
 
@@ -5484 +5484 @@
 
         {
-            checkClass(first).setDirectMethods(second);
-            return second;
+            checkClass(second).setDirectMethods(first);
+            return first;
         }
     };
@@ -5522 +5522 @@
     };
 
-    // ### 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);
+    // ### %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);
         }
 
@@ -5546 +5546 @@
 
         {
-            checkClass(first).setFinalized(second != NIL);
-            return second;
+            checkClass(second).setFinalized(first != NIL);
+            return first;
         }
     };

branches/metaclass/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);
+            if (second instanceof SlotClass) {
+                ((SlotClass)second).setDefaultInitargs(first);
+                return first;
+            }
+            return type_error(second, Symbol.STANDARD_CLASS);
         }
     };

branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java

@@ -71 +71 @@
   }
   
-  public static SlotDefinition checkSlotDefination(LispObject obj) {
+  public static SlotDefinition checkSlotDefinition(LispObject obj) {
           if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
       return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);     
@@ -118 +118 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
       }
     };
@@ -131 +131 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
           return second;
       }
@@ -143 +143 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
       }
     };
 
   // ### 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")
@@ -156 +156 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
           return second;
       }
@@ -169 +169 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
       }
     };
 
   // ### 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")
@@ -182 +182 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
           return second;
       }
@@ -194 +194 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
       }
     };
@@ -207 +207 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
           return second;
       }
@@ -220 +220 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
       }
     };
@@ -233 +233 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
           return second;
       }
@@ -246 +246 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
       }
     };
@@ -259 +259 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
           return second;
       }
@@ -272 +272 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
       }
     };
@@ -285 +285 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
           return second;
       }
@@ -298 +298 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
       }
     };
@@ -311 +311 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
           return second;
       }
@@ -323 +323 @@
       public LispObject execute(LispObject arg)
       {
-          return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
+          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
       }
     };
@@ -335 +335 @@
 
       {
-          checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
+          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
           return second;
       }

branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java

@@ -59 +59 @@
   private static Symbol symDefaultInitargs
     = PACKAGE_MOP.intern("DEFAULT-INITARGS");
+  private static Symbol symFinalizedP
+    = PACKAGE_MOP.intern("FINALIZED-P");
 
   static Layout layoutStandardClass =
@@ -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);
@@ -145 +152 @@
   {
     setInstanceSlotValue(symDirectSuperclasses, directSuperclasses);
+  }
+
+  @Override
+  public final boolean isFinalized()
+  {
+    return getInstanceSlotValue(symFinalizedP) != NIL;
+  }
+
+  @Override
+  public final void setFinalized(boolean b)
+  {
+    setInstanceSlotValue(symFinalizedP, b ? T : NIL);
   }
 
@@ -323 +342 @@
     STANDARD_CLASS.setClassLayout(layoutStandardClass);
     STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
+    LispObject slots = STANDARD_CLASS.getDirectSlotDefinitions();
+    while (slots != NIL) {
+      SlotDefinition slot = (SlotDefinition)slots.car();
+      if (slot.getName() == symLayout)
+          SlotDefinition.SET_SLOT_DEFINITION_INITFUNCTION.execute(slot,
+                                                                  new Function() {
+@Override
+    public LispObject execute() {
+    return NIL;
+}
+                                                                  });
+      slots = slots.cdr();
+    }
+    
   }
 
@@ -617 +650 @@
 
     // Condition classes.
+    STANDARD_CLASS.finalizeClass();
     ARITHMETIC_ERROR.finalizeClass();
     CELL_ERROR.finalizeClass();

branches/metaclass/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());

branches/metaclass/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());

branches/metaclass/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)
       {
@@ -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;

branches/metaclass/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);
@@ -2914 +2921 @@
 
   // 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");

branches/metaclass/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)
@@ -255 +290 @@
 
 (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
-                   (funcall (if (eq (class-of class) (find-class 'standard-class))
-                                #'std-compute-slots
-                                #'compute-slots)
-                            class))
+  (setf (class-slots class)
+        (funcall (if (eq (class-of class) (find-class 'standard-class))
+                     #'std-compute-slots
+                     #'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 +326 @@
                (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
@@ -393 +426 @@
 (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 +465 @@
 
 (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 +515 @@
 
 (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 +533 @@
   (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 +572 @@
   (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 +599 @@
         (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 +618 @@
                   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 +870 @@
           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 +1820 @@
                    )))
 
-(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 class-precedence-list)
+(redefine-class-forwarder (setf class-precedence-list) class-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 +2032 @@
 
 (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)))
@@ -1970 +2051 @@
 (defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
   (declare (ignore new-value))
+  (mapcar #'print (mapcar #'frame-to-string (sys::backtrace)))
   (error "The slot ~S is missing from the class ~S." slot-name class))
 
@@ -1987 +2069 @@
 (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 +2095 @@
      `(,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 +2178 @@
        :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 +2203 @@
 (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 +2236 @@
                        (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 +2423 @@
 (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 +2438 @@
     (error "Method combination error in CLOS dispatch:~%    ~A" message)))
 
+(fmakunbound 'no-applicable-method)
 (defgeneric no-applicable-method (generic-function &rest args))
 
@@ -2394 +2477 @@
 (defgeneric function-keywords (method))
 
+(setf *clos-booting* nil)
 
 (provide 'clos)