[armedbear-cvs] r12530 - branches/metaclass/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun Mar 14 09:18:06 2010
New Revision: 12530

Log:
Re #38: Make method creation and dispatch possible for classes with
non-standard-class metaclasses.


Modified:
   branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
   branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java
   branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
   branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp

Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java	Sun Mar 14 09:18:06 2010
@@ -5465,7 +5465,7 @@
             if (arg instanceof LispClass)
                 return ((LispClass)arg).getCPL();
             else
-                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symClassPrecedenceList);
+                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
         }
     };
 
@@ -5482,7 +5482,7 @@
             if (second instanceof LispClass)
                 ((LispClass)second).setCPL(first);
             else
-                ((StandardObject)second).setInstanceSlotValue(StandardClass.symClassPrecedenceList, first);
+                ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
             return first;
         }
     };

Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java	(original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java	Sun Mar 14 09:18:06 2010
@@ -69,7 +69,21 @@
     slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers;
     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;
       return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);     

Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java	(original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java	Sun Mar 14 09:18:06 2010
@@ -44,8 +44,8 @@
     = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
   public static Symbol symDirectSubclasses
     = PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
-  public static Symbol symClassPrecedenceList
-    = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
+  public static Symbol symPrecedenceList
+    = PACKAGE_MOP.intern("PRECEDENCE-LIST");
   public static Symbol symDirectMethods
     = PACKAGE_MOP.intern("DIRECT-METHODS");
   public static Symbol symDocumentation
@@ -67,7 +67,7 @@
                       symLayout,
                       symDirectSuperclasses,
                       symDirectSubclasses,
-                      symClassPrecedenceList,
+                      symPrecedenceList,
                       symDirectMethods,
                       symDocumentation,
                       symDirectSlots,
@@ -180,7 +180,7 @@
   @Override
   public LispObject getCPL()
   {
-    return getInstanceSlotValue(symClassPrecedenceList);
+    return getInstanceSlotValue(symPrecedenceList);
   }
 
   @Override
@@ -188,14 +188,14 @@
   {
     LispObject obj1 = cpl[0];
     if (obj1.listp() && cpl.length == 1)
-      setInstanceSlotValue(symClassPrecedenceList, obj1);
+      setInstanceSlotValue(symPrecedenceList, obj1);
     else
       {
         Debug.assertTrue(obj1 == this);
         LispObject l = NIL;
         for (int i = cpl.length; i-- > 0;)
             l = new Cons(cpl[i], l);
-        setInstanceSlotValue(symClassPrecedenceList, l);
+        setInstanceSlotValue(symPrecedenceList, l);
       }
   }
 
@@ -316,6 +316,42 @@
     return unreadableString(sb.toString());
   }
 
+  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)
   {
@@ -340,21 +376,7 @@
     addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);
 
     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() {
- at Override
-    public LispObject execute() {
-    return NIL;
-}
-                                                                  });
-      slots = slots.cdr();
-    }
-    
+    STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
   }
 
   // BuiltInClass.FUNCTION is also null here (see previous comment).

Modified: branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp	Sun Mar 14 09:18:06 2010
@@ -1880,8 +1880,8 @@
 (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-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)