Merge 'metaclass' branch, making STANDARD-CLASS have slots to

  be inherited by deriving metaclasses.

Note: this does definitely *not* complete the metaclass work.
parent b8072234
......@@ -74,7 +74,7 @@ public class BuiltInClass extends LispClass
public String writeToString()
{
StringBuilder sb = new StringBuilder("#<BUILT-IN-CLASS ");
sb.append(symbol.writeToString());
sb.append(getName().writeToString());
sb.append('>');
return sb.toString();
}
......
......@@ -139,7 +139,7 @@ public class Condition extends StandardObject
{
LispClass c = getLispClass();
if (c != null)
return c.getSymbol();
return c.getName();
return Symbol.CONDITION;
}
......
......@@ -69,9 +69,9 @@ public class ForwardReferencedClass extends LispClass
{
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());
}
......
......@@ -35,9 +35,9 @@ package org.armedbear.lisp;
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 @@ public final class Layout extends LispObject
// 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 final class Layout extends LispObject
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 @@ public final class Layout extends LispObject
return result.nreverse();
}
public LispClass getLispClass()
{
return lispClass;
}
public boolean isInvalid()
{
return invalid;
......@@ -167,7 +172,7 @@ public final class Layout extends LispObject
@Override
public LispObject execute(LispObject arg)
{
return checkLayout(arg).lispClass;
return checkLayout(arg).getLispClass();
}
};
......
......@@ -88,46 +88,57 @@ public abstract class LispClass extends StandardObject
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 @@ public abstract class LispClass extends StandardObject
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 @@ public abstract class LispClass extends StandardObject
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 @@ public abstract class LispClass extends StandardObject
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 @@ public abstract class LispClass extends StandardObject
// 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 abstract class LispClass extends StandardObject
public boolean subclassp(LispObject obj)
{
LispObject cpl = classPrecedenceList;
LispObject cpl = getCPL();
while (cpl != NIL)
{
if (cpl.car() == obj)
......
......@@ -5316,7 +5316,7 @@ for (LispObject a : args)
@Override
public LispObject execute(LispObject arg) {
return checkClass(arg).symbol;
return checkClass(arg).getName();
}
};
......@@ -5331,7 +5331,7 @@ for (LispObject a : args)
public LispObject execute(LispObject first, LispObject second)
{
checkClass(first).symbol = checkSymbol(second);
checkClass(first).setName(checkSymbol(second));
return second;
}
};
......@@ -5452,7 +5452,7 @@ for (LispObject a : args)
public LispObject execute(LispObject first, LispObject second)
{
checkClass(first).classPrecedenceList = second;
checkClass(first).setCPL(second);
return second;
}
};
......@@ -5468,7 +5468,7 @@ for (LispObject a : args)
public LispObject execute(LispObject arg)
{
return checkClass(arg).directMethods;
return checkClass(arg).getDirectMethods();
}
};
......@@ -5483,13 +5483,14 @@ for (LispObject a : args)
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 @@ for (LispObject a : args)
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 @@ for (LispObject a : args)
public LispObject execute(LispObject first, LispObject second)
{
checkClass(first).documentation = second;
checkClass(first).setDocumentation(second);
return second;
}
};
......
......@@ -42,23 +42,35 @@ public class SlotClass extends LispClass
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 @@ public class SlotClass extends LispClass
this.directSlotDefinitions = directSlotDefinitions;
}
public final LispObject getSlotDefinitions()
public LispObject getSlotDefinitions()
{
return slotDefinitions;
}
......@@ -98,6 +110,11 @@ public class SlotClass extends LispClass
this.directDefaultInitargs = directDefaultInitargs;
}
public LispObject getDefaultInitargs()
{
return defaultInitargs;
}
public void setDefaultInitargs(LispObject defaultInitargs)
{
this.defaultInitargs = defaultInitargs;
......@@ -124,7 +141,8 @@ public class SlotClass extends LispClass
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 @@ public class SlotClass extends LispClass
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 @@ public class SlotClass extends LispClass
{
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 @@ public class SlotClass extends LispClass
{
if (first instanceof SlotClass) {
((SlotClass)first).directSlotDefinitions = second;
((SlotClass)first).setDirectSlotDefinitions(second);
return second;
}
else {
......@@ -201,7 +219,7 @@ public class SlotClass extends LispClass
{
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 class SlotClass extends LispClass
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 @@ public class SlotClass extends LispClass
{
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 class SlotClass extends LispClass
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 @@ public class SlotClass extends LispClass
{
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 @@ public class SlotClass extends LispClass
{
if (first instanceof SlotClass) {
((SlotClass)first).defaultInitargs = second;
((SlotClass)first).setDefaultInitargs(second);
return second;
}
return type_error(first, Symbol.STANDARD_CLASS);
......
......@@ -37,23 +37,223 @@ import static org.armedbear.lisp.Lisp.*;
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