[armedbear-cvs] r11450 - in branches/scripting/j/src/org/armedbear/lisp: . scripting scripting/lisp
Alessio Stalla
astalla at common-lisp.net
Mon Dec 15 03:31:06 UTC 2008
Author: astalla
Date: Mon Dec 15 03:31:04 2008
New Revision: 11450
Log:
JavaBean property support (jproperty-value)
Minor code cleanup
Started jinterface-impl registration support on the Lisp side
Modified:
branches/scripting/j/src/org/armedbear/lisp/JProxy.java
branches/scripting/j/src/org/armedbear/lisp/Java.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/AbclScriptEngineFactory.java
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp
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 Mon Dec 15 03:31:04 2008
@@ -124,6 +124,9 @@
//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 {
Modified: branches/scripting/j/src/org/armedbear/lisp/Java.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Java.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/Java.java Mon Dec 15 03:31:04 2008
@@ -21,14 +21,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
{
@@ -691,7 +695,53 @@
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);
+ return new JavaObject(pd.getReadMethod().invoke(obj));
+ } catch (Exception e) {
+ ConditionThrowable t = new ConditionThrowable("Exception in accessing 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 {
+ try {
+ Object obj = javaObject.javaInstance();
+ PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+ pd.getWriteMethod().invoke(obj, value.javaInstance());
+ return value;
+ } catch (Exception e) {
+ ConditionThrowable t = new ConditionThrowable("Exception in accessing property");
+ 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: 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 Mon Dec 15 03:31:04 2008
@@ -191,6 +191,8 @@
(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: 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 Mon Dec 15 03:31:04 2008
@@ -278,4 +278,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: 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 Mon Dec 15 03:31:04 2008
@@ -328,10 +328,6 @@
return new AbclScriptEngineFactory();
}
- public static String decoratedVariableName(String jvar) {
- return jvar.toUpperCase();
- }
-
private static Object toJava(LispObject lispObject) throws ConditionThrowable {
return lispObject.javaInstance();
}
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Mon Dec 15 03:31:04 2008
@@ -78,10 +78,10 @@
sb.append("(jcall \"");
sb.append(method);
sb.append("\" ");
- sb.append(AbclScriptEngine.decoratedVariableName(obj));
+ sb.append(obj);
for(String arg : args) {
sb.append(" ");
- sb.append(AbclScriptEngine.decoratedVariableName(arg));
+ sb.append(arg);
}
sb.append(")");
return sb.toString();
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 Mon Dec 15 03:31:04 2008
@@ -86,4 +86,23 @@
(let ((*package* (find-package :abcl-script-user)))
(eval `(compile nil
(lambda ()
- ,@(read-from-string (concatenate 'string "(" code-string ")")))))))
\ No newline at end of file
+ ,@(read-from-string (concatenate 'string "(" code-string ")")))))))
+
+
+;;Java interface implementation
+
+(defvar *interface-implementation-map* (make-hash-table :test #'equal))
+
+(defun find-java-interface-implementation (interface)
+ (gethash interface *interface-implementation-map*))
+
+(defun register-java-interface-implementation (interface impl)
+ (setf (gethash interface *interface-implementation-map*) impl))
+
+(defun remove-java-interface-implementation (interface)
+ (remhash interface *interface-implementation-map*))
+
+(defun define-java-interface-implementation (interface implementation &optional lisp-this)
+ (register-java-interface-implementation
+ interface
+ (jmake-proxy interface implementation lisp-this)))
\ No newline at end of file
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp Mon Dec 15 03:31:04 2008
@@ -23,7 +23,8 @@
#:eval-compiled-script
#:define-java-interface-implementation
#:find-java-interface-implementation
- #:implement-java-interface))
+ #:register-java-interface-implementation
+ #:remove-java-interface-implementation))
(defpackage :abcl-script-user
(:use :cl :ext :java :abcl-script))
\ No newline at end of file
More information about the armedbear-cvs
mailing list