[armedbear-cvs] r12576 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Mar 28 20:13:16 UTC 2010
Author: ehuelsmann
Date: Sun Mar 28 16:13:14 2010
New Revision: 12576
Log:
Re #38: Merge the METACLASS branch to trunk.
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Condition.java
trunk/abcl/src/org/armedbear/lisp/Layout.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/LispClass.java
trunk/abcl/src/org/armedbear/lisp/LispObject.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/SlotClass.java
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
trunk/abcl/src/org/armedbear/lisp/StandardMethod.java
trunk/abcl/src/org/armedbear/lisp/StandardObject.java
trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Mar 28 16:13:14 2010
@@ -685,7 +685,7 @@
autoload(Symbol.SET_CHAR, "StringFunctions");
autoload(Symbol.SET_SCHAR, "StringFunctions");
- autoload(Symbol.SET_CLASS_SLOTS, "SlotClass");
+ autoload(Symbol._SET_CLASS_SLOTS, "SlotClass");
autoload(Symbol._CLASS_SLOTS, "SlotClass");
autoload(Symbol.JAVA_EXCEPTION_CAUSE, "JavaException");
Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Condition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Condition.java Sun Mar 28 16:13:14 2010
@@ -141,16 +141,18 @@
@Override
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;
}
@Override
public LispObject classOf()
{
- LispClass c = getLispClass();
+ LispObject c = getLispClass();
if (c != null)
return c;
return StandardClass.CONDITION;
Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Layout.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Layout.java Sun Mar 28 16:13:14 2010
@@ -37,7 +37,7 @@
public class Layout extends LispObject
{
- private final LispClass lispClass;
+ private final LispObject lispClass;
public final EqHashTable slotTable;
final LispObject[] slotNames;
@@ -45,7 +45,7 @@
private boolean invalid;
- public Layout(LispClass lispClass, LispObject instanceSlots, LispObject sharedSlots)
+ public Layout(LispObject lispClass, LispObject instanceSlots, LispObject sharedSlots)
{
this.lispClass = lispClass;
Debug.assertTrue(instanceSlots.listp());
@@ -64,7 +64,7 @@
slotTable = initializeSlotTable(slotNames);
}
- public Layout(LispClass lispClass, LispObject[] instanceSlotNames,
+ public Layout(LispObject lispClass, LispObject[] instanceSlotNames,
LispObject sharedSlots)
{
this.lispClass = lispClass;
@@ -103,7 +103,7 @@
return result.nreverse();
}
- public LispClass getLispClass()
+ public LispObject getLispClass()
{
return lispClass;
}
@@ -159,8 +159,7 @@
LispObject third)
{
- return new Layout(checkClass(first), checkList(second),
- checkList(third));
+ return new Layout(first, checkList(second), checkList(third));
}
};
@@ -235,7 +234,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- final Layout layOutFirst = checkLayout(first);
+ final Layout layOutFirst = checkLayout(first);
final LispObject slotNames[] = layOutFirst.slotNames;
final int limit = slotNames.length;
for (int i = 0; i < limit; i++)
@@ -263,11 +262,20 @@
@Override
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;
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Mar 28 16:13:14 2010
@@ -1653,15 +1653,6 @@
type_error(obj, Symbol.STRING);
}
- 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)
{
Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Sun Mar 28 16:13:14 2010
@@ -48,6 +48,15 @@
return c;
}
+ public static LispObject addClass(Symbol symbol, LispObject c)
+ {
+ synchronized (map)
+ {
+ map.put(symbol, c);
+ }
+ return c;
+ }
+
public static void removeClass(Symbol symbol)
{
synchronized (map)
@@ -68,10 +77,10 @@
{
final Symbol symbol = checkSymbol(name);
- final LispClass c;
+ final LispObject c;
synchronized (map)
{
- c = (LispClass) map.get(symbol);
+ c = map.get(symbol);
}
if (c != null)
return c;
@@ -179,9 +188,9 @@
return classLayout;
}
- public void setClassLayout(Layout layout)
+ public void setClassLayout(LispObject layout)
{
- classLayout = layout;
+ classLayout = layout == NIL ? null : (Layout)layout;
}
public final int getLayoutLength()
@@ -201,12 +210,12 @@
this.directSuperclasses = directSuperclasses;
}
- public final boolean isFinalized()
+ public boolean isFinalized()
{
return finalized;
}
- public final void setFinalized(boolean b)
+ public void setFinalized(boolean b)
{
finalized = b;
}
@@ -291,13 +300,29 @@
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)
{
if (cpl.car() == obj)
return true;
cpl = ((Cons)cpl).cdr;
}
+
+ if (cls instanceof LispClass)
+ // additional checks (currently because of JavaClass)
+ return ((LispClass)cls).subclassp(obj);
+
return false;
}
@@ -340,8 +365,7 @@
removeClass(name);
return second;
}
- final LispClass c = checkClass(second);
- addClass(name, c);
+ addClass(name, second);
return second;
}
};
@@ -354,8 +378,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- final LispClass c = checkClass(first);
- return c.subclassp(second) ? T : NIL;
+ return LispClass.subclassp(first, second) ? T : NIL;
}
};
}
Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Mar 28 16:13:14 2010
@@ -677,6 +677,16 @@
return type_error(this, Symbol.SYMBOL);
}
+ public LispObject getSymbolSetfFunction()
+ {
+ return type_error(this, Symbol.SYMBOL);
+ }
+
+ public LispObject getSymbolSetfFunctionOrDie()
+ {
+ return type_error(this, Symbol.SYMBOL);
+ }
+
public String writeToString()
{
return toString();
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Mar 28 16:13:14 2010
@@ -5316,7 +5316,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getName();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getName();
+
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
}
};
@@ -5331,21 +5334,30 @@
public LispObject execute(LispObject first, LispObject second)
{
- 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");
+ 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();
+ Layout layout;
+ if (arg instanceof LispClass)
+ layout = ((LispClass)arg).getClassLayout();
+ else
+ layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
+
return layout != null ? layout : NIL;
}
};
@@ -5361,24 +5373,30 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (second instanceof Layout) {
- checkClass(first).setClassLayout((Layout)second);
- return second;
+ 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(second, Symbol.LAYOUT);
+ 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);
+ // ### %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 (arg instanceof LispClass)
+ return ((LispClass)arg).getDirectSuperclasses();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
}
};
@@ -5391,23 +5409,28 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(first).setDirectSuperclasses(second);
- return second;
+ 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);
+ // ### %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 (arg instanceof LispClass)
+ return ((LispClass)arg).getDirectSubclasses();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
}
};
@@ -5421,10 +5444,12 @@
@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;
}
};
@@ -5437,38 +5462,45 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getCPL();
+ 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);
+ // ### %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;
+ 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);
+ // ### %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);
}
};
@@ -5481,10 +5513,12 @@
@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;
}
};
@@ -5500,7 +5534,10 @@
public LispObject execute(LispObject arg)
{
- return checkClass(arg).getDocumentation();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getDocumentation();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
}
};
@@ -5514,23 +5551,28 @@
@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);
+ // ### %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;
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).isFinalized() ? T : NIL;
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
}
};
@@ -5543,10 +5585,12 @@
@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;
}
};
@@ -5559,7 +5603,7 @@
@Override
public LispObject execute(LispObject arg) {
- return arg instanceof LispClass ? T : NIL;
+ return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sun Mar 28 16:13:14 2010
@@ -178,7 +178,7 @@
// ### 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
public LispObject execute(LispObject arg)
@@ -200,12 +200,12 @@
public LispObject execute(LispObject first, LispObject second)
{
- 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);
}
}
};
@@ -227,26 +227,26 @@
};
// ### 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
public LispObject execute(LispObject first, LispObject second)
{
- 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);
}
}
};
// ### 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
public LispObject execute(LispObject arg)
@@ -268,17 +268,17 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (first instanceof SlotClass) {
- ((SlotClass)first).setDirectDefaultInitargs(second);
- return second;
+ if (second instanceof SlotClass) {
+ ((SlotClass)second).setDirectDefaultInitargs(first);
+ return first;
}
- return type_error(first, Symbol.STANDARD_CLASS);
+ return type_error(second, Symbol.STANDARD_CLASS);
}
};
// ### 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
public LispObject execute(LispObject arg)
@@ -300,30 +300,12 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (first instanceof SlotClass) {
- ((SlotClass)first).setDefaultInitargs(second);
- return second;
+ if (second instanceof SlotClass) {
+ ((SlotClass)second).setDefaultInitargs(first);
+ return first;
}
- return type_error(first, Symbol.STANDARD_CLASS);
+ return type_error(second, 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();
- }
- };
}
Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sun Mar 28 16:13:14 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);
@@ -147,7 +161,7 @@
};
// ### 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")
{
@@ -173,7 +187,7 @@
};
// ### 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")
{
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Mar 28 16:13:14 2010
@@ -38,26 +38,28 @@
public class StandardClass extends SlotClass
{
- 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 =
new Layout(null,
@@ -65,13 +67,14 @@
symLayout,
symDirectSuperclasses,
symDirectSubclasses,
- symClassPrecedenceList,
+ symPrecedenceList,
symDirectMethods,
symDocumentation,
symDirectSlots,
symSlots,
symDirectDefaultInitargs,
- symDefaultInitargs),
+ symDefaultInitargs,
+ symFinalizedP),
NIL)
{
@Override
@@ -86,6 +89,7 @@
super(layoutStandardClass);
setDirectSuperclasses(NIL);
setDirectSubclasses(NIL);
+ setClassLayout(layoutStandardClass);
setCPL(NIL);
setDirectMethods(NIL);
setDocumentation(NIL);
@@ -93,6 +97,7 @@
setSlotDefinitions(NIL);
setDirectDefaultInitargs(NIL);
setDefaultInitargs(NIL);
+ setFinalized(false);
}
public StandardClass(Symbol symbol, LispObject directSuperclasses)
@@ -100,6 +105,7 @@
super(layoutStandardClass,
symbol, directSuperclasses);
setDirectSubclasses(NIL);
+ setClassLayout(layoutStandardClass);
setCPL(NIL);
setDirectMethods(NIL);
setDocumentation(NIL);
@@ -107,6 +113,7 @@
setSlotDefinitions(NIL);
setDirectDefaultInitargs(NIL);
setDefaultInitargs(NIL);
+ setFinalized(false);
}
@Override
@@ -129,7 +136,7 @@
}
@Override
- public void setClassLayout(Layout newLayout)
+ public void setClassLayout(LispObject newLayout)
{
setInstanceSlotValue(symLayout, newLayout);
}
@@ -147,6 +154,18 @@
}
@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()
{
return getInstanceSlotValue(symDirectSubclasses);
@@ -161,7 +180,7 @@
@Override
public LispObject getCPL()
{
- return getInstanceSlotValue(symClassPrecedenceList);
+ return getInstanceSlotValue(symPrecedenceList);
}
@Override
@@ -169,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);
}
}
@@ -252,7 +271,11 @@
setInstanceSlotValue(symDefaultInitargs, defaultInitargs);
}
-
+ @Override
+ public LispObject typeOf()
+ {
+ return Symbol.STANDARD_CLASS;
+ }
@Override
public LispObject classOf()
@@ -297,6 +320,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)
{
@@ -321,7 +380,7 @@
addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);
STANDARD_CLASS.setClassLayout(layoutStandardClass);
- STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
+ STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
}
// BuiltInClass.FUNCTION is also null here (see previous comment).
@@ -616,6 +675,7 @@
WARNING.setCPL(WARNING, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T);
// Condition classes.
+ STANDARD_CLASS.finalizeClass();
ARITHMETIC_ERROR.finalizeClass();
CELL_ERROR.finalizeClass();
COMPILER_ERROR.finalizeClass();
Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Mar 28 16:13:14 2010
@@ -209,7 +209,14 @@
if (name != null)
{
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());
return unreadableString(sb.toString());
Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Mar 28 16:13:14 2010
@@ -156,7 +156,14 @@
if (name != null)
{
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());
LispObject specializers =
Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Mar 28 16:13:14 2010
@@ -46,6 +46,11 @@
}
+ protected StandardObject(Layout layout)
+ {
+ this(layout, layout.getLength());
+ }
+
protected StandardObject(Layout layout, int length)
{
this.layout = layout;
@@ -98,11 +103,29 @@
return parts.nreverse();
}
- 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);
+ }
+
@Override
public LispObject typeOf()
{
@@ -110,14 +133,19 @@
// conditions, TYPE-OF returns the proper name of the class returned by
// 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;
}
@@ -137,20 +165,30 @@
return T;
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();
}
}
@@ -183,10 +221,16 @@
{
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;
LispObject discarded = NIL;
Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sun Mar 28 16:13:14 2010
@@ -47,7 +47,11 @@
if (arg == StandardClass.STANDARD_CLASS)
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);
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Mar 28 16:13:14 2010
@@ -390,8 +390,15 @@
return function;
}
- public final LispObject getSymbolSetfFunctionOrDie()
+ @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);
if (obj == null)
@@ -2921,6 +2928,10 @@
PACKAGE_EXT.addExternalSymbol("SLIME-OUTPUT-STREAM");
// 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");
@@ -2965,8 +2976,8 @@
PACKAGE_SYS.addExternalSymbol("NAMED-LAMBDA");
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");
public static final Symbol SETF_INVERSE =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 28 16:13:14 2010
@@ -53,8 +53,52 @@
(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)
`(setf ,location (nconc ,location (list ,value))))
@@ -85,15 +129,6 @@
(cons (funcall fun (car x) (cadr x))
(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)
@@ -253,26 +288,30 @@
;;; 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
(set-slot-definition-location slot length)
@@ -292,13 +331,14 @@
(let* ((slot-name (car location))
(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
(setf (cdr location) (funcall initfunction))))))))
(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))
;;; Class precedence lists
@@ -392,7 +432,7 @@
(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))))
(mapcar #'(lambda (name)
@@ -431,7 +471,7 @@
;;; references.
(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))))
@@ -481,7 +521,7 @@
(slot-makunbound-using-class (class-of object) object slot-name)))
(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))))
(defun slot-exists-p (object slot-name)
@@ -499,9 +539,10 @@
&allow-other-keys)
(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
:direct-superclasses direct-superclasses
@@ -537,8 +578,9 @@
(defun canonical-slot-name (canonical-slot)
(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)
(let ((name1 (canonical-slot-name s1)))
@@ -563,7 +605,7 @@
(when (typep class 'built-in-class)
(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))
((typep old-class 'forward-referenced-class)
@@ -582,8 +624,11 @@
(apply #'std-after-initialization-for-classes old-class all-keys)
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)
class)))))
@@ -831,7 +876,8 @@
(finalize-generic-function gf))
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."
:format-arguments (list function-name)))
@@ -1780,26 +1826,68 @@
(autocompile fast-function))
)))
-(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)
@@ -1950,7 +2038,7 @@
(std-slot-exists-p instance slot-name))
(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)))
nil)
@@ -1986,8 +2074,8 @@
(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+)))
;; "The set of valid initialization arguments for a class is the set of valid
@@ -2012,7 +2100,7 @@
(if initargs
`(,instance , at 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)))
((null tail))
@@ -2095,7 +2183,7 @@
(error 'program-error
: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)
(get-properties all-keys (%slot-definition-initargs slot))
@@ -2120,8 +2208,8 @@
(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
;; CFROM are retained. If such a local slot was unbound, it remains
@@ -2153,7 +2241,7 @@
(remove-if #'(lambda (slot-name)
(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)))
@@ -2340,7 +2428,7 @@
(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
:format-control "Can't use anonymous or undefined class as a constant: ~S."
@@ -2355,6 +2443,7 @@
(let ((message (apply #'format nil format-control args)))
(error "Method combination error in CLOS dispatch:~% ~A" message)))
+(fmakunbound 'no-applicable-method)
(defgeneric no-applicable-method (generic-function &rest args))
(defmethod no-applicable-method (generic-function &rest args)
@@ -2393,6 +2482,8 @@
;; FIXME
(defgeneric function-keywords (method))
+(setf *clos-booting* nil)
+
(defgeneric class-prototype (class))
(defmethod class-prototype :before (class)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 28 16:13:14 2010
@@ -3402,7 +3402,6 @@
(BIT-VECTOR-P p2-test-bit-vector-p)
(CHAR= p2-test-char=)
(CHARACTERP p2-test-characterp)
- (CLASSP p2-test-classp)
(CONSP p2-test-consp)
(CONSTANTP p2-test-constantp)
(ENDP p2-test-endp)
@@ -3543,9 +3542,6 @@
(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)
(p2-test-instanceof-predicate form +lisp-symbol-class+))
@@ -4827,9 +4823,6 @@
(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)
(p2-instanceof-predicate form target representation +lisp-cons-class+))
@@ -8874,7 +8867,6 @@
(install-p2-handler 'java:jmethod 'p2-java-jmethod)
(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)
(install-p2-handler 'sys::backq-cons 'p2-cons)
More information about the armedbear-cvs
mailing list