[armedbear-cvs] r11368 - in branches/scripting/j/src/org/armedbear/lisp: . scripting scripting/lisp scripting/lisp/test
Alessio Stalla
astalla at common-lisp.net
Tue Oct 28 21:16:06 UTC 2008
Author: astalla
Date: Tue Oct 28 21:16:05 2008
New Revision: 11368
Log:
New jimplement-interface functionality allowing some sort of limited single-dispatch OO. Changed LispObject.javaObject() to return this instead of signaling an error.
Removed:
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/test/
Modified:
branches/scripting/j/src/org/armedbear/lisp/Autoload.java
branches/scripting/j/src/org/armedbear/lisp/JProxy.java
branches/scripting/j/src/org/armedbear/lisp/LispObject.java
branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp
branches/scripting/j/src/org/armedbear/lisp/java.lisp
branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
Modified: branches/scripting/j/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Autoload.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/Autoload.java Tue Oct 28 21:16:05 2008
@@ -488,6 +488,7 @@
autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true);
autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
+ autoload(PACKAGE_JAVA, "%jimplement-interface", "JProxy");
autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");
Modified: branches/scripting/j/src/org/armedbear/lisp/JProxy.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/JProxy.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/JProxy.java Tue Oct 28 21:16:05 2008
@@ -121,4 +121,83 @@
return null;
}
}
+
+ //NEW IMPLEMENTATION by Alessio Stalla
+
+
+
+ private static final Primitive _JIMPLEMENT_INTERFACE =
+ new Primitive("%jimplement-interface", PACKAGE_JAVA, false,
+ "interface &rest method-names-and-defs") {
+
+ public LispObject execute(LispObject[] args) throws ConditionThrowable {
+ int length = args.length;
+ if (length < 3 || length % 2 != 1) {
+ return error(new WrongNumberOfArgumentsException(this));
+ }
+ final Map<String,Function> lispDefinedMethods = new HashMap<String,Function>();
+ for (int i = 1; i < length; i += 2) {
+ lispDefinedMethods.put(args[i].getStringValue(), (Function) args[i + 1]);
+ }
+ final Class<?> iface = (Class<?>) args[0].javaInstance();
+ return new Function() {
+
+ public LispObject execute(LispObject lispProxy) {
+ Object proxy = Proxy.newProxyInstance(
+ iface.getClassLoader(),
+ new Class[] { iface },
+ new LispHandler2(lispProxy, lispDefinedMethods));
+ return new JavaObject(proxy);
+ }
+
+ };
+
+ }
+ };
+
+ private static class LispHandler2 implements InvocationHandler {
+
+ private Map<String, Function> lispDefinedMethods;
+ private LispObject lispProxy;
+
+ LispHandler2(LispObject lispProxy, Map<String, Function> lispDefinedMethods) {
+ this.lispProxy = lispProxy;
+ this.lispDefinedMethods = lispDefinedMethods;
+ }
+
+ public Object invoke(Object proxy, Method method, Object[] args) throws ConditionThrowable {
+ String methodName = method.getName();
+
+ //TODO are these implemented correctly?
+ if(methodName.equals("hashCode")) {
+ return lispProxy.hashCode();
+ }
+ if (methodName.equals("equals")) {
+ return (args[0] instanceof LispObject) && (T == lispProxy.EQ((LispObject) args[0]));
+ }
+ if (methodName.equals("toString")) {
+ return lispProxy.writeToString();
+ }
+
+ Function f = lispDefinedMethods.get(methodName);
+ if (f != null) {
+ try {
+ LispObject lispArgs = NIL;
+ if (args != null) {
+ for (int i = args.length - 1 ; 0 <= i ; i--) {
+ lispArgs = lispArgs.push(new JavaObject(args[i]));
+ }
+ }
+ lispArgs = lispArgs.push(lispProxy);
+ LispObject result = evalCall(f, lispArgs, new Environment(),
+ LispThread.currentThread());
+ return (method.getReturnType() == void.class ? null : result.javaInstance());
+ } catch (ConditionThrowable t) {
+ t.printStackTrace();
+ }
+ }
+ return null;
+ }
+ }
+
}
Modified: branches/scripting/j/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/LispObject.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/LispObject.java Tue Oct 28 21:16:05 2008
@@ -85,8 +85,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: branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp Tue Oct 28 21:16:05 2008
@@ -187,6 +187,8 @@
(autoload 'jregister-handler "java")
(export 'jinterface-implementation "JAVA")
(autoload 'jinterface-implementation "java")
+(export 'jimplement-interface "JAVA")
+(autoload 'jimplement-interface "java")
(export 'jobject-class "JAVA")
(autoload 'jobject-class "java")
(export 'jclass-superclass "JAVA")
Modified: branches/scripting/j/src/org/armedbear/lisp/java.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/java.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/java.lisp Tue Oct 28 21:16:05 2008
@@ -63,6 +63,45 @@
(push method-name method-names-and-defs)))
(apply #'%jnew-proxy interface method-names-and-defs)))
+(defun jimplement-interface (interface &rest method-names-and-defs)
+ "Creates and returns an implementation of a Java interface with
+ methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
+
+ INTERFACE is either a Java interface or a string naming one.
+
+ METHOD-NAMES-AND-DEFS is an alternating list of method names
+ (strings) and method definitions (closures).
+
+ For missing methods, a dummy implementation is provided that
+ returns nothing or null depending on whether the return type is
+ void or not. This is for convenience only, and a warning is issued
+ for each undefined method."
+ (let ((interface (jclass interface))
+ (implemented-methods
+ (loop for m in method-names-and-defs
+ for i from 0
+ if (evenp i)
+ do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
+ else
+ do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))
+ (null (make-immediate-object nil :ref)))
+ (loop for method across
+ (jclass-methods interface :declared nil :public t)
+ for method-name = (jmethod-name method)
+ when (not (member method-name implemented-methods :test #'string=))
+ do
+ (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void"))
+ (arglist '(&rest ignore))
+ (def `(lambda
+ ,arglist
+ ,(when arglist '(declare (ignore ignore)))
+ ,(if void-p '(values) null))))
+ (warn "Implementing dummy method ~a for interface ~a"
+ method-name (jclass-name interface))
+ (push (coerce def 'function) method-names-and-defs)
+ (push method-name method-names-and-defs)))
+ (apply #'%jimplement-interface interface method-names-and-defs)))
+
(defun jobject-class (obj)
"Returns the Java class that OBJ belongs to"
(jcall (jmethod "java.lang.Object" "getClass") obj))
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Tue Oct 28 21:16:05 2008
@@ -36,7 +36,6 @@
import javax.script.ScriptException;
import javax.script.SimpleBindings;
-import org.armedbear.lisp.AbstractString;
import org.armedbear.lisp.Bignum;
import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.Cons;
@@ -51,6 +50,7 @@
import org.armedbear.lisp.LispObject;
import org.armedbear.lisp.LispThread;
import org.armedbear.lisp.SimpleString;
+import org.armedbear.lisp.SimpleVector;
import org.armedbear.lisp.SingleFloat;
import org.armedbear.lisp.Stream;
import org.armedbear.lisp.Symbol;
@@ -336,7 +336,45 @@
}
public static LispObject toLisp(Object javaObject) {
- if(javaObject instanceof LispObject) {
+ if(javaObject == null) {
+ return Lisp.NIL;
+ } else if(javaObject instanceof Boolean) {
+ return ((Boolean)javaObject).booleanValue() ? Lisp.T : Lisp.NIL;
+ } else if(javaObject instanceof Byte) {
+ return new Fixnum(((Byte)javaObject).intValue());
+ } else if(javaObject instanceof Integer) {
+ return new Fixnum(((Integer)javaObject).intValue());
+ } else if(javaObject instanceof Short) {
+ return new Fixnum(((Short)javaObject).shortValue());
+ } else if(javaObject instanceof Long) {
+ return new Bignum((Long)javaObject);
+ } else if(javaObject instanceof BigInteger) {
+ return new Bignum((BigInteger) javaObject);
+ } else if(javaObject instanceof Float) {
+ return new SingleFloat(((Float)javaObject).floatValue());
+ } else if(javaObject instanceof Double) {
+ return new DoubleFloat(((Double)javaObject).doubleValue());
+ } else if(javaObject instanceof String) {
+ return new SimpleString((String)javaObject);
+ } else if(javaObject instanceof Character) {
+ return LispCharacter.getInstance((Character)javaObject);
+ } else if(javaObject instanceof Object[]) {
+ Object[] array = (Object[]) javaObject;
+ SimpleVector v = new SimpleVector(array.length);
+ for(int i = array.length; i > 0; --i) {
+ try {
+ v.aset(i, new JavaObject(array[i]));
+ } catch (ConditionThrowable e) {
+ throw new Error("Can't set simplevector index " + i, e);
+ }
+ }
+ return v;
+ } else if(javaObject instanceof LispObject) {
+ return (LispObject) javaObject;
+ } else {
+ return new JavaObject(javaObject);
+ }
+ /*if(javaObject instanceof LispObject) {
return (LispObject) javaObject;
} else if(javaObject instanceof Float) {
return new SingleFloat((Float) javaObject);
@@ -354,32 +392,26 @@
return new SimpleString((String) javaObject);
} else {
return new JavaObject(javaObject);
- }
+ }*/
}
@SuppressWarnings("unchecked")
@Override
public <T> T getInterface(Class<T> clasz) {
- try {
- Symbol s = findSymbol("find-java-interface-implementation", "abcl-script");
- Object obj = s.getSymbolFunction().execute(new JavaObject(clasz));
- if(obj instanceof JavaObject) {
- return (T) ((JavaObject) obj).getObject();
- } else {
- return null;
- }
- } catch (ConditionThrowable e) {
- throw new Error(e);
- }
+ return getInterface(Lisp.NIL, clasz);
}
@SuppressWarnings("unchecked")
@Override
public <T> T getInterface(Object thiz, Class<T> clasz) {
try {
- Symbol s = findSymbol("implement-java-interface", "abcl-script");
- Object obj = s.getSymbolFunction().execute(new JavaObject(clasz), (LispObject) thiz);
- return (T) ((JavaObject) obj).getObject();
+ Symbol s = findSymbol("find-java-interface-implementation", "abcl-script");
+ Object obj = s.getSymbolFunction().execute(new JavaObject(clasz));
+ if(obj instanceof Function) {
+ return (T) ((JavaObject) ((Function) obj).execute((LispObject) thiz)).getObject();
+ } else {
+ return null;
+ }
} catch (ConditionThrowable e) {
throw new Error(e);
}
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Tue Oct 28 21:16:05 2008
@@ -97,6 +97,6 @@
*java-interface-implementations*))
(defun implement-java-interface (interface implementation)
- (apply #'jinterface-implementation
+ (apply #'jimplement-interface
`(,interface
,@(java-interface-implementation-method-definitions implementation))))
\ No newline at end of file
More information about the armedbear-cvs
mailing list