[armedbear-cvs] r12834 - in branches/generic-class-file/abcl: . src/org/armedbear/lisp test/lisp/ansi
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu Jul 29 19:38:26 UTC 2010
Author: ehuelsmann
Date: Thu Jul 29 15:38:25 2010
New Revision: 12834
Log:
Backport r12805-12833 from trunk.
Added:
branches/generic-class-file/abcl/src/org/armedbear/lisp/DocString.java
- copied unchanged from r12833, /trunk/abcl/src/org/armedbear/lisp/DocString.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/java-collections.lisp
- copied unchanged from r12833, /trunk/abcl/src/org/armedbear/lisp/java-collections.lisp
Modified:
branches/generic-class-file/abcl/CHANGES
branches/generic-class-file/abcl/build.xml
branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp
branches/generic-class-file/abcl/test/lisp/ansi/package.lisp
branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp
Modified: branches/generic-class-file/abcl/CHANGES
==============================================================================
--- branches/generic-class-file/abcl/CHANGES (original)
+++ branches/generic-class-file/abcl/CHANGES Thu Jul 29 15:38:25 2010
@@ -1,7 +1,46 @@
+Version 0.21
+============
+svn://common-lisp.net/project/armedbear/svn/tags/0.21.0/abcl
+(???, 2010)
+
+
+Features
+--------
+
+* [svn r12818] Update to ASDF 2.004
+
+* [svn r12738-805] Support for custom CLOS slot definitions and custom class options.
+
+* [svn r12756] slot-* functions work on structures too.
+
+* [svn r12774] Improved Java integration: jmake-proxy can implement more than one interface.
+
+* [svn r12773] Improved Java integration: functions to dynamically manipulate the classpath.
+
+* [svn r12755] Improved Java integration: CL:STRING can convert Java strings to Lisp strings.
+
+Fixes
+-----
+
+* [svn 12809-10-20] Various printing fixes.
+
+* [svn 12804] Fixed elimination of unused local functions shadowed by macrolet.
+
+* [svn r12798-803] Fixed pathname serialization across OSes. On Windows pathnames are always printed with forward slashes, but can still be read with backslashes.
+
+* [svn r12740] Make JSR-223 classes compilable with Java 1.5
+
+Other
+-----
+
+* [svn r12754] Changed class file generation and FASL loading to minimize reflection.
+
+* [svn r12734] A minimal Swing GUI Console with a REPL is now included with ABCL.
+
Version 0.20
============
-yet-to-be-tagged
-(???)
+svn://common-lisp.net/project/armedbear/svn/tags/0.20.0/abcl
+(24 May, 2010)
Features
Modified: branches/generic-class-file/abcl/build.xml
==============================================================================
--- branches/generic-class-file/abcl/build.xml (original)
+++ branches/generic-class-file/abcl/build.xml Thu Jul 29 15:38:25 2010
@@ -445,8 +445,11 @@
</target>
<target name="TAGS">
- <apply executable="etags" parallel="true" verbose="true">
+ <delete file="TAGS"/>
+ <apply executable="etags" parallel="true" verbose="true" maxparallel="300">
+ <arg value="--append"/>
<arg value="--regex=|[ \t]+//[ \t]+###[ \t]+\([^ \t]+\)|\1|"/>
+ <arg value='--regex=|[ \t]*@DocString([ \t]*name=\"\([^\"]*\)|\1|'/>
<fileset dir="${src.dir}">
<patternset refid="abcl.source.java"/>
<patternset refid="abcl.source.lisp"/>
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java Thu Jul 29 15:38:25 2010
@@ -104,7 +104,7 @@
public final LispObject getFormatControl()
{
- return getInstanceSlotValue(Symbol.FORMAT_CONTROL);
+ return getInstanceSlotValue(Symbol.FORMAT_CONTROL);
}
public final void setFormatControl(LispObject formatControl)
@@ -135,7 +135,8 @@
*/
public String getMessage()
{
- return getFormatControl().toString();
+ LispObject formatControl = getFormatControl();
+ return formatControl != UNBOUND_VALUE ? formatControl.writeToString() : null;
}
@Override
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Thu Jul 29 15:38:25 2010
@@ -76,7 +76,7 @@
return unreadableString(sb.toString());
}
- // ### make-forward-referenced-class
+ @DocString(name="make-forward-referenced=class")
private static final Primitive MAKE_FORWARD_REFERENCED_CLASS =
new Primitive("make-forward-referenced-class", PACKAGE_SYS, true)
{
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java Thu Jul 29 15:38:25 2010
@@ -53,7 +53,14 @@
public Function(String name)
{
+ this(name, (String)null);
+ }
+
+ public Function(String name, String arglist)
+ {
this();
+ if(arglist != null)
+ setLambdaList(new SimpleString(arglist));
if (name != null) {
Symbol symbol = Symbol.addFunction(name.toUpperCase(), this);
if (cold)
@@ -62,14 +69,14 @@
}
}
+ public Function(Symbol symbol)
+ {
+ this(symbol, null, null);
+ }
+
public Function(Symbol symbol, String arglist)
{
- this();
- symbol.setSymbolFunction(this);
- if (cold)
- symbol.setBuiltInFunction(true);
- setLambdaName(symbol);
- setLambdaList(new SimpleString(arglist));
+ this(symbol, arglist, null);
}
public Function(Symbol symbol, String arglist, String docstring)
@@ -79,17 +86,11 @@
if (cold)
symbol.setBuiltInFunction(true);
setLambdaName(symbol);
- setLambdaList(new SimpleString(arglist));
- if (docstring != null) {
+ if(arglist != null)
+ setLambdaList(new SimpleString(arglist));
+ if (docstring != null)
symbol.setDocumentation(Symbol.FUNCTION,
new SimpleString(docstring));
- }
- }
-
- public Function(String name, String arglist)
- {
- this(name);
- setLambdaList(new SimpleString(arglist));
}
public Function(String name, Package pkg)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java Thu Jul 29 15:38:25 2010
@@ -60,11 +60,13 @@
}
private static final Primitive ENSURE_JAVA_OBJECT = new pf_ensure_java_object();
+ @DocString(name="ensure-java-object", args="obj",
+ doc="Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary.")
private static final class pf_ensure_java_object extends Primitive
{
pf_ensure_java_object()
{
- super("ensure-java-object", PACKAGE_JAVA, true, "obj");
+ super("ensure-java-object", PACKAGE_JAVA, true);
}
@Override
@@ -73,14 +75,16 @@
}
};
- // ### register-java-exception exception-name condition-symbol => T
private static final Primitive REGISTER_JAVA_EXCEPTION = new pf_register_java_exception();
+ @DocString(name="register-java-exception", // => T
+ args="exception-name condition-symbol",
+ doc="Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition " +
+ "designated by CONDITION-SYMBOL. Returns T if successful, NIL if not.")
private static final class pf_register_java_exception extends Primitive
{
pf_register_java_exception()
{
- super("register-java-exception", PACKAGE_JAVA, true,
- "exception-name condition-symbol");
+ super("register-java-exception", PACKAGE_JAVA, true);
}
@Override
@@ -98,14 +102,15 @@
}
};
- // ### unregister-java-exception exception-name => T or NIL
private static final Primitive UNREGISTER_JAVA_EXCEPTION = new pf_unregister_java_exception();
+ @DocString(name="unregister-java-exception", args="exception-name",
+ doc="Unregisters the Java Throwable EXCEPTION-NAME previously registered" +
+ " by REGISTER-JAVA-EXCEPTION.")
private static final class pf_unregister_java_exception extends Primitive
{
pf_unregister_java_exception()
{
- super("unregister-java-exception", PACKAGE_JAVA, true,
- "exception-name");
+ super("unregister-java-exception", PACKAGE_JAVA, true);
}
@Override
@@ -129,15 +134,17 @@
return null;
}
- // ### jclass name-or-class-ref &optional class-loader => class-ref
private static final Primitive JCLASS = new pf_jclass();
+ @DocString(name="jclass", args="name-or-class-ref &optional class-loader",
+ doc="Returns a reference to the Java class designated by" +
+ " NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the" +
+ " class is resolved with respect to the given ClassLoader.")
private static final class pf_jclass extends Primitive
{
pf_jclass()
{
- super(Symbol.JCLASS, "name-or-class-ref &optional class-loader",
- "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader.");
+ super(Symbol.JCLASS);
}
@Override
@@ -154,35 +161,6 @@
}
};
- // ### jfield - retrieve or modify a field in a Java class or instance.
- //
- // Supported argument patterns:
- //
- // Case 1: class-ref field-name:
- // to retrieve the value of a static field.
- //
- // Case 2: class-ref field-name instance-ref:
- // to retrieve the value of a class field of the instance.
- //
- // Case 3: class-ref field-name primitive-value:
- // to store primitive-value in a static field.
- //
- // Case 4: class-ref field-name instance-ref value:
- // to store value in a class field of the instance.
- //
- // Case 5: class-ref field-name nil value:
- // to store value in a static field (when value may be
- // confused with an instance-ref).
- //
- // Case 6: field-name instance:
- // to retrieve the value of a field of the instance. The
- // class is derived from the instance.
- //
- // Case 7: field-name instance value:
- // to store value in a field of the instance. The class is
- // derived from the instance.
- //
-
static final LispObject jfield(Primitive fun, LispObject[] args, boolean translate)
{
@@ -258,14 +236,35 @@
return NIL;
}
- // ### jfield class-ref-or-field field-or-instance &optional instance value
+
private static final Primitive JFIELD = new pf_jfield();
+ @DocString(name="jfield",
+ args="class-ref-or-field field-or-instance &optional instance value",
+ doc="Retrieves or modifies a field in a Java class or instance.\n\n"+
+ "Supported argument patterns:\n\n"+
+ " Case 1: class-ref field-name:\n"+
+ " Retrieves the value of a static field.\n\n"+
+ " Case 2: class-ref field-name instance-ref:\n"+
+ " Retrieves the value of a class field of the instance.\n\n"+
+ " Case 3: class-ref field-name primitive-value:\n"+
+ " Stores a primitive-value in a static field.\n\n"+
+ " Case 4: class-ref field-name instance-ref value:\n"+
+ " Stores value in a class field of the instance.\n\n"+
+ " Case 5: class-ref field-name nil value:\n"+
+ " Stores value in a static field (when value may be\n"+
+ " confused with an instance-ref).\n\n"+
+ " Case 6: field-name instance:\n"+
+ " Retrieves the value of a field of the instance. The\n"+
+ " class is derived from the instance.\n\n"+
+ " Case 7: field-name instance value:\n"+
+ " Stores value in a field of the instance. The class is\n"+
+ " derived from the instance.\n\n"
+ )
private static final class pf_jfield extends Primitive
{
pf_jfield()
{
- super("jfield", PACKAGE_JAVA, true,
- "class-ref-or-field field-or-instance &optional instance value");
+ super("jfield", PACKAGE_JAVA, true);
}
@Override
@@ -275,14 +274,35 @@
}
};
- // ### jfield-raw - retrieve or modify a field in a Java class or instance.
private static final Primitive JFIELD_RAW = new pf_jfield_raw();
+ @DocString(name="jfield",
+ args="class-ref-or-field field-or-instance &optional instance value",
+ doc="Retrieves or modifies a field in a Java class or instance. Does not\n"+
+ "attempt to coerce its value or the result into a Lisp object.\n\n"+
+ "Supported argument patterns:\n\n"+
+ " Case 1: class-ref field-name:\n"+
+ " Retrieves the value of a static field.\n\n"+
+ " Case 2: class-ref field-name instance-ref:\n"+
+ " Retrieves the value of a class field of the instance.\n\n"+
+ " Case 3: class-ref field-name primitive-value:\n"+
+ " Stores a primitive-value in a static field.\n\n"+
+ " Case 4: class-ref field-name instance-ref value:\n"+
+ " Stores value in a class field of the instance.\n\n"+
+ " Case 5: class-ref field-name nil value:\n"+
+ " Stores value in a static field (when value may be\n"+
+ " confused with an instance-ref).\n\n"+
+ " Case 6: field-name instance:\n"+
+ " Retrieves the value of a field of the instance. The\n"+
+ " class is derived from the instance.\n\n"+
+ " Case 7: field-name instance value:\n"+
+ " Stores value in a field of the instance. The class is\n"+
+ " derived from the instance.\n\n"
+ )
private static final class pf_jfield_raw extends Primitive
{
pf_jfield_raw()
{
- super("jfield-raw", PACKAGE_JAVA, true,
- "class-ref-or-field field-or-instance &optional instance value");
+ super("jfield-raw", PACKAGE_JAVA, true);
}
@Override
@@ -292,14 +312,15 @@
}
};
- // ### jconstructor class-ref &rest parameter-class-refs
private static final Primitive JCONSTRUCTOR = new pf_jconstructor();
+ @DocString(name="jconstructor", args="class-ref &rest parameter-class-refs",
+ doc="Returns a reference to the Java constructor of CLASS-REF with the" +
+ " given PARAMETER-CLASS-REFS.")
private static final class pf_jconstructor extends Primitive
{
pf_jconstructor()
{
- super("jconstructor", PACKAGE_JAVA, true,
- "class-ref &rest parameter-class-refs");
+ super("jconstructor", PACKAGE_JAVA, true);
}
@Override
@@ -342,14 +363,16 @@
}
};
- // ### jmethod class-ref name &rest parameter-class-refs
private static final Primitive JMETHOD = new pf_jmethod();
+
+ @DocString(name="jmethod", args="class-ref method-name &rest parameter-class-refs",
+ doc="Returns a reference to the Java method METHOD-NAME of CLASS-REF with the" +
+ " given PARAMETER-CLASS-REFS.")
private static final class pf_jmethod extends Primitive
{
pf_jmethod()
{
- super("jmethod", PACKAGE_JAVA, true,
- "class-ref name &rest parameter-class-refs");
+ super("jmethod", PACKAGE_JAVA, true);
}
@Override
@@ -470,13 +493,14 @@
return NIL;
}
- // ### jstatic method class &rest args
private static final Primitive JSTATIC = new pf_jstatic();
+ @DocString(name="jstatic", args="method class &rest args",
+ doc="Invokes the static method METHOD on class CLASS with ARGS.")
private static final class pf_jstatic extends Primitive
{
pf_jstatic()
{
- super("jstatic", PACKAGE_JAVA, true, "method class &rest args");
+ super("jstatic", PACKAGE_JAVA, true);
}
@Override
@@ -486,14 +510,15 @@
}
};
- // ### jstatic-raw method class &rest args
private static final Primitive JSTATIC_RAW = new pf_jstatic_raw();
+ @DocString(name="jstatic-raw", args="method class &rest args",
+ doc="Invokes the static method METHOD on class CLASS with ARGS. Does not "+
+ "attempt to coerce the arguments or result into a Lisp object.")
private static final class pf_jstatic_raw extends Primitive
{
pf_jstatic_raw()
{
- super("jstatic-raw", PACKAGE_JAVA, true,
- "method class &rest args");
+ super("jstatic-raw", PACKAGE_JAVA, true);
}
@Override
@@ -503,13 +528,14 @@
}
};
- // ### jnew constructor &rest args
private static final Primitive JNEW = new pf_jnew();
+ @DocString(name="jnew", args="constructor &rest args",
+ doc="Invokes the Java constructor CONSTRUCTOR with the arguments ARGS.")
private static final class pf_jnew extends Primitive
{
pf_jnew()
{
- super("jnew", PACKAGE_JAVA, true, "constructor &rest args");
+ super("jnew", PACKAGE_JAVA, true);
}
@Override
@@ -523,7 +549,14 @@
if(classRef instanceof AbstractString) {
constructor = findConstructor(javaClass(classRef), args);
} else {
- constructor = (Constructor) JavaObject.getObject(classRef);
+ Object object = JavaObject.getObject(classRef);
+ if(object instanceof Constructor) {
+ constructor = (Constructor) object;
+ } else if(object instanceof Class<?>) {
+ constructor = findConstructor((Class<?>) object, args);
+ } else {
+ return error(new LispError(classRef.writeToString() + " is neither a Constructor nor a Class"));
+ }
}
Class[] argTypes = constructor.getParameterTypes();
Object[] initargs = new Object[args.length-1];
@@ -559,14 +592,15 @@
}
};
- // ### jnew-array element-type &rest dimensions
private static final Primitive JNEW_ARRAY = new pf_jnew_array();
+ @DocString(name="jnew-array", args="element-type &rest dimensions",
+ doc="Creates a new Java array of type ELEMENT-TYPE, with the given" +
+ " DIMENSIONS.")
private static final class pf_jnew_array extends Primitive
{
pf_jnew_array()
{
- super("jnew-array", PACKAGE_JAVA, true,
- "element-type &rest dimensions");
+ super("jnew-array", PACKAGE_JAVA, true);
}
@Override
@@ -617,14 +651,15 @@
return NIL;
}
- // ### jarray-ref java-array &rest indices
private static final Primitive JARRAY_REF = new pf_jarray_ref();
+ @DocString(name="jarray-ref", args="java-array &rest indices",
+ doc="Dereferences the Java array JAVA-ARRAY using the given INDICIES, " +
+ "coercing the result into a Lisp object, if possible.")
private static final class pf_jarray_ref extends Primitive
{
pf_jarray_ref()
{
- super("jarray-ref", PACKAGE_JAVA, true,
- "java-array &rest indices");
+ super("jarray-ref", PACKAGE_JAVA, true);
}
@Override
@@ -634,14 +669,15 @@
}
};
- // ### jarray-ref-raw java-array &rest indices
private static final Primitive JARRAY_REF_RAW = new pf_jarray_ref_raw();
+ @DocString(name="jarray-ref-raw", args="java-array &rest indices",
+ doc="Dereference the Java array JAVA-ARRAY using the given INDICIES. " +
+ "Does not attempt to coerce the result into a Lisp object.")
private static final class pf_jarray_ref_raw extends Primitive
{
pf_jarray_ref_raw()
{
- super("jarray-ref-raw", PACKAGE_JAVA, true,
- "java-array &rest indices");
+ super("jarray-ref-raw", PACKAGE_JAVA, true);
}
@Override
@@ -651,14 +687,14 @@
}
};
- // ### jarray-set java-array new-value &rest indices
private static final Primitive JARRAY_SET = new pf_jarray_set();
+ @DocString(name="jarray-set", args="java-array new-value &rest indices",
+ doc="Stores NEW-VALUE at the given index in JAVA-ARRAY.")
private static final class pf_jarray_set extends Primitive
{
pf_jarray_set()
{
- super("jarray-set", PACKAGE_JAVA, true,
- "java-array new-value &rest indices");
+ super("jarray-set", PACKAGE_JAVA, true);
}
@Override
@@ -691,14 +727,16 @@
}
};
- // ### jcall method instance &rest args
/** Calls makeLispObject() to convert the result to an appropriate Lisp type. */
private static final Primitive JCALL = new pf_jcall();
+ @DocString(name="jcall", args="method-ref instance &rest args",
+ doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS," +
+ " coercing the result into a Lisp object, if possible.")
private static final class pf_jcall extends Primitive
{
pf_jcall()
{
- super(Symbol.JCALL, "method-ref instance &rest args");
+ super(Symbol.JCALL);
}
@Override
@@ -708,17 +746,19 @@
}
};
- // ### jcall-raw method instance &rest args
/**
* Does no type conversion. The result of the call is simply wrapped in a
* JavaObject.
*/
private static final Primitive JCALL_RAW = new pf_jcall_raw();
+ @DocString(name="jcall-raw", args="method-ref instance &rest args",
+ doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS." +
+ " Does not attempt to coerce the result into a Lisp object.")
private static final class pf_jcall_raw extends Primitive
{
pf_jcall_raw()
{
- super(Symbol.JCALL_RAW, "method-ref instance &rest args");
+ super(Symbol.JCALL_RAW);
}
@Override
@@ -976,14 +1016,17 @@
}
}
- // ### make-immediate-object object &optional type
private static final Primitive MAKE_IMMEDIATE_OBJECT = new pf_make_immediate_object();
+ @DocString(name="make-immediate-object", args="object &optional type",
+ doc="Attempts to coerce a given Lisp object into a java-object of the\n"+
+ "given type. If type is not provided, works as jobject-lisp-value.\n"+
+ "Currently, type may be :BOOLEAN, treating the object as a truth value,\n"+
+ "or :REF, which returns Java null if NIL is provided.")
private static final class pf_make_immediate_object extends Primitive
{
pf_make_immediate_object()
{
- super("make-immediate-object", PACKAGE_JAVA, true,
- "object &optional type");
+ super("make-immediate-object", PACKAGE_JAVA, true);
}
@Override
@@ -1012,13 +1055,14 @@
}
};
- // ### java-object-p
private static final Primitive JAVA_OBJECT_P = new pf_java_object_p();
+ @DocString(name="java-object-p", args="object",
+ doc="Returns T if OBJECT is a JAVA-OBJECT.")
private static final class pf_java_object_p extends Primitive
{
pf_java_object_p()
{
- super("java-object-p", PACKAGE_JAVA, true, "object");
+ super("java-object-p", PACKAGE_JAVA, true);
}
@Override
@@ -1028,8 +1072,9 @@
}
};
- // ### jobject-lisp-value java-object
private static final Primitive JOBJECT_LISP_VALUE = new pf_jobject_lisp_value();
+ @DocString(name="jobject-lisp-value", args="java-object",
+ doc="Attempts to coerce JAVA-OBJECT into a Lisp object.")
private static final class pf_jobject_lisp_value extends Primitive
{
pf_jobject_lisp_value()
@@ -1044,13 +1089,15 @@
}
};
- // ### jcoerce java-object intended-class
private static final Primitive JCOERCE = new pf_jcoerce();
+ @DocString(name="jcoerce", args="object intended-class",
+ doc="Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS." +
+ " Raises a TYPE-ERROR if no conversion is possible.")
private static final class pf_jcoerce extends Primitive
{
pf_jcoerce()
{
- super("jcoerce", PACKAGE_JAVA, true, "java-object intended-class");
+ super("jcoerce", PACKAGE_JAVA, true);
}
@Override
@@ -1066,8 +1113,10 @@
}
};
- // ### %jget-property-value java-object property-name
private static final Primitive JGET_PROPERTY_VALUE = new pf__jget_property_value();
+ @DocString(name="%jget-propety-value", args="java-object property-name",
+ doc="Gets a JavaBeans property on JAVA-OBJECT.\n" +
+ "SYSTEM-INTERNAL: Use jproperty-value instead.")
private static final class pf__jget_property_value extends Primitive
{
pf__jget_property_value()
@@ -1095,8 +1144,10 @@
}
};
- // ### %jset-property-value java-object property-name value
private static final Primitive JSET_PROPERTY_VALUE = new pf__jset_property_value();
+ @DocString(name="%jset-propety-value", args="java-object property-name value",
+ doc="Sets a JavaBean property on JAVA-OBJECT.\n" +
+ "SYSTEM-INTERNAL: Use (setf jproperty-value) instead.")
private static final class pf__jset_property_value extends Primitive
{
pf__jset_property_value()
@@ -1131,15 +1182,15 @@
}
};
-
- // ### jrun-exception-protected closure
private static final Primitive JRUN_EXCEPTION_PROTECTED = new pf_jrun_exception_protection();
+ @DocString(name="jrun-exception-protected", args="closure",
+ doc="Invokes the function CLOSURE and returns the result. "+
+ "Signals an error if stack or heap exhaustion occurs.")
private static final class pf_jrun_exception_protection extends Primitive
{
pf_jrun_exception_protection()
{
- super("jrun-exception-protected", PACKAGE_JAVA, true,
- "closure");
+ super("jrun-exception-protected", PACKAGE_JAVA, true);
}
@Override
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java Thu Jul 29 15:38:25 2010
@@ -97,18 +97,31 @@
return T;
if (type == BuiltInClass.JAVA_OBJECT)
return T;
- if(type.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) {
+ LispObject cls = NIL;
+ if(type instanceof Symbol) {
+ cls = LispClass.findClass(type, false);
+ }
+ if(cls == NIL) {
+ cls = type;
+ }
+ if(cls.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) {
if(obj != null) {
- Class c = (Class) JAVA_CLASS_JCLASS.execute(type).javaInstance();
+ Class c = (Class) JAVA_CLASS_JCLASS.execute(cls).javaInstance();
return c.isAssignableFrom(obj.getClass()) ? T : NIL;
} else {
return T;
}
+ } else if(cls == BuiltInClass.SEQUENCE) {
+ //This information is replicated here from java.lisp; it is a very
+ //specific case, not worth implementing CPL traversal in typep
+ if(java.util.List.class.isInstance(obj) ||
+ java.util.Set.class.isInstance(obj)) {
+ return T;
+ }
}
return super.typep(type);
}
-
@Override
public LispObject STRING()
{
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java Thu Jul 29 15:38:25 2010
@@ -89,7 +89,7 @@
Packages.createPackage("SEQUENCE");
- // ### nil
+ @DocString(name="nil")
public static final LispObject NIL = Nil.NIL;
// We need NIL before we can call usePackage().
@@ -261,7 +261,7 @@
return thread.setValues(form, NIL);
}
- // ### interactive-eval
+ @DocString(name="interactive-eval")
private static final Primitive INTERACTIVE_EVAL =
new Primitive("interactive-eval", PACKAGE_SYS, true)
{
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java Thu Jul 29 15:38:25 2010
@@ -657,6 +657,23 @@
if (entry instanceof Cons)
return ((Cons)entry).cdr;
}
+ if(docType == Symbol.FUNCTION && this instanceof Symbol) {
+ Object fn = ((Symbol)this).getSymbolFunction();
+ if(fn instanceof Function) {
+ DocString ds = fn.getClass().getAnnotation(DocString.class);
+ if(ds != null) {
+ String arglist = ds.args();
+ String docstring = ds.doc();
+ if(arglist.length() != 0)
+ ((Function)fn).setLambdaList(new SimpleString(arglist));
+ if(docstring.length() != 0) {
+ SimpleString doc = new SimpleString(docstring);
+ ((Symbol)this).setDocumentation(Symbol.FUNCTION, doc);
+ return doc;
+ }
+ }
+ }
+ }
return NIL;
}
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java Thu Jul 29 15:38:25 2010
@@ -860,7 +860,7 @@
return unreadableString(sb.toString());
}
- // ### make-thread
+ @DocString(name="make-thread", args="function &optional &key name")
private static final Primitive MAKE_THREAD =
new Primitive("make-thread", PACKAGE_THREADS, true, "function &optional &key name")
{
@@ -886,10 +886,10 @@
}
};
- // ### threadp
+ @DocString(name="threadp", args="object",
+ doc="Boolean predicate testing if OBJECT is a thread.")
private static final Primitive THREADP =
- new Primitive("threadp", PACKAGE_THREADS, true, "object",
- "Boolean predicate as whether OBJECT is a thread.")
+ new Primitive("threadp", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject arg)
@@ -898,7 +898,8 @@
}
};
- // ### thread-alive-p
+ @DocString(name="thread-alive-p", args="thread",
+ doc="Returns T if THREAD is alive.")
private static final Primitive THREAD_ALIVE_P =
new Primitive("thread-alive-p", PACKAGE_THREADS, true, "thread",
"Boolean predicate whether THREAD is alive.")
@@ -917,10 +918,10 @@
}
};
- // ### thread-name
+ @DocString(name="thread-name", args="thread",
+ doc="Return the name of THREAD, if it has one.")
private static final Primitive THREAD_NAME =
- new Primitive("thread-name", PACKAGE_THREADS, true, "thread",
- "Return the name of THREAD if it has one.")
+ new Primitive("thread-name", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject arg)
@@ -972,9 +973,10 @@
return (d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE);
}
- // ### sleep
- private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true, "seconds",
- "Causes the invoking thread to sleep for SECONDS seconds.\nSECONDS may be a value between 0 1and 1.")
+ @DocString(name="sleep", args="seconds",
+ doc="Causes the invoking thread to sleep for SECONDS seconds.\n"+
+ "SECONDS may be a value between 0 1and 1.")
+ private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true)
{
@Override
public LispObject execute(LispObject arg)
@@ -990,10 +992,10 @@
}
};
- // ### mapcar-threads
+ @DocString(name="mapcar-threads", args= "function",
+ doc="Applies FUNCTION to all existing threads.")
private static final Primitive MAPCAR_THREADS =
- new Primitive("mapcar-threads", PACKAGE_THREADS, true, "function",
- "Applies FUNCTION to all existing threads.")
+ new Primitive("mapcar-threads", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject arg)
@@ -1011,10 +1013,9 @@
}
};
- // ### destroy-thread
+ @DocString(name="destroy-thread", args="thread", doc="Mark THREAD as destroyed")
private static final Primitive DESTROY_THREAD =
- new Primitive("destroy-thread", PACKAGE_THREADS, true, "thread",
- "Mark THREAD as destroyed.")
+ new Primitive("destroy-thread", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject arg)
@@ -1031,11 +1032,12 @@
}
};
- // ### interrupt-thread thread function &rest args => T
- // Interrupts thread and forces it to apply function to args. When the
- // function returns, the thread's original computation continues. If
- // multiple interrupts are queued for a thread, they are all run, but the
- // order is not guaranteed.
+ // => T
+ @DocString(name="interrupt-thread", args="thread function &rest args",
+ doc="Interrupts thread and forces it to apply function to args. When the\n"+
+ "function returns, the thread's original computation continues. If\n"+
+ "multiple interrupts are queued for a thread, they are all run, but the\n"+
+ "order is not guaranteed.")
private static final Primitive INTERRUPT_THREAD =
new Primitive("interrupt-thread", PACKAGE_THREADS, true,
"thread function &rest args",
@@ -1062,10 +1064,10 @@
}
};
- // ### current-thread
+ @DocString(name="current-thread",
+ doc="Returns a reference to invoking thread.")
private static final Primitive CURRENT_THREAD =
- new Primitive("current-thread", PACKAGE_THREADS, true, "",
- "Returns a reference to invoking thread.")
+ new Primitive("current-thread", PACKAGE_THREADS, true)
{
@Override
public LispObject execute()
@@ -1074,10 +1076,10 @@
}
};
- // ### backtrace
+ @DocString(name="backtrace",
+ doc="Returns a backtrace of the invoking thread.")
private static final Primitive BACKTRACE =
- new Primitive("backtrace", PACKAGE_SYS, true, "",
- "Returns a backtrace of the invoking thread.")
+ new Primitive("backtrace", PACKAGE_SYS, true)
{
@Override
public LispObject execute(LispObject[] args)
@@ -1089,9 +1091,9 @@
return currentThread().backtrace(limit);
}
};
- // ### frame-to-string
+ @DocString(name="frame-to-string", args="frame")
private static final Primitive FRAME_TO_STRING =
- new Primitive("frame-to-string", PACKAGE_SYS, true, "frame")
+ new Primitive("frame-to-string", PACKAGE_SYS, true)
{
@Override
public LispObject execute(LispObject[] args)
@@ -1104,9 +1106,9 @@
}
};
- // ### frame-to-list
+ @DocString(name="frame-to-list", args="frame")
private static final Primitive FRAME_TO_LIST =
- new Primitive("frame-to-list", PACKAGE_SYS, true, "frame")
+ new Primitive("frame-to-list", PACKAGE_SYS, true)
{
@Override
public LispObject execute(LispObject[] args)
@@ -1120,20 +1122,7 @@
};
- static {
- //FIXME: this block has been added for pre-0.16 compatibility
- // and can be removed the latest at release 0.22
- PACKAGE_EXT.export(intern("MAKE-THREAD", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("THREADP", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("THREAD-ALIVE-P", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("THREAD-NAME", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("MAPCAR-THREADS", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("DESTROY-THREAD", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("INTERRUPT-THREAD", PACKAGE_THREADS));
- PACKAGE_EXT.export(intern("CURRENT-THREAD", PACKAGE_THREADS));
- }
-
- // ### use-fast-calls
+ @DocString(name="use-fast-calls")
private static final Primitive USE_FAST_CALLS =
new Primitive("use-fast-calls", PACKAGE_SYS, true)
{
@@ -1145,7 +1134,7 @@
}
};
- // ### synchronized-on
+ @DocString(name="synchronized-on", args="form &body body")
private static final SpecialOperator SYNCHRONIZED_ON =
new SpecialOperator("synchronized-on", PACKAGE_THREADS, true,
"form &body body")
@@ -1164,10 +1153,9 @@
}
};
- // ### object-wait
+ @DocString(name="object-wait", args="object &optional timeout")
private static final Primitive OBJECT_WAIT =
- new Primitive("object-wait", PACKAGE_THREADS, true,
- "object &optional timeout")
+ new Primitive("object-wait", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject object)
@@ -1202,7 +1190,7 @@
}
};
- // ### object-notify
+ @DocString(name="object-notify", args="object")
private static final Primitive OBJECT_NOTIFY =
new Primitive("object-notify", PACKAGE_THREADS, true,
"object")
@@ -1221,10 +1209,9 @@
}
};
- // ### object-notify-all
+ @DocString(name="object-notify-all", args="object")
private static final Primitive OBJECT_NOTIFY_ALL =
- new Primitive("object-notify-all", PACKAGE_THREADS, true,
- "object")
+ new Primitive("object-notify-all", PACKAGE_THREADS, true)
{
@Override
public LispObject execute(LispObject object)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java Thu Jul 29 15:38:25 2010
@@ -53,6 +53,11 @@
public final LispObject getLambdaList()
{
+ if(lambdaList == null) {
+ DocString ds = getClass().getAnnotation(DocString.class);
+ if(ds != null)
+ lambdaList = new SimpleString(ds.args());
+ }
return lambdaList;
}
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Thu Jul 29 15:38:25 2010
@@ -860,6 +860,7 @@
useNamestring = false;
}
StringBuilder sb = new StringBuilder();
+
if (useNamestring) {
if (printReadably || printEscape) {
sb.append("#P\"");
@@ -877,61 +878,45 @@
if (printReadably || printEscape) {
sb.append('"');
}
- } else {
- final SpecialBindingsMark mark = thread.markSpecialBindings();
- thread.bindSpecial(Symbol.PRINT_ESCAPE, T);
- try {
- final boolean ANSI_COMPATIBLE = true;
- final String SPACE = " ";
- if (ANSI_COMPATIBLE) {
- sb.append("#P(\"");
- } else {
- sb.append("#P(");
+ return sb.toString();
+ }
- }
- if (host != NIL) {
- sb.append(":HOST ");
- sb.append(host.writeToString());
- sb.append(SPACE);
- }
- if (device != NIL) {
- sb.append(":DEVICE ");
- sb.append(device.writeToString());
- sb.append(SPACE);
- }
- if (directory != NIL) {
- sb.append(":DIRECTORY ");
- sb.append(directory.writeToString());
- sb.append(SPACE);
- }
- if (name != NIL) {
- sb.append(":NAME ");
- sb.append(name.writeToString());
- sb.append(SPACE);
- }
- if (type != NIL) {
- sb.append(":TYPE ");
- sb.append(type.writeToString());
- sb.append(SPACE);
- }
- if (version != NIL) {
- sb.append(":VERSION ");
- sb.append(version.writeToString());
- sb.append(SPACE);
- }
- if (sb.charAt(sb.length() - 1) == ' ') { // XXX
- sb.setLength(sb.length() - 1);
- }
- if (ANSI_COMPATIBLE) {
- sb.append(')' + "\"");
- } else {
- sb.append(')');
- }
- } finally {
- thread.resetSpecialBindings(mark);
- }
+ sb.append("PATHNAME (with no namestring) ");
+ if (host != NIL) {
+ sb.append(":HOST ");
+ sb.append(host.writeToString());
+ sb.append(" ");
}
- return sb.toString();
+ if (device != NIL) {
+ sb.append(":DEVICE ");
+ sb.append(device.writeToString());
+ sb.append(" ");
+ }
+ if (directory != NIL) {
+ sb.append(":DIRECTORY ");
+ sb.append(directory.writeToString());
+ sb.append(" ");
+ }
+ if (name != NIL) {
+ sb.append(":NAME ");
+ sb.append(name.writeToString());
+ sb.append(" ");
+ }
+ if (type != NIL) {
+ sb.append(":TYPE ");
+ sb.append(type.writeToString());
+ sb.append(" ");
+ }
+ if (version != NIL) {
+ sb.append(":VERSION ");
+ sb.append(version.writeToString());
+ sb.append(" ");
+ }
+ if (sb.charAt(sb.length() - 1) == ' ') {
+ sb.setLength(sb.length() - 1);
+ }
+
+ return unreadableString(sb.toString());
}
// A logical host is represented as the string that names it.
// (defvar *logical-pathname-translations* (make-hash-table :test 'equal))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java Thu Jul 29 15:38:25 2010
@@ -45,6 +45,11 @@
super(name);
}
+ public Primitive(Symbol symbol)
+ {
+ super(symbol);
+ }
+
public Primitive(Symbol symbol, String arglist)
{
super(symbol, arglist);
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java Thu Jul 29 15:38:25 2010
@@ -890,7 +890,16 @@
out = Symbol.STANDARD_OUTPUT.symbolValue();
else
out = second;
- checkStream(out)._writeString(first.writeToString());
+ String output = first.writeToString();
+ if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL
+ && output.contains("#<")) {
+ LispObject args = NIL;
+ args = args.push(first);
+ args = args.push(Keyword.OBJECT);
+ args = args.nreverse();
+ return error(new PrintNotReadable(args));
+ }
+ checkStream(out)._writeString(output);
return first;
}
};
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java Thu Jul 29 15:38:25 2010
@@ -534,11 +534,12 @@
public LispObject readPathname(ReadtableAccessor rta) {
LispObject obj = read(true, NIL, false,
LispThread.currentThread(), rta);
- if (obj instanceof AbstractString)
+ if (obj instanceof AbstractString) {
return Pathname.parseNamestring((AbstractString)obj);
+ }
if (obj.listp())
return Pathname.makePathname(obj);
- return error(new TypeError("#p requires a string or list argument."));
+ return error(new TypeError("#p requires a string argument."));
}
public LispObject readSymbol() {
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java Thu Jul 29 15:38:25 2010
@@ -41,9 +41,9 @@
public static String getVersion()
{
- return "0.21.0-dev";
+ return "0.22.0-dev";
}
-
+
public static void main(String args[]) {
System.out.println(Version.getVersion());
}
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jul 29 15:38:25 2010
@@ -70,7 +70,7 @@
(eval-when (:load-toplevel :compile-toplevel :execute)
(let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
+ (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111.
(existing-asdf (find-package :asdf))
(vername '#:*asdf-version*)
(versym (and existing-asdf
@@ -727,8 +727,12 @@
#+clisp (defun get-uid () (posix:uid))
#+sbcl (defun get-uid () (sb-unix:unix-getuid))
#+cmu (defun get-uid () (unix:unix-getuid))
-#+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>")
-#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
+#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
+ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
+#+ecl (defun get-uid ()
+ #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
+ '(ffi:c-inline () () :int "getuid()" :one-liner t)
+ '(ext::getuid)))
#+allegro (defun get-uid () (excl.osi:getuid))
#-(or cmu sbcl clisp allegro ecl)
(defun get-uid ()
@@ -1073,6 +1077,17 @@
(defun system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
+(defun clear-system (name)
+ "Clear the entry for a system in the database of systems previously loaded.
+Note that this does NOT in any way cause the code of the system to be unloaded."
+ ;; There is no "unload" operation in Common Lisp, and a general such operation
+ ;; cannot be portably written, considering how much CL relies on side-effects
+ ;; of global data structures.
+ ;; Note that this does a setf gethash instead of a remhash
+ ;; this way there remains a hint in the *defined-systems* table
+ ;; that the system was loaded at some point.
+ (setf (gethash (coerce-name name) *defined-systems*) nil))
+
(defun map-systems (fn)
"Apply FN to each defined system.
@@ -2395,6 +2410,7 @@
:hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
:java-1.4 :java-1.5 :java-1.6 :java-1.7))
+
(defun lisp-version-string ()
(let ((s (lisp-implementation-version)))
(declare (ignorable s))
@@ -2410,6 +2426,7 @@
(:-ics "8")
(:+ics ""))
(if (member :64bit *features*) "-64bit" ""))
+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
#+clisp (subseq s 0 (position #\space s))
#+clozure (format nil "~d.~d-fasl~d"
ccl::*openmcl-major-version*
@@ -2424,8 +2441,7 @@
#+gcl (subseq s (1+ (position #\space s)))
#+lispworks (format nil "~A~@[~A~]" s
(when (member :lispworks-64bit *features*) "-64bit"))
- ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
- #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+ ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
#+(or cormanlisp mcl sbcl scl) s
#-(or allegro armedbear clisp clozure cmu cormanlisp digitool
ecl gcl lispworks mcl sbcl scl) s))
@@ -2510,7 +2526,7 @@
`(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
- (list #p"/etc/"))))
+ (list #p"/etc/common-lisp/"))))
(defun in-first-directory (dirs x)
(loop :for dir :in dirs
:thereis (and dir (ignore-errors
@@ -2957,7 +2973,7 @@
:defaults x))
(defun delete-file-if-exists (x)
- (when (probe-file x)
+ (when (and x (probe-file x))
(delete-file x)))
(defun compile-file* (input-file &rest keys &key &allow-other-keys)
@@ -3354,14 +3370,18 @@
(defun initialize-source-registry (&optional parameter)
(setf (source-registry) (compute-source-registry parameter)))
-;; checks an initial variable to see whether the state is initialized
+;; Checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
-;; of (asdf:find-system).
-(defun ensure-source-registry ()
+;; of (asdf:find-system) to make sure the source registry is initialized.
+;; However, it will do so *without* a parameter, at which point it
+;; will be too late to provide a parameter to this function, though
+;; you may override the configuration explicitly by calling
+;; initialize-source-registry directly with your parameter.
+(defun ensure-source-registry (&optional parameter)
(if (source-registry-initialized-p)
(source-registry)
- (initialize-source-registry)))
+ (initialize-source-registry parameter)))
(defun sysdef-source-registry-search (system)
(ensure-source-registry)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Jul 29 15:38:25 2010
@@ -345,16 +345,6 @@
(export '(make-thread-lock thread-lock thread-unlock with-thread-lock))
(export '(make-mutex get-mutex release-mutex with-mutex))
-(progn
- ;; block to be removed at 0.22
- ;; It exists solely for pre-0.17 compatibility
- ;; FIXME 0.22
- (in-package "EXTENSIONS")
- (export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
- (export '(make-thread-lock thread-lock thread-unlock with-thread-lock))
- (export '(with-mutex make-mutex get-mutex release-mutex)))
-
-;; end of 0.22 block
(in-package "EXTENSIONS")
@@ -428,6 +418,8 @@
(in-package "COMMON-LISP")
+(sys::autoload '(documentation) "clos")
+
(sys::autoload '(write print prin1 princ pprint write-to-string
prin1-to-string princ-to-string write-char
write-string write-line terpri finish-output
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Jul 29 15:38:25 2010
@@ -187,6 +187,7 @@
"inspect.lisp"
;;"j.lisp"
"java.lisp"
+ "java-collections.lisp"
"known-functions.lisp"
"known-symbols.lisp"
"late-setf.lisp"
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp Thu Jul 29 15:38:25 2010
@@ -85,7 +85,8 @@
(when condition
(fresh-line *debug-io*)
(with-standard-io-syntax
- (let ((*print-structure* nil))
+ (let ((*print-structure* nil)
+ (*print-readably* nil))
(when (and *load-truename* (streamp *load-stream*))
(simple-format *debug-io*
"Error loading ~A at line ~D (offset ~D)~%"
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp Thu Jul 29 15:38:25 2010
@@ -149,6 +149,11 @@
method implementation)))))
lisp-this))
+(defun jequal (obj1 obj2)
+ "Compares obj1 with obj2 using java.lang.Object.equals()"
+ (jcall (jmethod "java.lang.Object" "equals" "java.lang.Object")
+ obj1 obj2))
+
(defun jobject-class (obj)
"Returns the Java class that OBJ belongs to"
(jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -363,6 +368,15 @@
:direct-superclasses (list (find-class 'java-object))
:java-class +java-lang-object+)))
+(defun jclass-additional-superclasses (jclass)
+ "Extension point to put additional CLOS classes on the CPL of a CLOS Java class."
+ (let ((supers nil))
+ (when (jclass-interface-p jclass)
+ (push (find-class 'java-object) supers))
+ (when (jequal jclass (jclass "java.util.List"))
+ (push (find-class 'sequence) supers))
+ supers))
+
(defun ensure-java-class (jclass)
(let ((class (%find-java-class jclass)))
(if class
@@ -378,9 +392,7 @@
(concatenate 'list
(list (jclass-superclass jclass))
(jclass-interfaces jclass))))))
- (if (jclass-interface-p jclass)
- (append supers (list (find-class 'java-object)))
- supers))
+ (append supers (jclass-additional-superclasses jclass)))
:java-class jclass)))))
(defmethod mop::compute-class-precedence-list ((class java-class))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java Thu Jul 29 15:38:25 2010
@@ -37,9 +37,9 @@
import java.math.BigInteger;
-// ### logorc2
// logorc2 integer-1 integer-2 => result-integer
// or integer-1 with complement of integer-2
+ at DocString(name="logorc2", args="integer-1 integer-2")
public final class logorc2 extends Primitive
{
private logorc2()
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java Thu Jul 29 15:38:25 2010
@@ -35,7 +35,7 @@
import static org.armedbear.lisp.Lisp.*;
-// ### package-error-package
+ at DocString(name="package-error-package")
public final class package_error_package extends Primitive
{
private package_error_package()
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp Thu Jul 29 15:38:25 2010
@@ -280,6 +280,10 @@
(symbol-package x))))
(defun %print-object (object stream)
+ (when (and *print-readably*
+ (typep object 'string)
+ (search "#<" object))
+ (error 'print-not-readable :object object))
(if *print-pretty*
(xp::output-pretty-object object stream)
(output-ugly-object object stream)))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp Thu Jul 29 15:38:25 2010
@@ -1,6 +1,6 @@
;;; threads.lisp
;;;
-;;; Copyright (C) 2009 Erik Huelsmann <ehuelsmann at common-lisp.net>
+;;; Copyright (C) 2009-2010 Erik Huelsmann <ehuelsmann at common-lisp.net>
;;;
;;; $Id$
;;;
@@ -142,9 +142,3 @@
(synchronized-on ,glock
, at body))))
-(defun thread-lock (lock)
- "Deprecated; due for removal in 0.22"
- (declare (ignore lock)))
-(defun thread-unlock (lock)
- "Deprecated; due for removal in 0.22"
- (declare (ignore lock)))
Modified: branches/generic-class-file/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- branches/generic-class-file/abcl/test/lisp/ansi/package.lisp (original)
+++ branches/generic-class-file/abcl/test/lisp/ansi/package.lisp Thu Jul 29 15:38:25 2010
@@ -32,13 +32,22 @@
(format t "---> ~A begins.~%" message)
(format t "Invoking ABCL hosted on ~A ~A.~%"
(software-type) (software-version))
- (if (find :unix *features*)
- (run-shell-command "cd ~A; make clean" ansi-tests-directory)
- ;; XXX -- what to invoke on win32? Untested:
- (run-shell-command
- (format nil "~A~%~A"
- (format nil "cd ~A" *ansi-tests-directory*)
- (format nil "erase *.cls *.abcl"))))
+ ;; Do what 'make clean' would do from the GCL ANSI tests,
+ ;; so we don't have to hunt for 'make' on win32.
+ (mapcar #'delete-file
+ (append (directory (format nil "~A/*.cls" *default-pathname-defaults*))
+ (directory (format nil "~A/*.abcl" *default-pathname-defaults*))
+ (directory (format nil "~A/scratch/*" *default-pathname-defaults*))
+ (mapcar (lambda(x) (format nil "~A/~A" *default-pathname-defaults* x))
+ '("scratch/"
+ "scratch.txt" "foo.txt" "foo.lsp"
+ "foo.dat"
+ "tmp.txt" "tmp.dat" "tmp2.dat"
+ "temp.dat" "out.class"
+ "file-that-was-renamed.txt"
+ "compile-file-test-lp.lsp"
+ "compile-file-test-lp.out"
+ "ldtest.lsp"))))
(time (load boot-file))
(format t "<--- ~A ends.~%" message))
(file-error (e)
Modified: branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp
==============================================================================
--- branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp (original)
+++ branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp Thu Jul 29 15:38:25 2010
@@ -74,7 +74,9 @@
(getf `(doit ,*doit* compileit ,*compileit*) test))
(defvar *default-database-file*
- (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))
+ (if (find :asdf2 *features*)
+ (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures")
+ (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))
(defun parse (&optional (file *default-database-file*))
(format t "Parsing test report database from ~A~%" *default-database-file*)
More information about the armedbear-cvs
mailing list