[armedbear-cvs] r11379 - in branches/scripting/j/src/org/armedbear/lisp: . scripting/lisp
Alessio Stalla
astalla at common-lisp.net
Wed Nov 5 20:20:58 UTC 2008
Author: astalla
Date: Wed Nov 5 20:20:57 2008
New Revision: 11379
Log:
jmake-proxy now is a generic function. A couple of simple methods are provided. TBD: automagic proxy generation from functions in a package.
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/autoloads.lisp
branches/scripting/j/src/org/armedbear/lisp/java.lisp
branches/scripting/j/src/org/armedbear/lisp/print-object.lisp
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 Wed Nov 5 20:20:57 2008
@@ -488,7 +488,6 @@
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, "%find-java-class", "JavaClass");
autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
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 Wed Nov 5 20:20:57 2008
@@ -221,80 +221,6 @@
private static LispObject toLispObject(Object obj) {
return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj);
- }
-
- 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/autoloads.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp Wed Nov 5 20:20:57 2008
@@ -187,8 +187,6 @@
(autoload 'jregister-handler "java")
(export 'jinterface-implementation "JAVA")
(autoload 'jinterface-implementation "java")
-(export 'jimplement-interface "JAVA")
-(autoload 'jimplement-interface "java")
(export 'jmake-invocation-handler "JAVA")
(autoload 'jmake-invocation-handler "java")
(export 'jmake-proxy "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 Wed Nov 5 20:20:57 2008
@@ -63,53 +63,47 @@
(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 jmake-invocation-handler (function)
(%jmake-invocation-handler function))
-(defun jmake-proxy (interface invocation-handler)
- (let ((handler (if (functionp invocation-handler)
- (jmake-invocation-handler invocation-handler)
- invocation-handler)))
- (%jmake-proxy (jclass interface) handler)))
+(when (autoloadp 'jmake-proxy)
+ (fmakunbound 'jmake-proxy))
+
+(defgeneric jmake-proxy (interface implementation))
+
+;(defun jmake-proxy (interface implementation)
+; (jmake-proxy-impl interface implementation))
+
+(defmethod jmake-proxy (interface invocation-handler)
+ (%jmake-proxy (jclass interface) invocation-handler))
+
+(defmethod jmake-proxy (interface (implementation function))
+ (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation)))
+
+#|
+TODO java->lisp wrong (coding at night has nasty effects)
+(defmethod jmake-proxy (interface (implementation package))
+ (flet ((java->lisp (name)
+ (substitute #\- #\. (string-upcase name))))
+ (%jmake-proxy (jclass interface)
+ (jmake-invocation-handler
+ (lambda (obj method &rest args)
+ (let* ((sym (find-symbol (java->lisp (jmethod-name method))))
+ (fn (symbol-function sym)))
+ (if fn
+ (apply fn obj args)
+ (error "Function ~A, implementation of method ~A, not found in ~A"
+ sym (jmethod-name method) implementation))))))))
+|#
+(defmethod jmake-proxy (interface (implementation hash-table))
+ (%jmake-proxy (jclass interface)
+ (jmake-invocation-handler
+ (lambda (obj method &rest args)
+ (let ((fn (gethash (jmethod-name method) implementation)))
+ (if fn
+ (apply fn obj args)
+ (error "Implementation for method ~A not found in ~A"
+ (jmethod-name method) implementation)))))))
(defun jobject-class (obj)
"Returns the Java class that OBJ belongs to"
Modified: branches/scripting/j/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/print-object.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/print-object.lisp Wed Nov 5 20:20:57 2008
@@ -37,6 +37,9 @@
(format stream "~S" (class-name (class-of object))))
object)
+(defmethod print-object ((class java:java-class) stream)
+ (write-string (%write-to-string object) stream))
+
(defmethod print-object ((class class) stream)
(print-unreadable-object (class stream :identity t)
(format stream "~S ~S"
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 Wed Nov 5 20:20:57 2008
@@ -71,32 +71,4 @@
,@(generate-java-bindings
engine-bindings
actual-engine-bindings
- (jcall +get-bindings+ script-context +engine-scope+)))))))))
-
-(defstruct (java-interface-implementation (:type list))
- (method-definitions (list) :type list))
-
-(defun define-java-interface-implementation (interface &rest method-definitions)
- (register-java-interface-implementation
- (canonicalize-interface interface)
- (make-java-interface-implementation :method-definitions method-definitions)))
-
-(defun canonicalize-interface (interface)
- (cond
- ((stringp interface) interface)
- ((jclass-interface-p interface) (jclass-name interface))
- (t (error "not an interface: ~A" interface))))
-
-(defun register-java-interface-implementation (interface implementation)
- (setf (gethash (canonicalize-interface interface)
- *java-interface-implementations*)
- (implement-java-interface interface implementation)))
-
-(defun find-java-interface-implementation (interface)
- (gethash (canonicalize-interface interface)
- *java-interface-implementations*))
-
-(defun implement-java-interface (interface implementation)
- (apply #'jimplement-interface
- `(,interface
- ,@(java-interface-implementation-method-definitions implementation))))
\ No newline at end of file
+ (jcall +get-bindings+ script-context +engine-scope+)))))))))
\ No newline at end of file
More information about the armedbear-cvs
mailing list