[armedbear-cvs] r12527 - branches/metaclass/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Mar 13 19:05:17 UTC 2010
Author: ehuelsmann
Date: Sat Mar 13 14:05:15 2010
New Revision: 12527
Log:
Make all class accessor functions generic functions instead
of normal ones, to support METACLASS. Additionally, make
it possible to store general objects in Layout.lispClass.
Because classes may be of a different Java type than
StandardClass, fall back to the generic functions to access
the required fields from Java.
See #38.
Modified:
branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java
branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java
branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java
branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java
branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java
branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java
branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java Sat Mar 13 14:05:15 2010
@@ -684,7 +684,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: branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java Sat Mar 13 14:05:15 2010
@@ -137,16 +137,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: branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java Sat Mar 13 14:05:15 2010
@@ -37,7 +37,7 @@
public class Layout extends LispObject
{
- private final LispClass lispClass;
+ private final LispObject lispClass;
public final EqHashTable slotTable;
private 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: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Mar 13 14:05:15 2010
@@ -179,9 +179,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 +201,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;
}
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java Sat Mar 13 14:05:15 2010
@@ -668,6 +668,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: branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java Sat Mar 13 14:05:15 2010
@@ -5331,16 +5331,16 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).setName(checkSymbol(second));
- return second;
+ checkClass(second).setName(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
@@ -5361,19 +5361,19 @@
public LispObject execute(LispObject first, LispObject second)
{
- if (second instanceof Layout) {
- checkClass(first).setClassLayout((Layout)second);
- return second;
+ if (first == NIL || first instanceof Layout) {
+ checkClass(second).setClassLayout(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
@@ -5393,16 +5393,16 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).setDirectSuperclasses(second);
- return second;
+ checkClass(second).setDirectSuperclasses(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
@@ -5423,8 +5423,8 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).setDirectSubclasses(second);
- return second;
+ checkClass(second).setDirectSubclasses(first);
+ return first;
}
};
@@ -5441,27 +5441,27 @@
}
};
- // ### 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;
+ checkClass(second).setCPL(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
@@ -5483,8 +5483,8 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).setDirectMethods(second);
- return second;
+ checkClass(second).setDirectMethods(first);
+ return first;
}
};
@@ -5521,11 +5521,11 @@
}
};
- // ### 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
@@ -5545,8 +5545,8 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(first).setFinalized(second != NIL);
- return second;
+ checkClass(second).setFinalized(first != NIL);
+ return first;
}
};
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Sat Mar 13 14:05:15 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,11 +300,11 @@
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);
}
};
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java Sat Mar 13 14:05:15 2010
@@ -70,7 +70,7 @@
slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
}
- public static SlotDefinition checkSlotDefination(LispObject obj) {
+ public static SlotDefinition checkSlotDefinition(LispObject obj) {
if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);
}
@@ -117,7 +117,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
}
};
@@ -130,7 +130,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
return second;
}
};
@@ -142,12 +142,12 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
}
};
// ### 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")
{
@@ -155,7 +155,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
return second;
}
};
@@ -168,12 +168,12 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
}
};
// ### 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")
{
@@ -181,7 +181,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
return second;
}
};
@@ -193,7 +193,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
}
};
@@ -206,7 +206,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
return second;
}
};
@@ -219,7 +219,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
}
};
@@ -232,7 +232,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
return second;
}
};
@@ -245,7 +245,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
}
};
@@ -258,7 +258,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
return second;
}
};
@@ -271,7 +271,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
}
};
@@ -284,7 +284,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
return second;
}
};
@@ -297,7 +297,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
}
};
@@ -310,7 +310,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
return second;
}
};
@@ -322,7 +322,7 @@
@Override
public LispObject execute(LispObject arg)
{
- return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
}
};
@@ -334,7 +334,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
return second;
}
};
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Mar 13 14:05:15 2010
@@ -58,6 +58,8 @@
= PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
private static Symbol symDefaultInitargs
= PACKAGE_MOP.intern("DEFAULT-INITARGS");
+ private static Symbol symFinalizedP
+ = PACKAGE_MOP.intern("FINALIZED-P");
static Layout layoutStandardClass =
new Layout(null,
@@ -71,7 +73,8 @@
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);
@@ -322,6 +341,20 @@
STANDARD_CLASS.setClassLayout(layoutStandardClass);
STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
+ LispObject slots = STANDARD_CLASS.getDirectSlotDefinitions();
+ while (slots != NIL) {
+ SlotDefinition slot = (SlotDefinition)slots.car();
+ if (slot.getName() == symLayout)
+ SlotDefinition.SET_SLOT_DEFINITION_INITFUNCTION.execute(slot,
+ new Function() {
+ at Override
+ public LispObject execute() {
+ return NIL;
+}
+ });
+ slots = slots.cdr();
+ }
+
}
// BuiltInClass.FUNCTION is also null here (see previous comment).
@@ -616,6 +649,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: branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Mar 13 14:05:15 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: branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java Sat Mar 13 14:05:15 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: branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java Sat Mar 13 14:05:15 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,10 +133,15 @@
// 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
@@ -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: branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java Sat Mar 13 14:05:15 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)
@@ -2913,6 +2920,10 @@
PACKAGE_EXT.addExternalSymbol("*LOAD-TRUENAME-FASL*");
// 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: branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp Sat Mar 13 14:05:15 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)
@@ -254,25 +289,23 @@
;;; finalize-inheritance
(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
- (funcall (if (eq (class-of class) (find-class 'standard-class))
- #'std-compute-slots
- #'compute-slots)
- class))
+ (setf (class-slots class)
+ (funcall (if (eq (class-of class) (find-class 'standard-class))
+ #'std-compute-slots
+ #'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,7 +325,7 @@
(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))))))))
@@ -392,7 +425,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 +464,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 +514,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 +532,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 +571,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 +598,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 +617,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 +869,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 +1819,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 class-precedence-list)
+(redefine-class-forwarder (setf class-precedence-list) class-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 +2031,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)
@@ -1969,6 +2050,7 @@
(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
(declare (ignore new-value))
+ (mapcar #'print (mapcar #'frame-to-string (sys::backtrace)))
(error "The slot ~S is missing from the class ~S." slot-name class))
(defgeneric slot-unbound (class instance slot-name))
@@ -1986,8 +2068,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 +2094,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 +2177,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 +2202,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 +2235,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 +2422,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 +2437,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,5 +2476,6 @@
;; FIXME
(defgeneric function-keywords (method))
+(setf *clos-booting* nil)
(provide 'clos)
More information about the armedbear-cvs
mailing list