ABCL - Release notes v0.19

+ +

Most notable changes in ABCL 0.19

+ + +

Release notes for older releases.

+ +

Note: Due to issues in version 0.19.0, that specific + version was never released.

+ +

Support for user-extensible sequences: Support for the functionality proposed by Christopher Rhodes + at the International Lisp Conference 2007, user-extensible + sequences; these were provided by SBCL for a while now. With this + release, ABCL adds support too.
Much better support for inlining anonymous and local functions: Before, only functions with fixed numbers of arguments were + inlined when declared inline. Now, inlining also happens to functions + with &optional and &keyword arguments or &rest parameters.
EXT:*COMMAND-LINE-ARGUMENT-LIST*: Unprocessed command line arguments are collected in this variable for + Lisp programs to use.

+ + + + + +

Back to Common-lisp.net.

+ +

+ Valid XHTML 1.0 Strict +

$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $

+ + From astalla at common-lisp.net Sun Mar 28 19:22:20 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 28 Mar 2010 15:22:20 -0400 Subject: [armedbear-cvs] r12575 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Mar 28 15:22:19 2010 New Revision: 12575 Log: Made SEQUENCE be a built-in class again to avoid to cause problems with metaclass support. This temporarily makes extending SEQUENCE impossible, until we make certain built-in classes be extensible. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sun Mar 28 15:22:19 2010 @@ -119,6 +119,7 @@ public static final BuiltInClass READTABLE = addClass(Symbol.READTABLE); public static final BuiltInClass REAL = addClass(Symbol.REAL); public static final BuiltInClass RESTART = addClass(Symbol.RESTART); + public static final BuiltInClass SEQUENCE = addClass(Symbol.SEQUENCE); public static final BuiltInClass SIMPLE_ARRAY = addClass(Symbol.SIMPLE_ARRAY); public static final BuiltInClass SIMPLE_BASE_STRING = addClass(Symbol.SIMPLE_BASE_STRING); public static final BuiltInClass SIMPLE_BIT_VECTOR = addClass(Symbol.SIMPLE_BIT_VECTOR); @@ -138,10 +139,6 @@ (StructureClass)addClass(Symbol.STRUCTURE_OBJECT, new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T))); - public static final SlotClass SEQUENCE = - (SlotClass) addClass(Symbol.SEQUENCE, - new SlotClass(Symbol.SEQUENCE, list(CLASS_T))); - /* All the stream classes below are being defined as structure classes but won't be available as such until further action is taken: the 'defstruct' internal administration is missing. From ehuelsmann at common-lisp.net Sun Mar 28 20:13:16 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Mar 2010 16:13:16 -0400 Subject: [armedbear-cvs] r12576 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 28 16:13:14 2010 New Revision: 12576 Log: Re #38: Merge the METACLASS branch to trunk. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Condition.java trunk/abcl/src/org/armedbear/lisp/Layout.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispClass.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/SlotClass.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Mar 28 16:13:14 2010 @@ -685,7 +685,7 @@ autoload(Symbol.SET_CHAR, "StringFunctions"); autoload(Symbol.SET_SCHAR, "StringFunctions"); - autoload(Symbol.SET_CLASS_SLOTS, "SlotClass"); + autoload(Symbol._SET_CLASS_SLOTS, "SlotClass"); autoload(Symbol._CLASS_SLOTS, "SlotClass"); autoload(Symbol.JAVA_EXCEPTION_CAUSE, "JavaException"); Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Condition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Condition.java Sun Mar 28 16:13:14 2010 @@ -141,16 +141,18 @@ @Override public LispObject typeOf() { - LispClass c = getLispClass(); - if (c != null) - return c.getName(); + LispObject c = getLispClass(); + if (c instanceof LispClass) + return ((LispClass)c).getName(); + else if (c != null) + return Symbol.CLASS_NAME.execute(c); return Symbol.CONDITION; } @Override public LispObject classOf() { - LispClass c = getLispClass(); + LispObject c = getLispClass(); if (c != null) return c; return StandardClass.CONDITION; Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Layout.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Layout.java Sun Mar 28 16:13:14 2010 @@ -37,7 +37,7 @@ public class Layout extends LispObject { - private final LispClass lispClass; + private final LispObject lispClass; public final EqHashTable slotTable; final LispObject[] slotNames; @@ -45,7 +45,7 @@ private boolean invalid; - public Layout(LispClass lispClass, LispObject instanceSlots, LispObject sharedSlots) + public Layout(LispObject lispClass, LispObject instanceSlots, LispObject sharedSlots) { this.lispClass = lispClass; Debug.assertTrue(instanceSlots.listp()); @@ -64,7 +64,7 @@ slotTable = initializeSlotTable(slotNames); } - public Layout(LispClass lispClass, LispObject[] instanceSlotNames, + public Layout(LispObject lispClass, LispObject[] instanceSlotNames, LispObject sharedSlots) { this.lispClass = lispClass; @@ -103,7 +103,7 @@ return result.nreverse(); } - public LispClass getLispClass() + public LispObject getLispClass() { return lispClass; } @@ -159,8 +159,7 @@ LispObject third) { - return new Layout(checkClass(first), checkList(second), - checkList(third)); + return new Layout(first, checkList(second), checkList(third)); } }; @@ -235,7 +234,7 @@ public LispObject execute(LispObject first, LispObject second) { - final Layout layOutFirst = checkLayout(first); + final Layout layOutFirst = checkLayout(first); final LispObject slotNames[] = layOutFirst.slotNames; final int limit = slotNames.length; for (int i = 0; i < limit; i++) @@ -263,11 +262,20 @@ @Override public LispObject execute(LispObject arg) { - final LispClass lispClass = checkClass(arg); - Layout oldLayout = lispClass.getClassLayout(); - Layout newLayout = new Layout(oldLayout); - lispClass.setClassLayout(newLayout); - oldLayout.invalidate(); + final LispObject lispClass = arg; + LispObject oldLayout; + if (lispClass instanceof LispClass) + oldLayout = ((LispClass)lispClass).getClassLayout(); + else + oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass); + + Layout newLayout = new Layout((Layout)oldLayout); + if (lispClass instanceof LispClass) + ((LispClass)lispClass).setClassLayout(newLayout); + else + Symbol.CLASS_LAYOUT.getSymbolSetfFunction() + .execute(newLayout, lispClass); + ((Layout)oldLayout).invalidate(); return arg; } }; Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Mar 28 16:13:14 2010 @@ -1653,15 +1653,6 @@ type_error(obj, Symbol.STRING); } - public final static LispClass checkClass(LispObject obj) - - { - if (obj instanceof LispClass) - return (LispClass) obj; - return (LispClass)// Not reached. - type_error(obj, Symbol.CLASS); - } - public final static Layout checkLayout(LispObject obj) { Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Sun Mar 28 16:13:14 2010 @@ -48,6 +48,15 @@ return c; } + public static LispObject addClass(Symbol symbol, LispObject c) + { + synchronized (map) + { + map.put(symbol, c); + } + return c; + } + public static void removeClass(Symbol symbol) { synchronized (map) @@ -68,10 +77,10 @@ { final Symbol symbol = checkSymbol(name); - final LispClass c; + final LispObject c; synchronized (map) { - c = (LispClass) map.get(symbol); + c = map.get(symbol); } if (c != null) return c; @@ -179,9 +188,9 @@ return classLayout; } - public void setClassLayout(Layout layout) + public void setClassLayout(LispObject layout) { - classLayout = layout; + classLayout = layout == NIL ? null : (Layout)layout; } public final int getLayoutLength() @@ -201,12 +210,12 @@ this.directSuperclasses = directSuperclasses; } - public final boolean isFinalized() + public boolean isFinalized() { return finalized; } - public final void setFinalized(boolean b) + public void setFinalized(boolean b) { finalized = b; } @@ -291,13 +300,29 @@ public boolean subclassp(LispObject obj) { - LispObject cpl = getCPL(); + return false; + } + + public static boolean subclassp(LispObject cls, LispObject obj) + { + LispObject cpl; + + if (cls instanceof LispClass) + cpl = ((LispClass)cls).getCPL(); + else + cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls); + while (cpl != NIL) { if (cpl.car() == obj) return true; cpl = ((Cons)cpl).cdr; } + + if (cls instanceof LispClass) + // additional checks (currently because of JavaClass) + return ((LispClass)cls).subclassp(obj); + return false; } @@ -340,8 +365,7 @@ removeClass(name); return second; } - final LispClass c = checkClass(second); - addClass(name, c); + addClass(name, second); return second; } }; @@ -354,8 +378,7 @@ public LispObject execute(LispObject first, LispObject second) { - final LispClass c = checkClass(first); - return c.subclassp(second) ? T : NIL; + return LispClass.subclassp(first, second) ? T : NIL; } }; } Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Mar 28 16:13:14 2010 @@ -677,6 +677,16 @@ return type_error(this, Symbol.SYMBOL); } + public LispObject getSymbolSetfFunction() + { + return type_error(this, Symbol.SYMBOL); + } + + public LispObject getSymbolSetfFunctionOrDie() + { + return type_error(this, Symbol.SYMBOL); + } + public String writeToString() { return toString(); Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Mar 28 16:13:14 2010 @@ -5316,7 +5316,10 @@ @Override public LispObject execute(LispObject arg) { - return checkClass(arg).getName(); + if (arg instanceof LispClass) + return ((LispClass)arg).getName(); + + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName); } }; @@ -5331,21 +5334,30 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).setName(checkSymbol(second)); - return second; + if (second instanceof LispClass) + ((LispClass)second).setName(checkSymbol(first)); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symName, + checkSymbol(first)); + return first; } }; // ### class-layout - private static final Primitive CLASS_LAYOUT = new pf_class_layout(); - private static final class pf_class_layout extends Primitive { - pf_class_layout() { - super("class-layout", PACKAGE_SYS, true, "class"); + private static final Primitive CLASS_LAYOUT = new pf__class_layout(); + private static final class pf__class_layout extends Primitive { + pf__class_layout() { + super("%class-layout", PACKAGE_SYS, true, "class"); } @Override public LispObject execute(LispObject arg) { - Layout layout = checkClass(arg).getClassLayout(); + Layout layout; + if (arg instanceof LispClass) + layout = ((LispClass)arg).getClassLayout(); + else + layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout); + return layout != null ? layout : NIL; } }; @@ -5361,24 +5373,30 @@ public LispObject execute(LispObject first, LispObject second) { - if (second instanceof Layout) { - checkClass(first).setClassLayout((Layout)second); - return second; + if (first == NIL || first instanceof Layout) { + if (second instanceof LispClass) + ((LispClass)second).setClassLayout(first); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first); + return first; } - return type_error(second, Symbol.LAYOUT); + return type_error(first, Symbol.LAYOUT); } }; - // ### class-direct-superclasses - private static final Primitive CLASS_DIRECT_SUPERCLASSES = new pf_class_direct_superclasses(); - private static final class pf_class_direct_superclasses extends Primitive { - pf_class_direct_superclasses() { - super("class-direct-superclasses", PACKAGE_SYS, true); + // ### %class-direct-superclasses + private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses(); + private static final class pf__class_direct_superclasses extends Primitive { + pf__class_direct_superclasses() { + super("%class-direct-superclasses", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) { - return checkClass(arg).getDirectSuperclasses(); + if (arg instanceof LispClass) + return ((LispClass)arg).getDirectSuperclasses(); + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses); } }; @@ -5391,23 +5409,28 @@ @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setDirectSuperclasses(second); - return second; + if (second instanceof LispClass) + ((LispClass)second).setDirectSuperclasses(first); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first); + return first; } }; - // ### class-direct-subclasses - private static final Primitive CLASS_DIRECT_SUBCLASSES = new pf_class_direct_subclasses(); - private static final class pf_class_direct_subclasses extends Primitive { - pf_class_direct_subclasses() { - super("class-direct-subclasses", PACKAGE_SYS, true); + // ### %class-direct-subclasses + private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses(); + private static final class pf__class_direct_subclasses extends Primitive { + pf__class_direct_subclasses() { + super("%class-direct-subclasses", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) { - return checkClass(arg).getDirectSubclasses(); + if (arg instanceof LispClass) + return ((LispClass)arg).getDirectSubclasses(); + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses); } }; @@ -5421,10 +5444,12 @@ @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setDirectSubclasses(second); - return second; + if (second instanceof LispClass) + ((LispClass)second).setDirectSubclasses(first); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first); + return first; } }; @@ -5437,38 +5462,45 @@ @Override public LispObject execute(LispObject arg) { - return checkClass(arg).getCPL(); + if (arg instanceof LispClass) + return ((LispClass)arg).getCPL(); + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList); } }; - // ### set-class-precedence-list - private static final Primitive SET_CLASS_PRECEDENCE_LIST = new pf_set_class_precedence_list(); - private static final class pf_set_class_precedence_list extends Primitive { - pf_set_class_precedence_list() { - super("set-class-precedence-list", PACKAGE_SYS, true); + // ### %set-class-precedence-list + private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list(); + private static final class pf__set_class_precedence_list extends Primitive { + pf__set_class_precedence_list() { + super("%set-class-precedence-list", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setCPL(second); - return second; + if (second instanceof LispClass) + ((LispClass)second).setCPL(first); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first); + return first; } }; - // ### class-direct-methods - private static final Primitive CLASS_DIRECT_METHODS = new pf_class_direct_methods(); - private static final class pf_class_direct_methods extends Primitive { - pf_class_direct_methods() { - super("class-direct-methods", PACKAGE_SYS, true); + // ### %class-direct-methods + private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods(); + private static final class pf__class_direct_methods extends Primitive { + pf__class_direct_methods() { + super("%class-direct-methods", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) - { - return checkClass(arg).getDirectMethods(); + if (arg instanceof LispClass) + return ((LispClass)arg).getDirectMethods(); + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods); } }; @@ -5481,10 +5513,12 @@ @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setDirectMethods(second); - return second; + if (second instanceof LispClass) + ((LispClass)second).setDirectMethods(first); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first); + return first; } }; @@ -5500,7 +5534,10 @@ public LispObject execute(LispObject arg) { - return checkClass(arg).getDocumentation(); + if (arg instanceof LispClass) + return ((LispClass)arg).getDocumentation(); + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation); } }; @@ -5514,23 +5551,28 @@ @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setDocumentation(second); + if (first instanceof LispClass) + ((LispClass)first).setDocumentation(second); + else + ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second); return second; } }; - // ### class-finalized-p - private static final Primitive CLASS_FINALIZED_P = new pf_class_finalized_p(); - private static final class pf_class_finalized_p extends Primitive { - pf_class_finalized_p() { - super("class-finalized-p", PACKAGE_SYS, true); + // ### %class-finalized-p + private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p(); + private static final class pf__class_finalized_p extends Primitive { + pf__class_finalized_p() { + super("%class-finalized-p", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) { - return checkClass(arg).isFinalized() ? T : NIL; + if (arg instanceof LispClass) + return ((LispClass)arg).isFinalized() ? T : NIL; + else + return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP); } }; @@ -5543,10 +5585,12 @@ @Override public LispObject execute(LispObject first, LispObject second) - { - checkClass(first).setFinalized(second != NIL); - return second; + if (second instanceof LispClass) + ((LispClass)second).setFinalized(first != NIL); + else + ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first); + return first; } }; @@ -5559,7 +5603,7 @@ @Override public LispObject execute(LispObject arg) { - return arg instanceof LispClass ? T : NIL; + return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS); } }; Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sun Mar 28 16:13:14 2010 @@ -178,7 +178,7 @@ // ### class-direct-slots private static final Primitive CLASS_DIRECT_SLOTS = - new Primitive("class-direct-slots", PACKAGE_SYS, true) + new Primitive("%class-direct-slots", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject arg) @@ -200,12 +200,12 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).setDirectSlotDefinitions(second); - return second; + if (second instanceof SlotClass) { + ((SlotClass)second).setDirectSlotDefinitions(first); + return first; } else { - return type_error(first, Symbol.STANDARD_CLASS); + return type_error(second, Symbol.STANDARD_CLASS); } } }; @@ -227,26 +227,26 @@ }; // ### set-class-slots - private static final Primitive SET_CLASS_SLOTS = - new Primitive(Symbol.SET_CLASS_SLOTS, "class slot-definitions") + private static final Primitive _SET_CLASS_SLOTS = + new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions") { @Override public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).setSlotDefinitions(second); - return second; + if (second instanceof SlotClass) { + ((SlotClass)second).setSlotDefinitions(first); + return first; } else { - return type_error(first, Symbol.STANDARD_CLASS); + return type_error(second, Symbol.STANDARD_CLASS); } } }; // ### class-direct-default-initargs private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS = - new Primitive("class-direct-default-initargs", PACKAGE_SYS, true) + new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject arg) @@ -268,17 +268,17 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).setDirectDefaultInitargs(second); - return second; + if (second instanceof SlotClass) { + ((SlotClass)second).setDirectDefaultInitargs(first); + return first; } - return type_error(first, Symbol.STANDARD_CLASS); + return type_error(second, Symbol.STANDARD_CLASS); } }; // ### class-default-initargs private static final Primitive CLASS_DEFAULT_INITARGS = - new Primitive("class-default-initargs", PACKAGE_SYS, true) + new Primitive("%class-default-initargs", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject arg) @@ -300,30 +300,12 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).setDefaultInitargs(second); - return second; + if (second instanceof SlotClass) { + ((SlotClass)second).setDefaultInitargs(first); + return first; } - return type_error(first, Symbol.STANDARD_CLASS); + return type_error(second, Symbol.STANDARD_CLASS); } }; - // ### compute-class-default-initargs - private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS = - new Primitive("compute-class-default-initargs", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject arg) - - { - final SlotClass c; - if (arg instanceof SlotClass) { - c = (SlotClass) arg; - } - else { - return type_error(arg, Symbol.STANDARD_CLASS); - } - return c.computeDefaultInitargs(); - } - }; } Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sun Mar 28 16:13:14 2010 @@ -69,7 +69,21 @@ slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers; slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; } - + + public SlotDefinition(LispObject name, LispObject readers, + Function initFunction) + { + this(); + Debug.assertTrue(name instanceof Symbol); + slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; + slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = initFunction; + slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = + new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName())); + slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers; + slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; + } + public static SlotDefinition checkSlotDefinition(LispObject obj) { if (obj instanceof SlotDefinition) return (SlotDefinition)obj; return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION); @@ -147,7 +161,7 @@ }; // ### set-slot-definition-initfunction - private static final Primitive SET_SLOT_DEFINITION_INITFUNCTION = + static final Primitive SET_SLOT_DEFINITION_INITFUNCTION = new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true, "slot-definition initfunction") { @@ -173,7 +187,7 @@ }; // ### set-slot-definition-initform - private static final Primitive SET_SLOT_DEFINITION_INITFORM = + static final Primitive SET_SLOT_DEFINITION_INITFORM = new Primitive("set-slot-definition-initform", PACKAGE_SYS, true, "slot-definition initform") { Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Mar 28 16:13:14 2010 @@ -38,26 +38,28 @@ public class StandardClass extends SlotClass { - private static Symbol symName = PACKAGE_MOP.intern("NAME"); - private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT"); - private static Symbol symDirectSuperclasses + public static Symbol symName = PACKAGE_MOP.intern("NAME"); + public static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT"); + public static Symbol symDirectSuperclasses = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"); - private static Symbol symDirectSubclasses + public static Symbol symDirectSubclasses = PACKAGE_MOP.intern("DIRECT-SUBCLASSES"); - private static Symbol symClassPrecedenceList - = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"); - private static Symbol symDirectMethods + public static Symbol symPrecedenceList + = PACKAGE_MOP.intern("PRECEDENCE-LIST"); + public static Symbol symDirectMethods = PACKAGE_MOP.intern("DIRECT-METHODS"); - private static Symbol symDocumentation + public static Symbol symDocumentation = PACKAGE_MOP.intern("DOCUMENTATION"); - private static Symbol symDirectSlots + public static Symbol symDirectSlots = PACKAGE_MOP.intern("DIRECT-SLOTS"); - private static Symbol symSlots + public static Symbol symSlots = PACKAGE_MOP.intern("SLOTS"); - private static Symbol symDirectDefaultInitargs + public static Symbol symDirectDefaultInitargs = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"); - private static Symbol symDefaultInitargs + public static Symbol symDefaultInitargs = PACKAGE_MOP.intern("DEFAULT-INITARGS"); + public static Symbol symFinalizedP + = PACKAGE_MOP.intern("FINALIZED-P"); static Layout layoutStandardClass = new Layout(null, @@ -65,13 +67,14 @@ symLayout, symDirectSuperclasses, symDirectSubclasses, - symClassPrecedenceList, + symPrecedenceList, symDirectMethods, symDocumentation, symDirectSlots, symSlots, symDirectDefaultInitargs, - symDefaultInitargs), + symDefaultInitargs, + symFinalizedP), NIL) { @Override @@ -86,6 +89,7 @@ super(layoutStandardClass); setDirectSuperclasses(NIL); setDirectSubclasses(NIL); + setClassLayout(layoutStandardClass); setCPL(NIL); setDirectMethods(NIL); setDocumentation(NIL); @@ -93,6 +97,7 @@ setSlotDefinitions(NIL); setDirectDefaultInitargs(NIL); setDefaultInitargs(NIL); + setFinalized(false); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -100,6 +105,7 @@ super(layoutStandardClass, symbol, directSuperclasses); setDirectSubclasses(NIL); + setClassLayout(layoutStandardClass); setCPL(NIL); setDirectMethods(NIL); setDocumentation(NIL); @@ -107,6 +113,7 @@ setSlotDefinitions(NIL); setDirectDefaultInitargs(NIL); setDefaultInitargs(NIL); + setFinalized(false); } @Override @@ -129,7 +136,7 @@ } @Override - public void setClassLayout(Layout newLayout) + public void setClassLayout(LispObject newLayout) { setInstanceSlotValue(symLayout, newLayout); } @@ -147,6 +154,18 @@ } @Override + public final boolean isFinalized() + { + return getInstanceSlotValue(symFinalizedP) != NIL; + } + + @Override + public final void setFinalized(boolean b) + { + setInstanceSlotValue(symFinalizedP, b ? T : NIL); + } + + @Override public LispObject getDirectSubclasses() { return getInstanceSlotValue(symDirectSubclasses); @@ -161,7 +180,7 @@ @Override public LispObject getCPL() { - return getInstanceSlotValue(symClassPrecedenceList); + return getInstanceSlotValue(symPrecedenceList); } @Override @@ -169,14 +188,14 @@ { LispObject obj1 = cpl[0]; if (obj1.listp() && cpl.length == 1) - setInstanceSlotValue(symClassPrecedenceList, obj1); + setInstanceSlotValue(symPrecedenceList, obj1); else { Debug.assertTrue(obj1 == this); LispObject l = NIL; for (int i = cpl.length; i-- > 0;) l = new Cons(cpl[i], l); - setInstanceSlotValue(symClassPrecedenceList, l); + setInstanceSlotValue(symPrecedenceList, l); } } @@ -252,7 +271,11 @@ setInstanceSlotValue(symDefaultInitargs, defaultInitargs); } - + @Override + public LispObject typeOf() + { + return Symbol.STANDARD_CLASS; + } @Override public LispObject classOf() @@ -297,6 +320,42 @@ return unreadableString(sb.toString()); } + private static final LispObject standardClassSlotDefinitions() + { + // (CONSTANTLY NIL) + Function initFunction = new Function() { + @Override + public LispObject execute() + { + return NIL; + } + }; + + return + list(helperMakeSlotDefinition("NAME", initFunction), + helperMakeSlotDefinition("LAYOUT", initFunction), + helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction), + helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction), + helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction), + helperMakeSlotDefinition("DIRECT-METHODS", initFunction), + helperMakeSlotDefinition("DIRECT-SLOTS", initFunction), + helperMakeSlotDefinition("SLOTS", initFunction), + helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction), + helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction), + helperMakeSlotDefinition("FINALIZED-P", initFunction)); + } + + + + private static final SlotDefinition helperMakeSlotDefinition(String name, + Function init) + { + return + new SlotDefinition(PACKAGE_MOP.intern(name), // name + list(PACKAGE_MOP.intern("CLASS-" + name)), // readers + init); + } + private static final StandardClass addStandardClass(Symbol name, LispObject directSuperclasses) { @@ -321,7 +380,7 @@ addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); STANDARD_CLASS.setClassLayout(layoutStandardClass); - STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions()); + STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); } // BuiltInClass.FUNCTION is also null here (see previous comment). @@ -616,6 +675,7 @@ WARNING.setCPL(WARNING, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); // Condition classes. + STANDARD_CLASS.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); COMPILER_ERROR.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Mar 28 16:13:14 2010 @@ -209,7 +209,14 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getName().writeToString()); + LispObject className; + LispObject lispClass = getLispClass(); + if (lispClass instanceof LispClass) + className = ((LispClass)lispClass).getName(); + else + className = Symbol.CLASS_NAME.execute(lispClass); + + sb.append(className.writeToString()); sb.append(' '); sb.append(name.writeToString()); return unreadableString(sb.toString()); Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Mar 28 16:13:14 2010 @@ -156,7 +156,14 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getName().writeToString()); + LispObject className; + LispObject lispClass = getLispClass(); + if (lispClass instanceof LispClass) + className = ((LispClass)lispClass).getName(); + else + className = Symbol.CLASS_NAME.execute(lispClass); + + sb.append(className.writeToString()); sb.append(' '); sb.append(name.writeToString()); LispObject specializers = Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Mar 28 16:13:14 2010 @@ -46,6 +46,11 @@ } + protected StandardObject(Layout layout) + { + this(layout, layout.getLength()); + } + protected StandardObject(Layout layout, int length) { this.layout = layout; @@ -98,11 +103,29 @@ return parts.nreverse(); } - public final LispClass getLispClass() + public final LispObject getLispClass() { return layout.getLispClass(); } + private LispObject helperGetClassName() + { + final LispObject c1 = layout.getLispClass(); + if (c1 instanceof LispClass) + return ((LispClass)c1).getName(); + else + return LispThread.currentThread().execute(Symbol.CLASS_NAME, c1); + } + + private LispObject helperGetCPL() + { + final LispObject c1 = layout.getLispClass(); + if (c1 instanceof LispClass) + return ((LispClass)c1).getCPL(); + else + return LispThread.currentThread().execute(Symbol.CLASS_PRECEDENCE_LIST, c1); + } + @Override public LispObject typeOf() { @@ -110,14 +133,19 @@ // conditions, TYPE-OF returns the proper name of the class returned by // CLASS-OF if it has a proper name, and otherwise returns the class // itself." - final LispClass c1 = layout.getLispClass(); + final LispObject c1 = layout.getLispClass(); + LispObject name; + if (c1 instanceof LispClass) + name = ((LispClass)c1).getName(); + else + name = LispThread.currentThread().execute(Symbol.CLASS_NAME, c1); + // The proper name of a class is "a symbol that names the class whose // name is that symbol". - final LispObject name = c1.getName(); if (name != NIL && name != UNBOUND_VALUE) { // TYPE-OF.9 - final LispObject c2 = LispClass.findClass(checkSymbol(name)); + final LispObject c2 = LispClass.findClass(name, false); if (c2 == c1) return name; } @@ -137,20 +165,30 @@ return T; if (type == StandardClass.STANDARD_OBJECT) return T; - LispClass cls = layout != null ? layout.getLispClass() : null; + LispObject cls = layout != null ? layout.getLispClass() : null; if (cls != null) { if (type == cls) return T; - if (type == cls.getName()) + if (type == helperGetClassName()) return T; - LispObject cpl = cls.getCPL(); + LispObject cpl = helperGetCPL(); while (cpl != NIL) { if (type == cpl.car()) return T; - if (type == ((LispClass)cpl.car()).getName()) - return T; + + LispObject otherName; + LispObject otherClass = cpl.car(); + if (otherClass instanceof LispClass) { + if (type == ((LispClass)otherClass).getName()) + return T; + } + else + if (type == LispThread + .currentThread().execute(Symbol.CLASS_NAME, otherClass)) + return T; + cpl = cpl.cdr(); } } @@ -183,10 +221,16 @@ { Debug.assertTrue(layout.isInvalid()); Layout oldLayout = layout; - LispClass cls = oldLayout.getLispClass(); - Layout newLayout = cls.getClassLayout(); + LispObject cls = oldLayout.getLispClass(); + Layout newLayout; + + if (cls instanceof LispClass) + newLayout = ((LispClass)cls).getClassLayout(); + else + newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls); + Debug.assertTrue(!newLayout.isInvalid()); - StandardObject newInstance = new StandardObject(cls); + StandardObject newInstance = new StandardObject(newLayout); Debug.assertTrue(newInstance.layout == newLayout); LispObject added = NIL; LispObject discarded = NIL; Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sun Mar 28 16:13:14 2010 @@ -47,7 +47,11 @@ if (arg == StandardClass.STANDARD_CLASS) return new StandardClass(); if (arg instanceof StandardClass) - return ((StandardClass)arg).allocateInstance(); + return ((StandardClass)arg).allocateInstance(); + if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { + Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg); + return new StandardObject(layout); + } return type_error(arg, Symbol.STANDARD_CLASS); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Mar 28 16:13:14 2010 @@ -390,8 +390,15 @@ return function; } - public final LispObject getSymbolSetfFunctionOrDie() + @Override + public final LispObject getSymbolSetfFunction() + { + return get(this, Symbol.SETF_FUNCTION, NIL); + } + + @Override + public final LispObject getSymbolSetfFunctionOrDie() { LispObject obj = get(this, Symbol.SETF_FUNCTION, null); if (obj == null) @@ -2921,6 +2928,10 @@ PACKAGE_EXT.addExternalSymbol("SLIME-OUTPUT-STREAM"); // MOP. + public static final Symbol CLASS_LAYOUT = + PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT"); + public static final Symbol CLASS_PRECEDENCE_LIST = + PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); @@ -2965,8 +2976,8 @@ PACKAGE_SYS.addExternalSymbol("NAMED-LAMBDA"); public static final Symbol OUTPUT_OBJECT = PACKAGE_SYS.addExternalSymbol("OUTPUT-OBJECT"); - public static final Symbol SET_CLASS_SLOTS = - PACKAGE_SYS.addExternalSymbol("SET-CLASS-SLOTS"); + public static final Symbol _SET_CLASS_SLOTS = + PACKAGE_SYS.addExternalSymbol("%SET-CLASS-SLOTS"); public static final Symbol SETF_FUNCTION = PACKAGE_SYS.addExternalSymbol("SETF-FUNCTION"); public static final Symbol SETF_INVERSE = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 28 16:13:14 2010 @@ -53,8 +53,52 @@ (export '(class-precedence-list class-slots)) -(defun class-slots (class) - (%class-slots class)) +;; Don't use DEFVAR, because that disallows loading clos.lisp +;; after compiling it: the binding won't get assigned to T anymore +(defparameter *clos-booting* t) + +(defmacro define-class->%class-forwarder (name) + (let* (($name (if (consp name) (cadr name) name)) + (%name (intern (concatenate 'string + "%" + (if (consp name) + (symbol-name 'set-) "") + (symbol-name $name)) + (symbol-package $name)))) + `(progn + (declaim (notinline ,name)) + (defun ,name (&rest args) + (apply #',%name args))))) + +(define-class->%class-forwarder class-name) +(define-class->%class-forwarder (setf class-name)) +(define-class->%class-forwarder class-slots) +(define-class->%class-forwarder (setf class-slots)) +(define-class->%class-forwarder class-direct-slots) +(define-class->%class-forwarder (setf class-direct-slots)) +(define-class->%class-forwarder class-layout) +(define-class->%class-forwarder (setf class-layout)) +(define-class->%class-forwarder class-direct-superclasses) +(define-class->%class-forwarder (setf class-direct-superclasses)) +(define-class->%class-forwarder class-direct-subclasses) +(define-class->%class-forwarder (setf class-direct-subclasses)) +(define-class->%class-forwarder class-direct-methods) +(define-class->%class-forwarder (setf class-direct-methods)) +(define-class->%class-forwarder class-precedence-list) +(define-class->%class-forwarder (setf class-precedence-list)) +(define-class->%class-forwarder class-finalized-p) +(define-class->%class-forwarder (setf class-finalized-p)) +(define-class->%class-forwarder class-default-initargs) +(define-class->%class-forwarder (setf class-default-initargs)) +(define-class->%class-forwarder class-direct-default-initargs) +(define-class->%class-forwarder (setf class-direct-default-initargs)) + +(defun no-applicable-method (generic-function &rest args) + (error "There is no applicable method for the generic function ~S when called with arguments ~S." + generic-function + args)) + + (defmacro push-on-end (value location) `(setf ,location (nconc ,location (list ,value)))) @@ -85,15 +129,6 @@ (cons (funcall fun (car x) (cadr x)) (mapplist fun (cddr x))))) -(defsetf class-layout %set-class-layout) -(defsetf class-direct-superclasses %set-class-direct-superclasses) -(defsetf class-direct-subclasses %set-class-direct-subclasses) -(defsetf class-direct-methods %set-class-direct-methods) -(defsetf class-direct-slots %set-class-direct-slots) -;; (defsetf class-slots %set-class-slots) -(defsetf class-direct-default-initargs %set-class-direct-default-initargs) -(defsetf class-default-initargs %set-class-default-initargs) -(defsetf class-finalized-p %set-class-finalized-p) (defsetf std-instance-layout %set-std-instance-layout) (defsetf standard-instance-access %set-standard-instance-access) @@ -253,26 +288,30 @@ ;;; finalize-inheritance +(defun std-compute-class-default-initargs (class) + (mapcan #'(lambda (c) + (copy-list + (class-direct-default-initargs c))) + (class-precedence-list class))) + (defun std-finalize-inheritance (class) - (set-class-precedence-list - class + (setf (class-precedence-list class) (funcall (if (eq (class-of class) (find-class 'standard-class)) #'std-compute-class-precedence-list #'compute-class-precedence-list) class)) - (dolist (class (%class-precedence-list class)) + (dolist (class (class-precedence-list class)) (when (typep class 'forward-referenced-class) (return-from std-finalize-inheritance))) - (set-class-slots class + (setf (class-slots class) (funcall (if (eq (class-of class) (find-class 'standard-class)) #'std-compute-slots - #'compute-slots) - class)) + #'compute-slots) class)) (let ((old-layout (class-layout class)) (length 0) (instance-slots '()) (shared-slots '())) - (dolist (slot (%class-slots class)) + (dolist (slot (class-slots class)) (case (%slot-definition-allocation slot) (:instance (set-slot-definition-location slot length) @@ -292,13 +331,14 @@ (let* ((slot-name (car location)) (old-location (layout-slot-location old-layout slot-name))) (unless old-location - (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name)) + (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name)) (initfunction (%slot-definition-initfunction slot-definition))) (when initfunction (setf (cdr location) (funcall initfunction)))))))) (setf (class-layout class) (make-layout class (nreverse instance-slots) (nreverse shared-slots)))) - (setf (class-default-initargs class) (compute-class-default-initargs class)) + (setf (class-default-initargs class) + (std-compute-class-default-initargs class)) (setf (class-finalized-p class) t)) ;;; Class precedence lists @@ -392,7 +432,7 @@ (defun std-compute-slots (class) (let* ((all-slots (mapappend #'class-direct-slots - (%class-precedence-list class))) + (class-precedence-list class))) (all-names (remove-duplicates (mapcar #'%slot-definition-name all-slots)))) (mapcar #'(lambda (name) @@ -431,7 +471,7 @@ ;;; references. (defun find-slot-definition (class slot-name) - (dolist (slot (%class-slots class) nil) + (dolist (slot (class-slots class) nil) (when (eq slot-name (%slot-definition-name slot)) (return slot)))) @@ -481,7 +521,7 @@ (slot-makunbound-using-class (class-of object) object slot-name))) (defun std-slot-exists-p (instance slot-name) - (not (null (find slot-name (%class-slots (class-of instance)) + (not (null (find slot-name (class-slots (class-of instance)) :key #'%slot-definition-name)))) (defun slot-exists-p (object slot-name) @@ -499,9 +539,10 @@ &allow-other-keys) (declare (ignore metaclass)) (let ((class (std-allocate-instance (find-class 'standard-class)))) - (%set-class-name class name) - (setf (class-direct-subclasses class) ()) - (setf (class-direct-methods class) ()) + (%set-class-name name class) + (%set-class-layout nil class) + (%set-class-direct-subclasses () class) + (%set-class-direct-methods () class) (%set-class-documentation class documentation) (std-after-initialization-for-classes class :direct-superclasses direct-superclasses @@ -537,8 +578,9 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defun ensure-class (name &rest all-keys &allow-other-keys) +(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. + (remf all-keys :metaclass) (let ((slots (getf all-keys :direct-slots))) (dolist (s1 slots) (let ((name1 (canonical-slot-name s1))) @@ -563,7 +605,7 @@ (when (typep class 'built-in-class) (error "Attempt to define a subclass of a built-in-class: ~S" class)))) (let ((old-class (find-class name nil))) - (cond ((and old-class (eq name (%class-name old-class))) + (cond ((and old-class (eq name (class-name old-class))) (cond ((typep old-class 'built-in-class) (error "The symbol ~S names a built-in class." name)) ((typep old-class 'forward-referenced-class) @@ -582,8 +624,11 @@ (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t - (let ((class (apply #'make-instance-standard-class - (find-class 'standard-class) + (let ((class (apply (if metaclass + #'make-instance + #'make-instance-standard-class) + (or metaclass + (find-class 'standard-class)) :name name all-keys))) (%set-find-class name class) class))))) @@ -831,7 +876,8 @@ (finalize-generic-function gf)) gf) (progn - (when (fboundp function-name) + (when (and (null *clos-booting*) + (fboundp function-name)) (error 'program-error :format-control "~A already names an ordinary function, macro, or special operator." :format-arguments (list function-name))) @@ -1780,26 +1826,68 @@ (autocompile fast-function)) ))) -(fmakunbound 'class-name) -(fmakunbound '(setf class-name)) - -(defgeneric class-name (class)) - -(defmethod class-name ((class class)) - (%class-name class)) - -(defgeneric (setf class-name) (new-value class)) - -(defmethod (setf class-name) (new-value (class class)) - (%set-class-name class new-value)) - -(when (autoloadp 'class-precedence-list) - (fmakunbound 'class-precedence-list)) - -(defgeneric class-precedence-list (class)) - -(defmethod class-precedence-list ((class class)) - (%class-precedence-list class)) +(defmacro redefine-class-forwarder (name slot &optional alternative-name) + (let* (($name (if (consp name) (cadr name) name)) + (%name (intern (concatenate 'string + "%" + (if (consp name) + (symbol-name 'set-) "") + (symbol-name $name)) + (find-package "SYS")))) + (unless alternative-name + (setf alternative-name name)) + (if (consp name) + `(progn ;; setter + (defgeneric ,alternative-name (new-value class)) + (defmethod ,alternative-name (new-value (class built-in-class)) + (,%name new-value class)) + (defmethod ,alternative-name (new-value (class forward-referenced-class)) + (,%name new-value class)) + (defmethod ,alternative-name (new-value (class structure-class)) + (,%name new-value class)) + (defmethod ,alternative-name (new-value (class standard-class)) + (setf (slot-value class ',slot) new-value)) + ,@(unless (eq name alternative-name) + `((setf (get ',$name 'SETF-FUNCTION) + (symbol-function ',alternative-name)))) + ) + `(progn ;; getter + (defgeneric ,alternative-name (class)) + (defmethod ,alternative-name ((class built-in-class)) + (,%name class)) + (defmethod ,alternative-name ((class forward-referenced-class)) + (,%name class)) + (defmethod ,alternative-name ((class structure-class)) + (,%name class)) + (defmethod ,alternative-name ((class standard-class)) + (slot-value class ',slot)) + ,@(unless (eq name alternative-name) + `((setf (symbol-function ',$name) + (symbol-function ',alternative-name)))) + ) ))) + +(redefine-class-forwarder class-name name) +(redefine-class-forwarder (setf class-name) name) +(redefine-class-forwarder class-slots slots) +(redefine-class-forwarder (setf class-slots) slots) +(redefine-class-forwarder class-direct-slots direct-slots) +(redefine-class-forwarder (setf class-direct-slots) direct-slots) +(redefine-class-forwarder class-layout layout) +(redefine-class-forwarder (setf class-layout) layout) +(redefine-class-forwarder class-direct-superclasses direct-superclasses) +(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses) +(redefine-class-forwarder class-direct-subclasses direct-subclasses) +(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses) +(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods) +(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods) +(redefine-class-forwarder class-precedence-list precedence-list) +(redefine-class-forwarder (setf class-precedence-list) precedence-list) +(redefine-class-forwarder class-finalized-p finalized-p) +(redefine-class-forwarder (setf class-finalized-p) finalized-p) +(redefine-class-forwarder class-default-initargs default-initargs) +(redefine-class-forwarder (setf class-default-initargs) default-initargs) +(redefine-class-forwarder class-direct-default-initargs direct-default-initargs) +(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) @@ -1950,7 +2038,7 @@ (std-slot-exists-p instance slot-name)) (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) - (dolist (dsd (%class-slots class)) + (dolist (dsd (class-slots class)) (when (eq (sys::dsd-name dsd) slot-name) (return-from slot-exists-p-using-class t))) nil) @@ -1986,8 +2074,8 @@ (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) - (%make-structure (%class-name class) - (make-list (length (%class-slots class)) + (%make-structure (class-name class) + (make-list (length (class-slots class)) :initial-element +slot-unbound+))) ;; "The set of valid initialization arguments for a class is the set of valid @@ -2012,7 +2100,7 @@ (if initargs `(,instance , at initargs) (list instance))))) - (slots (%class-slots (class-of instance)))) + (slots (class-slots (class-of instance)))) (do* ((tail initargs (cddr tail)) (initarg (car tail) (car tail))) ((null tail)) @@ -2095,7 +2183,7 @@ (error 'program-error :format-control "Invalid initarg ~S." :format-arguments (list initarg)))) - (dolist (slot (%class-slots (class-of instance))) + (dolist (slot (class-slots (class-of instance))) (let ((slot-name (%slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp) (get-properties all-keys (%slot-definition-initargs slot)) @@ -2120,8 +2208,8 @@ (defmethod change-class ((old-instance standard-object) (new-class standard-class) &rest initargs) - (let ((old-slots (%class-slots (class-of old-instance))) - (new-slots (%class-slots new-class)) + (let ((old-slots (class-slots (class-of old-instance))) + (new-slots (class-slots new-class)) (new-instance (allocate-instance new-class))) ;; "The values of local slots specified by both the class CTO and the class ;; CFROM are retained. If such a local slot was unbound, it remains @@ -2153,7 +2241,7 @@ (remove-if #'(lambda (slot-name) (slot-exists-p old slot-name)) (mapcar #'%slot-definition-name - (%class-slots (class-of new)))))) + (class-slots (class-of new)))))) (check-initargs new added-slots initargs) (apply #'shared-initialize new added-slots initargs))) @@ -2340,7 +2428,7 @@ (defmethod make-load-form ((class class) &optional environment) (declare (ignore environment)) - (let ((name (%class-name class))) + (let ((name (class-name class))) (unless (and name (eq (find-class name nil) class)) (error 'simple-type-error :format-control "Can't use anonymous or undefined class as a constant: ~S." @@ -2355,6 +2443,7 @@ (let ((message (apply #'format nil format-control args))) (error "Method combination error in CLOS dispatch:~% ~A" message))) +(fmakunbound 'no-applicable-method) (defgeneric no-applicable-method (generic-function &rest args)) (defmethod no-applicable-method (generic-function &rest args) @@ -2393,6 +2482,8 @@ ;; FIXME (defgeneric function-keywords (method)) +(setf *clos-booting* nil) + (defgeneric class-prototype (class)) (defmethod class-prototype :before (class) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 28 16:13:14 2010 @@ -3402,7 +3402,6 @@ (BIT-VECTOR-P p2-test-bit-vector-p) (CHAR= p2-test-char=) (CHARACTERP p2-test-characterp) - (CLASSP p2-test-classp) (CONSP p2-test-consp) (CONSTANTP p2-test-constantp) (ENDP p2-test-endp) @@ -3543,9 +3542,6 @@ (defun p2-test-special-variable-p (form) (p2-test-predicate form "isSpecialVariable")) -(defun p2-test-classp (form) - (p2-test-instanceof-predicate form +lisp-class-class+)) - (defun p2-test-symbolp (form) (p2-test-instanceof-predicate form +lisp-symbol-class+)) @@ -4827,9 +4823,6 @@ (defun p2-characterp (form target representation) (p2-instanceof-predicate form target representation +lisp-character-class+)) -(defun p2-classp (form target representation) - (p2-instanceof-predicate form target representation +lisp-class-class+)) - (defun p2-consp (form target representation) (p2-instanceof-predicate form target representation +lisp-cons-class+)) @@ -8874,7 +8867,6 @@ (install-p2-handler 'java:jmethod 'p2-java-jmethod) (install-p2-handler 'char= 'p2-char=) (install-p2-handler 'characterp 'p2-characterp) - (install-p2-handler 'classp 'p2-classp) (install-p2-handler 'coerce-to-function 'p2-coerce-to-function) (install-p2-handler 'cons 'p2-cons) (install-p2-handler 'sys::backq-cons 'p2-cons) From ehuelsmann at common-lisp.net Sun Mar 28 20:20:10 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Mar 2010 16:20:10 -0400 Subject: [armedbear-cvs] r12577 - branches/metaclass Message-ID: Author: ehuelsmann Date: Sun Mar 28 16:20:09 2010 New Revision: 12577 Log: Re #38: Delete merged metaclass branch. Removed: branches/metaclass/ From astalla at common-lisp.net Sun Mar 28 21:41:28 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 28 Mar 2010 17:41:28 -0400 Subject: [armedbear-cvs] r12578 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Mar 28 17:41:27 2010 New Revision: 12578 Log: Selected built-in classes can now be subclassed. Only SEQUENCE is allowed as of this revision. This makes sequences user-extensible again. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 28 17:41:27 2010 @@ -578,6 +578,8 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) +(defvar *extensible-built-in-classes* (list (find-class 'sequence))) + (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. (remf all-keys :metaclass) @@ -602,7 +604,8 @@ :format-arguments (list name))))) (let ((direct-superclasses (getf all-keys :direct-superclasses))) (dolist (class direct-superclasses) - (when (typep class 'built-in-class) + (when (and (typep class 'built-in-class) + (not (member class *extensible-built-in-classes*))) (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))) From mevenson at common-lisp.net Tue Mar 30 15:14:36 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 30 Mar 2010 11:14:36 -0400 Subject: [armedbear-cvs] r12579 - public_html Message-ID: Author: mevenson Date: Tue Mar 30 11:14:34 2010 New Revision: 12579 Log: Added links to binary downloads; refactored CSS somewhat. Corrected release notes link in left menu to point to the current release. Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue Mar 30 11:14:34 2010 @@ -8,9 +8,25 @@ @@ -22,68 +38,109 @@

- +

+ - - + + + + + - + + + + - + + + +

Project description

ABCL is a full implementation of the Common Lisp language - featuring both an interpreter and a compiler, running in the JVM. Originally - started to be a scripting language for the J editor, it now supports JSR-233 - (Java scripting API): it can be a scripting engine in any Java application. - Additionally, it can be used to implement (parts of) the application - using Java to Lisp integration APIs. + +

+ ABCL is a full implementation of the Common Lisp + language featuring both an interpreter and a compiler, + running in the JVM. Originally started to be a scripting + language for the J editor, it now supports JSR-233 (Java + scripting API): it can be a scripting engine in any Java + application. Additionally, it can be used to implement (parts of) + the application using Java to Lisp integration APIs. +

-Download 0.19.1 (zip)

Downloads

+ + + + + + + + + + + + + +

Binary	+ abcl-bin-0.19.1.tar.gz + (pgp) +	+ abcl-bin-0.19.1.zip + (pgp) +
Source	+ abcl-src-0.19.1.tar.gz + (pgp) +	+ abcl-src-0.19.1.zip + (pgp) +

Users +

Users (development with ABCL)

Developers (development of ABCL)

FAQ
Introduction: building - & running
Introduction: building & running
Documentation
Examples
Examples
Testimonials
Bug reporting

Mailing list and Mailing list and the old mailing list (abandoned)
Mailing list access on gmane
Repository
Technical wiki
Bug tracker
Contributing
Mailing list access on gmane
Repository
Technical wiki
Bug tracker
Contributing

Licensing

+ +

ABCL is covered by the -GNU General Public License with -Classpath exception, meaning that you can -use ABCL in your application without the requirement to open the -sources to your application. +GNU General Public License with Classpath exception, +meaning that you can use ABCL in your application without the +requirement to open the sources to your application. +

System requirements (Users)

System requirements (Developers)

@@ -94,17 +151,20 @@ FreeBSD or Google App Engine

JDK 1.5.0 (any patch level), or
JDK 1.6.0 (patch level 10 or higher)
Ant version 1.7.1 or higher, or
A Lisp to run the lisp-based build system

JDK 1.5.0 (any patch level), or
JDK 1.6.0 (patch level 10 or higher)
Ant version 1.7.1 or higher, or
A Lisp to run the lisp-based build system

Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Tue Mar 30 11:14:34 2010 @@ -1,7 +1,7 @@

Project page
Testimonials
-Release notes
+Release notes
Paid support

ABCL - Release notes for version 0.19

Most notable changes in ABCL 0.19