[armedbear-cvs] r11590 - in trunk/abcl: . src/META-INF src/org/armedbear/lisp src/org/armedbear/lisp/scripting
Alessio Stalla
astalla at common-lisp.net
Sun Jan 25 23:34:25 UTC 2009
Author: astalla
Date: Sun Jan 25 23:34:24 2009
New Revision: 11590
Log:
Merged the scripting branch, providing JSR-223 support and other new
features. JSR-233 is only built if the necessary javax.script.* classes
are found in the CLASSPATH.
Added:
trunk/abcl/src/META-INF/
- copied from r11575, /branches/scripting/j/src/META-INF/
trunk/abcl/src/org/armedbear/lisp/JavaClass.java
- copied unchanged from r11575, /branches/scripting/j/src/org/armedbear/lisp/JavaClass.java
trunk/abcl/src/org/armedbear/lisp/scripting/
- copied from r11575, /branches/scripting/j/src/org/armedbear/lisp/scripting/
Modified:
trunk/abcl/build.xml
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/JProxy.java
trunk/abcl/src/org/armedbear/lisp/Java.java
trunk/abcl/src/org/armedbear/lisp/JavaObject.java
trunk/abcl/src/org/armedbear/lisp/LispObject.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/java.lisp
trunk/abcl/src/org/armedbear/lisp/print-object.lisp
Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml (original)
+++ trunk/abcl/build.xml Sun Jan 25 23:34:24 2009
@@ -19,7 +19,7 @@
value="${dist.dir}/abcl.jar"/>
<property name="abcl.ext.dir"
value="${basedir}/ext"/>
-
+
<target name="help">
<echo>Main Ant targets:
abcl.compile
@@ -37,15 +37,23 @@
<echo>Corresponding targets for J have been removed.</echo>
</target>
+ <!-- Checks if JSR-223 support is available - thanks to Mark Everson -->
+ <available property="abcl.jsr-223.p"
+ classname="javax.script.ScriptEngine"/>
+
<patternset id="abcl.source.java">
<include name="org/armedbear/lisp/*.java"/>
<include name="org/armedbear/lisp/util/*.java"/>
+ <include name="org/armedbear/lisp/scripting/*.java" if="abcl.jsr-223.p"/>
+ <include name="org/armedbear/lisp/scripting/util/*.java" if="abcl.jsr-223.p"/>
+ <include name="org/armedbear/Main.java"/>
</patternset>
<patternset id="abcl.source.lisp">
<include name="org/armedbear/lisp/*.lisp"/>
<include name="org/armedbear/lisp/tests/*.lisp"/>
<exclude name="org/armedbear/lisp/j.lisp"/>
+ <include name="org/armedbear/lisp/scripting/lisp/*.lisp" if="abcl.jsr-223.p"/>
</patternset>
<patternset id="abcl.scripting.source.java">
@@ -60,6 +68,7 @@
<!-- Lisp files required at runtime -->
<patternset id="abcl.source.lisp.dist">
<include name="org/armedbear/lisp/boot.lisp"/>
+ <include name="org/armedbear/lisp/scripting/lisp/*.lisp" if="abcl.jsr-223.p"/>
</patternset>
<patternset id="abcl.objects">
@@ -67,6 +76,8 @@
<include name="org/armedbear/lisp/util/*.class"/>
<include name="org/armedbear/lisp/*.cls"/>
<include name="org/armedbear/lisp/*.abcl"/>
+ <include name="org/armedbear/lisp/scripting/*.class" if="abcl.jsr-223.p"/>
+ <include name="org/armedbear/lisp/scripting/util/*.class" if="abcl.jsr-223.p"/>
<patternset refid="abcl.source.lisp.dist"/>
</patternset>
@@ -127,8 +138,14 @@
<echo>WARNING: Use of Java version ${java.version} not recommended.</echo>
</target>
+ <target name="abcl.jsr-223.notice"
+ depends="abcl.init"
+ unless="abcl.jsr-223.p">
+ <echo>Notice: JSR-223 support won't be built since it is not supported, neither natively by your JVM nor by libraries in the CLASSPATH.</echo>
+ </target>
+
<target name="abcl.compile.java"
- depends="abcl.init,abcl.java.warning">
+ depends="abcl.init,abcl.java.warning,abcl.jsr-223.notice">
<mkdir dir="${build.dir}"/>
<mkdir dir="${build.classes.dir}"/>
<javac destdir="${build.classes.dir}"
@@ -236,6 +253,8 @@
value="${version.src}"/>
</section>
</manifest>
+ <metainf dir="${src.dir}/META-INF">
+ </metainf>
</jar>
</target>
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 Jan 25 23:34:24 2009
@@ -513,6 +513,9 @@
autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true);
autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
+ autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
+ autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
+ autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");
Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JProxy.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Sun Jan 25 23:34:24 2009
@@ -134,4 +134,114 @@
return null;
}
}
+
+ //NEW IMPLEMENTATION by Alessio Stalla
+
+ /**
+ * A weak map associating each proxy instance with a "Lisp-this" object.
+ */
+ private static final Map<Object, LispObject> proxyMap = new WeakHashMap<Object, LispObject>();
+
+ public static class LispInvocationHandler implements InvocationHandler {
+
+ private Function function;
+ private static Method hashCodeMethod;
+ private static Method equalsMethod;
+ private static Method toStringMethod;
+
+ static {
+ try {
+ hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {});
+ equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class });
+ toStringMethod = Object.class.getMethod("toString", new Class[] {});
+ } catch (Exception e) {
+ throw new Error("Something got horribly wrong - can't get a method from Object.class", e);
+ }
+ }
+
+ public LispInvocationHandler(Function function) {
+ this.function = function;
+ }
+
+ public Object invoke(Object proxy, Method method, Object[] args) throws Throwable {
+ if(hashCodeMethod.equals(method)) {
+ return System.identityHashCode(proxy);
+ }
+ if(equalsMethod.equals(method)) {
+ return proxy == args[0];
+ }
+ if(toStringMethod.equals(method)) {
+ return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode());
+ }
+
+ if(args == null) {
+ args = new Object[0];
+ }
+ LispObject[] lispArgs = new LispObject[args.length + 2];
+ synchronized(proxyMap) {
+ lispArgs[0] = toLispObject(proxyMap.get(proxy));
+ }
+ lispArgs[1] = new SimpleString(method.getName());
+ for(int i = 0; i < args.length; i++) {
+ lispArgs[i + 2] = toLispObject(args[i]);
+ }
+ Object retVal = (function.execute(lispArgs)).javaInstance();
+ /* DOES NOT WORK due to autoboxing!
+ if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) {
+ return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType())));
+ }*/
+ return retVal;
+ }
+ }
+
+ private static final Primitive _JMAKE_INVOCATION_HANDLER =
+ new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false,
+ "function") {
+
+ public LispObject execute(LispObject[] args) throws ConditionThrowable {
+ int length = args.length;
+ if (length != 1) {
+ return error(new WrongNumberOfArgumentsException(this));
+ }
+ if(!(args[0] instanceof Function)) {
+ return error(new TypeError(args[0], Symbol.FUNCTION));
+ }
+ return new JavaObject(new LispInvocationHandler((Function) args[0]));
+ }
+ };
+
+ private static final Primitive _JMAKE_PROXY =
+ new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
+ "interface invocation-handler") {
+
+ public LispObject execute(final LispObject[] args) throws ConditionThrowable {
+ int length = args.length;
+ if (length != 3) {
+ return error(new WrongNumberOfArgumentsException(this));
+ }
+ if(!(args[0] instanceof JavaObject) ||
+ !(((JavaObject) args[0]).javaInstance() instanceof Class)) {
+ return error(new TypeError(args[0], new SimpleString(Class.class.getName())));
+ }
+ if(!(args[1] instanceof JavaObject) ||
+ !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) {
+ return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName())));
+ }
+ Class<?> iface = (Class<?>) ((JavaObject) args[0]).javaInstance();
+ InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance();
+ Object proxy = Proxy.newProxyInstance(
+ iface.getClassLoader(),
+ new Class[] { iface },
+ invocationHandler);
+ synchronized(proxyMap) {
+ proxyMap.put(proxy, args[2]);
+ }
+ return new JavaObject(proxy);
+ }
+ };
+
+ private static LispObject toLispObject(Object obj) {
+ return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj);
+ }
+
}
Modified: trunk/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Java.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun Jan 25 23:34:24 2009
@@ -33,14 +33,18 @@
package org.armedbear.lisp;
+import java.beans.BeanInfo;
+import java.beans.IntrospectionException;
+import java.beans.Introspector;
+import java.beans.PropertyDescriptor;
import java.lang.reflect.Array;
import java.lang.reflect.Constructor;
import java.lang.reflect.Field;
import java.lang.reflect.InvocationTargetException;
import java.lang.reflect.Method;
import java.lang.reflect.Modifier;
-import java.util.Map;
import java.util.HashMap;
+import java.util.Map;
public final class Java extends Lisp
{
@@ -722,7 +726,72 @@
return makeLispObject(arg.javaInstance());
}
};
-
+
+ private static final Primitive JGET_PROPERTY_VALUE =
+ new Primitive("%jget-property-value", PACKAGE_JAVA, true,
+ "java-object property-name") {
+
+ public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable {
+ try {
+ Object obj = javaObject.javaInstance();
+ PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+ Object value = pd.getReadMethod().invoke(obj);
+ if(value instanceof LispObject) {
+ return (LispObject) value;
+ } else if(value != null) {
+ return new JavaObject(value);
+ } else {
+ return NIL;
+ }
+ } catch (Exception e) {
+ ConditionThrowable t = new ConditionThrowable("Exception reading property");
+ t.initCause(e);
+ throw t;
+ }
+ }
+ };
+
+ private static final Primitive JSET_PROPERTY_VALUE =
+ new Primitive("%jset-property-value", PACKAGE_JAVA, true,
+ "java-object property-name value") {
+
+ public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable {
+ Object obj = null;
+ try {
+ obj = javaObject.javaInstance();
+ PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+ Object jValue;
+ if(value == NIL) {
+ if(Boolean.TYPE.equals(pd.getPropertyType()) ||
+ Boolean.class.equals(pd.getPropertyType())) {
+ jValue = false;
+ } else {
+ jValue = null;
+ }
+ } else {
+ jValue = value.javaInstance();
+ }
+ pd.getWriteMethod().invoke(obj, jValue);
+ return value;
+ } catch (Exception e) {
+ ConditionThrowable t = new ConditionThrowable("Exception writing property " + propertyName.writeToString() + " in object " + obj + " to " + value.writeToString());
+ t.initCause(e);
+ throw t;
+ }
+ }
+ };
+
+ private static PropertyDescriptor getPropertyDescriptor(Object obj, LispObject propertyName) throws ConditionThrowable, IntrospectionException {
+ String prop = ((AbstractString) propertyName).getStringValue();
+ BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass());
+ for(PropertyDescriptor pd : beanInfo.getPropertyDescriptors()) {
+ if(pd.getName().equals(prop)) {
+ return pd;
+ }
+ }
+ throw new ConditionThrowable("Property " + prop + " not found in " + obj);
+ }
+
private static Class classForName(String className) throws ConditionThrowable
{
try {
Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Sun Jan 25 23:34:24 2009
@@ -51,7 +51,11 @@
@Override
public LispObject classOf()
{
- return BuiltInClass.JAVA_OBJECT;
+ if(obj == null) {
+ return BuiltInClass.JAVA_OBJECT;
+ } else {
+ return JavaClass.findJavaClass(obj.getClass());
+ }
}
@Override
@@ -61,6 +65,9 @@
return T;
if (type == BuiltInClass.JAVA_OBJECT)
return T;
+ if(type instanceof JavaClass && obj != null) {
+ return ((JavaClass) type).getJavaClass().isAssignableFrom(obj.getClass()) ? T : NIL;
+ }
return super.typep(type);
}
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 Jan 25 23:34:24 2009
@@ -101,8 +101,9 @@
public Object javaInstance() throws ConditionThrowable
{
- return error(new LispError("The value " + writeToString() +
- " is not of primitive type."));
+ return this;
+ /*return error(new LispError("The value " + writeToString() +
+ " is not of primitive type."));*/
}
public Object javaInstance(Class c) throws ConditionThrowable
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 Jan 25 23:34:24 2009
@@ -123,6 +123,9 @@
public static final StandardClass BUILT_IN_CLASS =
addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS));
+ public static final StandardClass JAVA_CLASS =
+ addStandardClass(Symbol.JAVA_CLASS, list1(CLASS));
+
public static final StandardClass FORWARD_REFERENCED_CLASS =
addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS));
@@ -280,6 +283,8 @@
list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS")))));
BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT,
BuiltInClass.CLASS_T);
+ JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
STANDARD_OBJECT, BuiltInClass.CLASS_T);
CELL_ERROR.setDirectSlotDefinitions(
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 Jan 25 23:34:24 2009
@@ -2899,6 +2899,8 @@
PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE");
public static final Symbol JAVA_OBJECT =
PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT");
+ public static final Symbol JAVA_CLASS =
+ PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS");
public static final Symbol JCALL =
PACKAGE_JAVA.addExternalSymbol("JCALL");
public static final Symbol JCALL_RAW =
Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sun Jan 25 23:34:24 2009
@@ -199,6 +199,12 @@
(autoload 'jregister-handler "java")
(export 'jinterface-implementation "JAVA")
(autoload 'jinterface-implementation "java")
+(export 'jmake-invocation-handler "JAVA")
+(autoload 'jmake-invocation-handler "java")
+(export 'jmake-proxy "JAVA")
+(autoload 'jmake-proxy "java")
+(export 'jproperty-value "JAVA")
+(autoload 'jproperty-value "java")
(export 'jobject-class "JAVA")
(autoload 'jobject-class "java")
(export 'jclass-superclass "JAVA")
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 Jan 25 23:34:24 2009
@@ -908,6 +908,13 @@
(eq (car object) 'quote))
(setf object (cadr object)))
(intern-eql-specializer object)))
+ ((and (consp specializer)
+ (eq (car specializer) 'java:jclass))
+ (let ((class-name (cadr specializer)))
+ (when (and (consp class-name)
+ (eq (car class-name) 'quote))
+ (setf class-name (cadr class-name)))
+ (java::%find-java-class class-name)))
(t
(error "Unknown specializer: ~S" specializer))))
Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp Sun Jan 25 23:34:24 2009
@@ -75,6 +75,64 @@
(push method-name method-names-and-defs)))
(apply #'%jnew-proxy interface method-names-and-defs)))
+(defun jmake-invocation-handler (function)
+ (%jmake-invocation-handler function))
+
+(when (autoloadp 'jmake-proxy)
+ (fmakunbound 'jmake-proxy))
+
+(defgeneric jmake-proxy (interface implementation &optional lisp-this)
+ (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters."))
+
+(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
+ "Basic implementation that directly uses an invocation handler."
+ (%jmake-proxy (jclass interface) invocation-handler lisp-this))
+
+(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
+ "Implements a Java interface forwarding method calls to a Lisp function."
+ (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
+
+(defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
+ "Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function."
+ (flet ((java->lisp (name)
+ (with-output-to-string (str)
+ (let ((last-lower-p nil))
+ (map nil (lambda (char)
+ (let ((upper-p (char= (char-upcase char) char)))
+ (when (and last-lower-p upper-p)
+ (princ "-" str))
+ (setf last-lower-p (not upper-p))
+ (princ (char-upcase char) str)))
+ name)))))
+ (%jmake-proxy (jclass interface)
+ (jmake-invocation-handler
+ (lambda (obj method &rest args)
+ (let ((sym (find-symbol
+ (java->lisp method)
+ implementation)))
+ (unless sym
+ (error "Symbol ~A, implementation of method ~A, not found in ~A"
+ (java->lisp method)
+ method
+ implementation))
+ (if (fboundp sym)
+ (apply (symbol-function sym) obj method args)
+ (error "Function ~A, implementation of method ~A, not found in ~A"
+ sym method implementation)))))
+ lisp-this)))
+
+(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
+ "Implements a Java interface using closures in an hash-table keyed by Java method name."
+ (%jmake-proxy (jclass interface)
+ (jmake-invocation-handler
+ (lambda (obj method &rest args)
+ (let ((fn (gethash method implementation)))
+ (if fn
+ (apply fn obj args)
+ (error "Implementation for method ~A not found in ~A"
+ method implementation)))))
+ lisp-this))
+
(defun jobject-class (obj)
"Returns the Java class that OBJ belongs to"
(jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -232,4 +290,10 @@
(t
(error "Unknown load-from for ~A" class-name)))))
+(defun jproperty-value (obj prop)
+ (%jget-property-value obj prop))
+
+(defun (setf jproperty-value) (value obj prop)
+ (%jset-property-value obj prop value))
+
(provide "JAVA-EXTENSIONS")
Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sun Jan 25 23:34:24 2009
@@ -50,6 +50,9 @@
(format stream "~S" (class-name (class-of object))))
object)
+(defmethod print-object ((class java:java-class) stream)
+ (write-string (%write-to-string class) stream))
+
(defmethod print-object ((class class) stream)
(print-unreadable-object (class stream :identity t)
(format stream "~S ~S"
More information about the armedbear-cvs
mailing list