From c122699fc585f94cc99dffd84fbd704847c12a92 Mon Sep 17 00:00:00 2001 From: "ehuelsmann@1c010e3e-69d0-11dd-93a8-456734b0d56f" Date: Sun, 14 Feb 2010 21:29:58 +0000 Subject: [PATCH] Merge 'metaclass' branch, making STANDARD-CLASS have slots to be inherited by deriving metaclasses. Note: this does definitely *not* complete the metaclass work. --- src/org/armedbear/lisp/BuiltInClass.java | 2 +- src/org/armedbear/lisp/Condition.java | 2 +- .../lisp/ForwardReferencedClass.java | 4 +- src/org/armedbear/lisp/Layout.java | 15 +- src/org/armedbear/lisp/LispClass.java | 142 +++++------ src/org/armedbear/lisp/Primitives.java | 20 +- src/org/armedbear/lisp/SlotClass.java | 84 ++++--- src/org/armedbear/lisp/StandardClass.java | 231 ++++++++++++++++-- .../lisp/StandardGenericFunction.java | 2 +- src/org/armedbear/lisp/StandardMethod.java | 4 +- src/org/armedbear/lisp/StandardObject.java | 40 +-- src/org/armedbear/lisp/StructureClass.java | 2 +- src/org/armedbear/lisp/StructureObject.java | 8 +- src/org/armedbear/lisp/clos.lisp | 5 + src/org/armedbear/lisp/make_condition.java | 2 +- 15 files changed, 391 insertions(+), 172 deletions(-) diff --git a/src/org/armedbear/lisp/BuiltInClass.java b/src/org/armedbear/lisp/BuiltInClass.java index 2d75bd2b..74228ad6 100644 --- a/src/org/armedbear/lisp/BuiltInClass.java +++ b/src/org/armedbear/lisp/BuiltInClass.java @@ -74,7 +74,7 @@ public class BuiltInClass extends LispClass public String writeToString() { StringBuilder sb = new StringBuilder("#'); return sb.toString(); } diff --git a/src/org/armedbear/lisp/Condition.java b/src/org/armedbear/lisp/Condition.java index 2d741b8f..7c9ab88b 100644 --- a/src/org/armedbear/lisp/Condition.java +++ b/src/org/armedbear/lisp/Condition.java @@ -139,7 +139,7 @@ public class Condition extends StandardObject { LispClass c = getLispClass(); if (c != null) - return c.getSymbol(); + return c.getName(); return Symbol.CONDITION; } diff --git a/src/org/armedbear/lisp/ForwardReferencedClass.java b/src/org/armedbear/lisp/ForwardReferencedClass.java index f14ea71a..a60e4f2d 100644 --- a/src/org/armedbear/lisp/ForwardReferencedClass.java +++ b/src/org/armedbear/lisp/ForwardReferencedClass.java @@ -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()); } diff --git a/src/org/armedbear/lisp/Layout.java b/src/org/armedbear/lisp/Layout.java index 4e01872f..1214e962 100644 --- a/src/org/armedbear/lisp/Layout.java +++ b/src/org/armedbear/lisp/Layout.java @@ -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(); } }; diff --git a/src/org/armedbear/lisp/LispClass.java b/src/org/armedbear/lisp/LispClass.java index 72da00e1..c8610b51 100644 --- a/src/org/armedbear/lisp/LispClass.java +++ b/src/org/armedbear/lisp/LispClass.java @@ -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) diff --git a/src/org/armedbear/lisp/Primitives.java b/src/org/armedbear/lisp/Primitives.java index 36a18c9c..d71b8843 100644 --- a/src/org/armedbear/lisp/Primitives.java +++ b/src/org/armedbear/lisp/Primitives.java @@ -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; } }; diff --git a/src/org/armedbear/lisp/SlotClass.java b/src/org/armedbear/lisp/SlotClass.java index bc631f48..c9caa760 100644 --- a/src/org/armedbear/lisp/SlotClass.java +++ b/src/org/armedbear/lisp/SlotClass.java @@ -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); diff --git a/src/org/armedbear/lisp/StandardClass.java b/src/org/armedbear/lisp/StandardClass.java index af9e8fa8..8ed5ad2a 100644 --- a/src/org/armedbear/lisp/StandardClass.java +++ b/src/org/armedbear/lisp/StandardClass.java @@ -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 + 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() { @@ -89,10 +289,10 @@ public class StandardClass extends SlotClass { 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 class StandardClass extends SlotClass 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 @@ public class StandardClass extends SlotClass 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 diff --git a/src/org/armedbear/lisp/StandardGenericFunction.java b/src/org/armedbear/lisp/StandardGenericFunction.java index c972d2ee..3b59be7e 100644 --- a/src/org/armedbear/lisp/StandardGenericFunction.java +++ b/src/org/armedbear/lisp/StandardGenericFunction.java @@ -209,7 +209,7 @@ public final class StandardGenericFunction extends StandardObject 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()); diff --git a/src/org/armedbear/lisp/StandardMethod.java b/src/org/armedbear/lisp/StandardMethod.java index 88e4bba5..0f7f1be0 100644 --- a/src/org/armedbear/lisp/StandardMethod.java +++ b/src/org/armedbear/lisp/StandardMethod.java @@ -156,7 +156,7 @@ public class StandardMethod extends StandardObject 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 @@ public class StandardMethod extends StandardObject { 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(); diff --git a/src/org/armedbear/lisp/StandardObject.java b/src/org/armedbear/lisp/StandardObject.java index 74d6f325..63157d33 100644 --- a/src/org/armedbear/lisp/StandardObject.java +++ b/src/org/armedbear/lisp/StandardObject.java @@ -45,9 +45,19 @@ public class StandardObject extends LispObject 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 @@ public class StandardObject extends LispObject 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 class StandardObject extends LispObject public final LispClass getLispClass() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -100,16 +110,16 @@ public class StandardObject extends LispObject // 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 @@ public class StandardObject extends LispObject @Override public LispObject classOf() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -127,19 +137,19 @@ public class StandardObject extends LispObject 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 @@ public class StandardObject extends LispObject { 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 @@ public class StandardObject extends LispObject @Override public LispObject execute(LispObject arg) { - return checkStandardObject(arg).layout.lispClass; + return checkStandardObject(arg).layout.getLispClass(); } }; diff --git a/src/org/armedbear/lisp/StructureClass.java b/src/org/armedbear/lisp/StructureClass.java index 20ded736..4e457c2e 100644 --- a/src/org/armedbear/lisp/StructureClass.java +++ b/src/org/armedbear/lisp/StructureClass.java @@ -79,7 +79,7 @@ public class StructureClass extends SlotClass public String writeToString() { StringBuffer sb = new StringBuffer("#'); return sb.toString(); } diff --git a/src/org/armedbear/lisp/StructureObject.java b/src/org/armedbear/lisp/StructureObject.java index 527b5539..4d441352 100644 --- a/src/org/armedbear/lisp/StructureObject.java +++ b/src/org/armedbear/lisp/StructureObject.java @@ -144,7 +144,7 @@ public class StructureObject extends LispObject @Override public LispObject typeOf() { - return structureClass.getSymbol(); + return structureClass.getName(); } @Override @@ -175,7 +175,7 @@ public class StructureObject extends LispObject { 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 @@ public class StructureObject extends LispObject 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 @@ public class StructureObject extends LispObject 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(); diff --git a/src/org/armedbear/lisp/clos.lisp b/src/org/armedbear/lisp/clos.lisp index d95397cf..9258ff7f 100644 --- a/src/org/armedbear/lisp/clos.lisp +++ b/src/org/armedbear/lisp/clos.lisp @@ -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) diff --git a/src/org/armedbear/lisp/make_condition.java b/src/org/armedbear/lisp/make_condition.java index acf1e7a7..e24f5135 100644 --- a/src/org/armedbear/lisp/make_condition.java +++ b/src/org/armedbear/lisp/make_condition.java @@ -52,7 +52,7 @@ public final class make_condition extends Primitive 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; -- GitLab