[armedbear-cvs] r12481 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Feb 14 21:30:01 UTC 2010
Author: ehuelsmann
Date: Sun Feb 14 16:29:58 2010
New Revision: 12481
Log:
Merge 'metaclass' branch, making STANDARD-CLASS have slots to
be inherited by deriving metaclasses.
Note: this does definitely *not* complete the metaclass work.
Modified:
trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
trunk/abcl/src/org/armedbear/lisp/Condition.java
trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java
trunk/abcl/src/org/armedbear/lisp/Layout.java
trunk/abcl/src/org/armedbear/lisp/LispClass.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/SlotClass.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/StructureClass.java
trunk/abcl/src/org/armedbear/lisp/StructureObject.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/make_condition.java
Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sun Feb 14 16:29:58 2010
@@ -74,7 +74,7 @@
public String writeToString()
{
StringBuilder sb = new StringBuilder("#<BUILT-IN-CLASS ");
- sb.append(symbol.writeToString());
+ sb.append(getName().writeToString());
sb.append('>');
return sb.toString();
}
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 Feb 14 16:29:58 2010
@@ -139,7 +139,7 @@
{
LispClass c = getLispClass();
if (c != null)
- return c.getSymbol();
+ return c.getName();
return Symbol.CONDITION;
}
Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Sun Feb 14 16:29:58 2010
@@ -69,9 +69,9 @@
{
StringBuffer sb =
new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.writeToString());
- if (symbol != null) {
+ if (getName() != null) {
sb.append(' ');
- sb.append(symbol.writeToString());
+ sb.append(getName().writeToString());
}
return unreadableString(sb.toString());
}
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 Feb 14 16:29:58 2010
@@ -35,9 +35,9 @@
import static org.armedbear.lisp.Lisp.*;
-public final class Layout extends LispObject
+public class Layout extends LispObject
{
- public final LispClass lispClass;
+ private final LispClass lispClass;
public final EqHashTable slotTable;
private final LispObject[] slotNames;
@@ -76,7 +76,7 @@
// Copy constructor.
private Layout(Layout oldLayout)
{
- lispClass = oldLayout.lispClass;
+ lispClass = oldLayout.getLispClass();
slotNames = oldLayout.slotNames;
sharedSlots = oldLayout.sharedSlots;
slotTable = initializeSlotTable(slotNames);
@@ -94,7 +94,7 @@
public LispObject getParts()
{
LispObject result = NIL;
- result = result.push(new Cons("class", lispClass));
+ result = result.push(new Cons("class", getLispClass()));
for (int i = 0; i < slotNames.length; i++)
{
result = result.push(new Cons("slot " + i, slotNames[i]));
@@ -103,6 +103,11 @@
return result.nreverse();
}
+ public LispClass getLispClass()
+ {
+ return lispClass;
+ }
+
public boolean isInvalid()
{
return invalid;
@@ -167,7 +172,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkLayout(arg).lispClass;
+ return checkLayout(arg).getLispClass();
}
};
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 Feb 14 16:29:58 2010
@@ -88,46 +88,57 @@
private final int sxhash;
- protected Symbol symbol;
+ private LispObject name;
private LispObject propertyList;
private Layout classLayout;
private LispObject directSuperclasses = NIL;
private LispObject directSubclasses = NIL;
- public LispObject classPrecedenceList = NIL; // FIXME! Should be private!
- public LispObject directMethods = NIL; // FIXME! Should be private!
- public LispObject documentation = NIL; // FIXME! Should be private!
+ private LispObject classPrecedenceList = NIL;
+ private LispObject directMethods = NIL;
+ private LispObject documentation = NIL;
private boolean finalized;
- protected LispClass()
+ protected LispClass(Layout layout)
{
+ super(layout, layout == null ? 0 : layout.getLength());
sxhash = hashCode() & 0x7fffffff;
}
protected LispClass(Symbol symbol)
{
+ this(null, symbol);
+ }
+
+ protected LispClass(Layout layout, Symbol symbol)
+ {
+ super(layout, layout == null ? 0 : layout.getLength());
+ setName(symbol);
sxhash = hashCode() & 0x7fffffff;
- this.symbol = symbol;
- this.directSuperclasses = NIL;
}
- protected LispClass(Symbol symbol, LispObject directSuperclasses)
+ protected LispClass(Layout layout,
+ Symbol symbol, LispObject directSuperclasses)
{
+ super(layout, layout == null ? 0 : layout.getLength());
sxhash = hashCode() & 0x7fffffff;
- this.symbol = symbol;
- this.directSuperclasses = directSuperclasses;
+ setName(symbol);
+ setDirectSuperclasses(directSuperclasses);
}
@Override
public LispObject getParts()
{
LispObject result = NIL;
- result = result.push(new Cons("NAME", symbol != null ? symbol : NIL));
- result = result.push(new Cons("LAYOUT", classLayout != null ? classLayout : NIL));
- result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses));
- result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses));
- result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList));
- result = result.push(new Cons("DIRECT-METHODS", directMethods));
- result = result.push(new Cons("DOCUMENTATION", documentation));
+ result = result.push(new Cons("NAME", name != null ? name : NIL));
+ result = result.push(new Cons("LAYOUT",
+ getClassLayout() != null
+ ? getClassLayout() : NIL));
+ result = result.push(new Cons("DIRECT-SUPERCLASSES",
+ getDirectSuperclasses()));
+ result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses()));
+ result = result.push(new Cons("CLASS-PRECEDENCE-LIST", getCPL()));
+ result = result.push(new Cons("DIRECT-METHODS", getDirectMethods()));
+ result = result.push(new Cons("DOCUMENTATION", getDocumentation()));
return result.nreverse();
}
@@ -137,9 +148,14 @@
return sxhash;
}
- public final Symbol getSymbol()
+ public LispObject getName()
{
- return symbol;
+ return name;
+ }
+
+ public void setName(LispObject name)
+ {
+ this.name = name;
}
@Override
@@ -158,12 +174,12 @@
propertyList = obj;
}
- public final Layout getClassLayout()
+ public Layout getClassLayout()
{
return classLayout;
}
- public final void setClassLayout(Layout layout)
+ public void setClassLayout(Layout layout)
{
classLayout = layout;
}
@@ -175,12 +191,12 @@
return layout.getLength();
}
- public final LispObject getDirectSuperclasses()
+ public LispObject getDirectSuperclasses()
{
return directSuperclasses;
}
- public final void setDirectSuperclasses(LispObject directSuperclasses)
+ public void setDirectSuperclasses(LispObject directSuperclasses)
{
this.directSuperclasses = directSuperclasses;
}
@@ -198,97 +214,57 @@
// When there's only one direct superclass...
public final void setDirectSuperclass(LispObject superclass)
{
- directSuperclasses = new Cons(superclass);
+ setDirectSuperclasses(new Cons(superclass));
}
- public final LispObject getDirectSubclasses()
+ public LispObject getDirectSubclasses()
{
return directSubclasses;
}
- public final void setDirectSubclasses(LispObject directSubclasses)
+ public void setDirectSubclasses(LispObject directSubclasses)
{
this.directSubclasses = directSubclasses;
}
- public final LispObject getCPL()
+ public LispObject getCPL()
{
return classPrecedenceList;
}
- public final void setCPL(LispObject obj1)
+ public void setCPL(LispObject... cpl)
{
- if (obj1 instanceof Cons)
+ LispObject obj1 = cpl[0];
+ if (obj1 instanceof Cons && cpl.length == 1)
classPrecedenceList = obj1;
else
{
Debug.assertTrue(obj1 == this);
- classPrecedenceList = new Cons(obj1);
+ LispObject l = NIL;
+ for (int i = cpl.length; i-- > 0;)
+ l = new Cons(cpl[i], l);
+ classPrecedenceList = l;
}
}
- public final void setCPL(LispObject obj1, LispObject obj2)
- {
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2);
- }
-
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3)
- {
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2, obj3);
- }
-
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4)
- {
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2, obj3, obj4);
- }
-
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4, LispObject obj5)
- {
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5);
- }
-
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4, LispObject obj5, LispObject obj6)
- {
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6);
- }
-
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4, LispObject obj5, LispObject obj6,
- LispObject obj7)
+ public LispObject getDirectMethods()
{
- Debug.assertTrue(obj1 == this);
- classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6, obj7);
+ return directMethods;
}
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4, LispObject obj5, LispObject obj6,
- LispObject obj7, LispObject obj8)
+ public void setDirectMethods(LispObject methods)
{
- Debug.assertTrue(obj1 == this);
- classPrecedenceList =
- list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8);
+ directMethods = methods;
}
- public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
- LispObject obj4, LispObject obj5, LispObject obj6,
- LispObject obj7, LispObject obj8, LispObject obj9)
+ public LispObject getDocumentation()
{
- Debug.assertTrue(obj1 == this);
- classPrecedenceList =
- list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9);
+ return documentation;
}
- public String getName()
+ public void setDocumentation(LispObject doc)
{
- return symbol.getName();
+ documentation = doc;
}
@Override
@@ -315,7 +291,7 @@
public boolean subclassp(LispObject obj)
{
- LispObject cpl = classPrecedenceList;
+ LispObject cpl = getCPL();
while (cpl != NIL)
{
if (cpl.car() == obj)
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 Feb 14 16:29:58 2010
@@ -5316,7 +5316,7 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).symbol;
+ return checkClass(arg).getName();
}
};
@@ -5331,7 +5331,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).symbol = checkSymbol(second);
+ checkClass(first).setName(checkSymbol(second));
return second;
}
};
@@ -5452,7 +5452,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).classPrecedenceList = second;
+ checkClass(first).setCPL(second);
return second;
}
};
@@ -5468,7 +5468,7 @@
public LispObject execute(LispObject arg)
{
- return checkClass(arg).directMethods;
+ return checkClass(arg).getDirectMethods();
}
};
@@ -5483,13 +5483,14 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).directMethods = second;
+ checkClass(first).setDirectMethods(second);
return second;
}
};
// ### class-documentation
- private static final Primitive CLASS_DOCUMENTATION = new pf_class_documentation();
+ private static final Primitive CLASS_DOCUMENTATION
+ = new pf_class_documentation();
private static final class pf_class_documentation extends Primitive {
pf_class_documentation() {
super("class-documentation", PACKAGE_SYS, true);
@@ -5499,12 +5500,13 @@
public LispObject execute(LispObject arg)
{
- return checkClass(arg).documentation;
+ return checkClass(arg).getDocumentation();
}
};
// ### %set-class-documentation
- private static final Primitive _SET_CLASS_DOCUMENTATION = new pf__set_class_documentation();
+ private static final Primitive _SET_CLASS_DOCUMENTATION
+ = new pf__set_class_documentation();
private static final class pf__set_class_documentation extends Primitive {
pf__set_class_documentation() {
super("%set-class-documentation", PACKAGE_SYS, true);
@@ -5514,7 +5516,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).documentation = second;
+ checkClass(first).setDocumentation(second);
return second;
}
};
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 Feb 14 16:29:58 2010
@@ -42,23 +42,35 @@
private LispObject directDefaultInitargs = NIL;
private LispObject defaultInitargs = NIL;
- public SlotClass()
+ public SlotClass(Layout layout)
{
+ super(layout);
}
public SlotClass(Symbol symbol, LispObject directSuperclasses)
+
+
+ {
+ this(null, symbol, directSuperclasses);
+ }
+
+ public SlotClass(Layout layout,
+ Symbol symbol, LispObject directSuperclasses)
{
- super(symbol, directSuperclasses);
+ super(layout, symbol, directSuperclasses);
}
@Override
public LispObject getParts()
{
LispObject result = super.getParts().nreverse();
- result = result.push(new Cons("DIRECT-SLOTS", directSlotDefinitions));
- result = result.push(new Cons("SLOTS", slotDefinitions));
- result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", directDefaultInitargs));
- result = result.push(new Cons("DEFAULT-INITARGS", defaultInitargs));
+ result = result.push(new Cons("DIRECT-SLOTS",
+ getDirectSlotDefinitions()));
+ result = result.push(new Cons("SLOTS", getSlotDefinitions()));
+ result = result.push(new Cons("DIRECT-DEFAULT-INITARGS",
+ getDirectDefaultInitargs()));
+ result = result.push(new Cons("DEFAULT-INITARGS",
+ getDefaultInitargs()));
return result.nreverse();
}
@@ -78,7 +90,7 @@
this.directSlotDefinitions = directSlotDefinitions;
}
- public final LispObject getSlotDefinitions()
+ public LispObject getSlotDefinitions()
{
return slotDefinitions;
}
@@ -98,6 +110,11 @@
this.directDefaultInitargs = directDefaultInitargs;
}
+ public LispObject getDefaultInitargs()
+ {
+ return defaultInitargs;
+ }
+
public void setDefaultInitargs(LispObject defaultInitargs)
{
this.defaultInitargs = defaultInitargs;
@@ -124,7 +141,8 @@
if (isFinalized())
return;
- Debug.assertTrue(slotDefinitions == NIL);
+ LispObject defs = getSlotDefinitions();
+ Debug.assertTrue(defs == NIL);
LispObject cpl = getCPL();
Debug.assertTrue(cpl != null);
Debug.assertTrue(cpl.listp());
@@ -133,20 +151,20 @@
LispObject car = cpl.car();
if (car instanceof StandardClass) {
StandardClass cls = (StandardClass) car;
- LispObject defs = cls.getDirectSlotDefinitions();
- Debug.assertTrue(defs != null);
- Debug.assertTrue(defs.listp());
- while (defs != NIL) {
- slotDefinitions = slotDefinitions.push(defs.car());
- defs = defs.cdr();
+ LispObject directDefs = cls.getDirectSlotDefinitions();
+ Debug.assertTrue(directDefs != null);
+ Debug.assertTrue(directDefs.listp());
+ while (directDefs != NIL) {
+ defs = defs.push(directDefs.car());
+ directDefs = directDefs.cdr();
}
}
cpl = cpl.cdr();
}
- slotDefinitions = slotDefinitions.nreverse();
- LispObject[] instanceSlotNames = new LispObject[slotDefinitions.length()];
+ setSlotDefinitions(defs.nreverse());
+ LispObject[] instanceSlotNames = new LispObject[defs.length()];
int i = 0;
- LispObject tail = slotDefinitions;
+ LispObject tail = getSlotDefinitions();
while (tail != NIL) {
SlotDefinition slotDefinition = (SlotDefinition) tail.car();
slotDefinition.setLocation(i);
@@ -167,7 +185,7 @@
{
if (arg instanceof SlotClass)
- return ((SlotClass)arg).directSlotDefinitions;
+ return ((SlotClass)arg).getDirectSlotDefinitions();
if (arg instanceof BuiltInClass)
return NIL;
return type_error(arg, Symbol.STANDARD_CLASS);
@@ -183,7 +201,7 @@
{
if (first instanceof SlotClass) {
- ((SlotClass)first).directSlotDefinitions = second;
+ ((SlotClass)first).setDirectSlotDefinitions(second);
return second;
}
else {
@@ -201,7 +219,7 @@
{
if (arg instanceof SlotClass)
- return ((SlotClass)arg).slotDefinitions;
+ return ((SlotClass)arg).getSlotDefinitions();
if (arg instanceof BuiltInClass)
return NIL;
return type_error(arg, Symbol.STANDARD_CLASS);
@@ -216,12 +234,12 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (first instanceof SlotClass) {
- ((SlotClass)first).slotDefinitions = second;
- return second;
+ if (first instanceof SlotClass) {
+ ((SlotClass)first).setSlotDefinitions(second);
+ return second;
}
- else {
- return type_error(first, Symbol.STANDARD_CLASS);
+ else {
+ return type_error(first, Symbol.STANDARD_CLASS);
}
}
};
@@ -235,7 +253,7 @@
{
if (arg instanceof SlotClass)
- return ((SlotClass)arg).directDefaultInitargs;
+ return ((SlotClass)arg).getDirectDefaultInitargs();
if (arg instanceof BuiltInClass)
return NIL;
return type_error(arg, Symbol.STANDARD_CLASS);
@@ -250,11 +268,11 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (first instanceof SlotClass) {
- ((SlotClass)first).directDefaultInitargs = second;
- return second;
- }
- return type_error(first, Symbol.STANDARD_CLASS);
+ if (first instanceof SlotClass) {
+ ((SlotClass)first).setDirectDefaultInitargs(second);
+ return second;
+ }
+ return type_error(first, Symbol.STANDARD_CLASS);
}
};
@@ -267,7 +285,7 @@
{
if (arg instanceof SlotClass)
- return ((SlotClass)arg).defaultInitargs;
+ return ((SlotClass)arg).getDefaultInitargs();
if (arg instanceof BuiltInClass)
return NIL;
return type_error(arg, Symbol.STANDARD_CLASS);
@@ -283,7 +301,7 @@
{
if (first instanceof SlotClass) {
- ((SlotClass)first).defaultInitargs = second;
+ ((SlotClass)first).setDefaultInitargs(second);
return second;
}
return type_error(first, Symbol.STANDARD_CLASS);
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 Feb 14 16:29:58 2010
@@ -37,24 +37,224 @@
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
+ = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
+ private static Symbol symDirectSubclasses
+ = PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
+ private static Symbol symClassPrecedenceList
+ = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
+ private static Symbol symDirectMethods
+ = PACKAGE_MOP.intern("DIRECT-METHODS");
+ private static Symbol symDocumentation
+ = PACKAGE_MOP.intern("DOCUMENTATION");
+ private static Symbol symDirectSlots
+ = PACKAGE_MOP.intern("DIRECT-SLOTS");
+ private static Symbol symSlots
+ = PACKAGE_MOP.intern("SLOTS");
+ private static Symbol symDirectDefaultInitargs
+ = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
+ private static Symbol symDefaultInitargs
+ = PACKAGE_MOP.intern("DEFAULT-INITARGS");
+
+ static Layout layoutStandardClass =
+ new Layout(null,
+ list(symName,
+ symLayout,
+ symDirectSuperclasses,
+ symDirectSubclasses,
+ symClassPrecedenceList,
+ symDirectMethods,
+ symDocumentation,
+ symDirectSlots,
+ symSlots,
+ symDirectDefaultInitargs,
+ symDefaultInitargs),
+ NIL)
+ {
+ @Override
+ public LispClass getLispClass()
+ {
+ return STANDARD_CLASS;
+ }
+ };
+
public StandardClass()
{
- setClassLayout(new Layout(this, NIL, NIL));
+ super(layoutStandardClass);
+ setDirectSuperclasses(NIL);
+ setDirectSubclasses(NIL);
+ setCPL(NIL);
+ setDirectMethods(NIL);
+ setDocumentation(NIL);
+ setDirectSlotDefinitions(NIL);
+ setSlotDefinitions(NIL);
+ setDirectDefaultInitargs(NIL);
+ setDefaultInitargs(NIL);
}
public StandardClass(Symbol symbol, LispObject directSuperclasses)
{
- super(symbol, directSuperclasses);
- setClassLayout(new Layout(this, NIL, NIL));
+ super(layoutStandardClass,
+ symbol, directSuperclasses);
+ setDirectSubclasses(NIL);
+ setCPL(NIL);
+ setDirectMethods(NIL);
+ setDocumentation(NIL);
+ setDirectSlotDefinitions(NIL);
+ setSlotDefinitions(NIL);
+ setDirectDefaultInitargs(NIL);
+ setDefaultInitargs(NIL);
+ }
+
+ @Override
+ public LispObject getName()
+ {
+ return getInstanceSlotValue(symName);
+ }
+
+ @Override
+ public void setName(LispObject newName)
+ {
+ setInstanceSlotValue(symName, newName);
+ }
+
+ @Override
+ public Layout getClassLayout()
+ {
+ LispObject layout = getInstanceSlotValue(symLayout);
+ return (layout == UNBOUND_VALUE) ? null : (Layout)layout;
+ }
+
+ @Override
+ public void setClassLayout(Layout newLayout)
+ {
+ setInstanceSlotValue(symLayout, newLayout);
+ }
+
+ @Override
+ public LispObject getDirectSuperclasses()
+ {
+ return getInstanceSlotValue(symDirectSuperclasses);
+ }
+
+ @Override
+ public void setDirectSuperclasses(LispObject directSuperclasses)
+ {
+ setInstanceSlotValue(symDirectSuperclasses, directSuperclasses);
+ }
+
+ @Override
+ public LispObject getDirectSubclasses()
+ {
+ return getInstanceSlotValue(symDirectSubclasses);
+ }
+
+ @Override
+ public void setDirectSubclasses(LispObject directSubclasses)
+ {
+ setInstanceSlotValue(symDirectSubclasses, directSubclasses);
+ }
+
+ @Override
+ public LispObject getCPL()
+ {
+ return getInstanceSlotValue(symClassPrecedenceList);
+ }
+
+ @Override
+ public void setCPL(LispObject... cpl)
+ {
+ LispObject obj1 = cpl[0];
+ if (obj1.listp() && cpl.length == 1)
+ setInstanceSlotValue(symClassPrecedenceList, 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);
+ }
+ }
+
+ @Override
+ public LispObject getDirectMethods()
+ {
+ return getInstanceSlotValue(symDirectMethods);
+ }
+
+ @Override
+ public void setDirectMethods(LispObject methods)
+ {
+ setInstanceSlotValue(symDirectMethods, methods);
}
@Override
- public LispObject typeOf()
+ public LispObject getDocumentation()
{
- return Symbol.STANDARD_CLASS;
+ return getInstanceSlotValue(symDocumentation);
}
@Override
+ public void setDocumentation(LispObject doc)
+ {
+ setInstanceSlotValue(symDocumentation, doc);
+ }
+
+ @Override
+ public LispObject getDirectSlotDefinitions()
+ {
+ return getInstanceSlotValue(symDirectSlots);
+ }
+
+ @Override
+ public void setDirectSlotDefinitions(LispObject directSlotDefinitions)
+ {
+ setInstanceSlotValue(symDirectSlots, directSlotDefinitions);
+ }
+
+ @Override
+ public LispObject getSlotDefinitions()
+ {
+ return getInstanceSlotValue(symSlots);
+ }
+
+ @Override
+ public void setSlotDefinitions(LispObject slotDefinitions)
+ {
+ setInstanceSlotValue(symSlots, slotDefinitions);
+ }
+
+ @Override
+ public LispObject getDirectDefaultInitargs()
+ {
+ return getInstanceSlotValue(symDirectDefaultInitargs);
+ }
+
+ @Override
+ public void setDirectDefaultInitargs(LispObject directDefaultInitargs)
+ {
+ setInstanceSlotValue(symDirectDefaultInitargs, directDefaultInitargs);
+ }
+
+ @Override
+ public LispObject getDefaultInitargs()
+ {
+ return getInstanceSlotValue(symDefaultInitargs);
+ }
+
+ @Override
+ public void setDefaultInitargs(LispObject defaultInitargs)
+ {
+ setInstanceSlotValue(symDefaultInitargs, defaultInitargs);
+ }
+
+
+
+ @Override
public LispObject classOf()
{
return STANDARD_CLASS;
@@ -89,10 +289,10 @@
{
StringBuilder sb =
new StringBuilder(Symbol.STANDARD_CLASS.writeToString());
- if (symbol != null)
+ if (getName() != null)
{
sb.append(' ');
- sb.append(symbol.writeToString());
+ sb.append(getName().writeToString());
}
return unreadableString(sb.toString());
}
@@ -114,6 +314,16 @@
public static final StandardClass STANDARD_OBJECT =
addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T));
+ public static final StandardClass SLOT_DEFINITION =
+ new SlotDefinitionClass();
+ static
+ {
+ addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);
+
+ STANDARD_CLASS.setClassLayout(layoutStandardClass);
+ STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
+ }
+
// BuiltInClass.FUNCTION is also null here (see previous comment).
public static final StandardClass GENERIC_FUNCTION =
addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION,
@@ -259,13 +469,6 @@
addClass(Symbol.STANDARD_GENERIC_FUNCTION, STANDARD_GENERIC_FUNCTION);
}
- public static final StandardClass SLOT_DEFINITION =
- new SlotDefinitionClass();
- static
- {
- addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);
- }
-
public static void initializeStandardClasses()
{
// We need to call setDirectSuperclass() here for classes that have a
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 Feb 14 16:29:58 2010
@@ -209,7 +209,7 @@
if (name != null)
{
StringBuilder sb = new StringBuilder();
- sb.append(getLispClass().getSymbol().writeToString());
+ sb.append(getLispClass().getName().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 Feb 14 16:29:58 2010
@@ -156,7 +156,7 @@
if (name != null)
{
StringBuilder sb = new StringBuilder();
- sb.append(getLispClass().getSymbol().writeToString());
+ sb.append(getLispClass().getName().writeToString());
sb.append(' ');
sb.append(name.writeToString());
LispObject specializers =
@@ -169,7 +169,7 @@
{
LispObject spec = specs.car();
if (spec instanceof LispClass)
- names = names.push(((LispClass)spec).getSymbol());
+ names = names.push(((LispClass)spec).getName());
else
names = names.push(spec);
specs = specs.cdr();
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 Feb 14 16:29:58 2010
@@ -45,9 +45,19 @@
layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL);
}
+
+ protected StandardObject(Layout layout, int length)
+ {
+ this.layout = layout;
+ slots = new LispObject[length];
+ for (int i = slots.length; i-- > 0;)
+ slots[i] = UNBOUND_VALUE;
+ }
+
+
protected StandardObject(LispClass cls, int length)
{
- layout = cls.getClassLayout();
+ layout = cls == null ? null : cls.getClassLayout();
slots = new LispObject[length];
for (int i = slots.length; i-- > 0;)
slots[i] = UNBOUND_VALUE;
@@ -55,8 +65,8 @@
protected StandardObject(LispClass cls)
{
- layout = cls.getClassLayout();
- slots = new LispObject[layout.getLength()];
+ layout = cls == null ? null : cls.getClassLayout();
+ slots = new LispObject[layout == null ? 0 : layout.getLength()];
for (int i = slots.length; i-- > 0;)
slots[i] = UNBOUND_VALUE;
}
@@ -90,7 +100,7 @@
public final LispClass getLispClass()
{
- return layout.lispClass;
+ return layout.getLispClass();
}
@Override
@@ -100,16 +110,16 @@
// 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.lispClass;
+ final LispClass c1 = layout.getLispClass();
// The proper name of a class is "a symbol that names the class whose
// name is that symbol".
- final Symbol symbol = c1.getSymbol();
- if (symbol != NIL)
+ final LispObject name = c1.getName();
+ if (name != NIL && name != UNBOUND_VALUE)
{
// TYPE-OF.9
- final LispObject c2 = LispClass.findClass(symbol);
+ final LispObject c2 = LispClass.findClass(checkSymbol(name));
if (c2 == c1)
- return symbol;
+ return name;
}
return c1;
}
@@ -117,7 +127,7 @@
@Override
public LispObject classOf()
{
- return layout.lispClass;
+ return layout.getLispClass();
}
@Override
@@ -127,19 +137,19 @@
return T;
if (type == StandardClass.STANDARD_OBJECT)
return T;
- LispClass cls = layout != null ? layout.lispClass : null;
+ LispClass cls = layout != null ? layout.getLispClass() : null;
if (cls != null)
{
if (type == cls)
return T;
- if (type == cls.getSymbol())
+ if (type == cls.getName())
return T;
LispObject cpl = cls.getCPL();
while (cpl != NIL)
{
if (type == cpl.car())
return T;
- if (type == ((LispClass)cpl.car()).getSymbol())
+ if (type == ((LispClass)cpl.car()).getName())
return T;
cpl = cpl.cdr();
}
@@ -173,7 +183,7 @@
{
Debug.assertTrue(layout.isInvalid());
Layout oldLayout = layout;
- LispClass cls = oldLayout.lispClass;
+ LispClass cls = oldLayout.getLispClass();
Layout newLayout = cls.getClassLayout();
Debug.assertTrue(!newLayout.isInvalid());
StandardObject newInstance = new StandardObject(cls);
@@ -340,7 +350,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkStandardObject(arg).layout.lispClass;
+ return checkStandardObject(arg).layout.getLispClass();
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StructureClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sun Feb 14 16:29:58 2010
@@ -79,7 +79,7 @@
public String writeToString()
{
StringBuffer sb = new StringBuffer("#<STRUCTURE-CLASS ");
- sb.append(symbol.writeToString());
+ sb.append(getName().writeToString());
sb.append('>');
return sb.toString();
}
Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StructureObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Sun Feb 14 16:29:58 2010
@@ -144,7 +144,7 @@
@Override
public LispObject typeOf()
{
- return structureClass.getSymbol();
+ return structureClass.getName();
}
@Override
@@ -175,7 +175,7 @@
{
if (type instanceof StructureClass)
return memq(type, structureClass.getCPL()) ? T : NIL;
- if (type == structureClass.getSymbol())
+ if (type == structureClass.getName())
return T;
if (type == Symbol.STRUCTURE_OBJECT)
return T;
@@ -421,7 +421,7 @@
return stream.getString().getStringValue();
}
if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL)
- return unreadableString(structureClass.getSymbol().writeToString());
+ return unreadableString(structureClass.getName().writeToString());
int maxLevel = Integer.MAX_VALUE;
LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread);
if (printLevel instanceof Fixnum)
@@ -432,7 +432,7 @@
if (currentLevel >= maxLevel && slots.length > 0)
return "#";
StringBuilder sb = new StringBuilder("#S(");
- sb.append(structureClass.getSymbol().writeToString());
+ sb.append(structureClass.getName().writeToString());
if (currentLevel < maxLevel)
{
LispObject effectiveSlots = structureClass.getSlotDefinitions();
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 Feb 14 16:29:58 2010
@@ -1781,6 +1781,7 @@
)))
(fmakunbound 'class-name)
+(fmakunbound '(setf class-name))
(defgeneric class-name (class))
@@ -1800,6 +1801,9 @@
(defmethod class-precedence-list ((class class))
(%class-precedence-list class))
+
+
+(fmakunbound 'documentation)
(defgeneric documentation (x doc-type))
(defgeneric (setf documentation) (new-value x doc-type))
@@ -2389,4 +2393,5 @@
;; FIXME
(defgeneric function-keywords (method))
+
(provide 'clos)
Modified: trunk/abcl/src/org/armedbear/lisp/make_condition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/make_condition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/make_condition.java Sun Feb 14 16:29:58 2010
@@ -52,7 +52,7 @@
if (type instanceof Symbol)
symbol = (Symbol) type;
else if (type instanceof LispClass)
- symbol = ((LispClass)type).getSymbol();
+ symbol = checkSymbol(((LispClass)type).getName());
else {
// This function only works on symbols and classes.
return NIL;
More information about the armedbear-cvs
mailing list