Changeset 11454

Timestamp:

Dec 2, 2008, 3:10:56 PM (12 years ago)

Author:

gb

Message:

Do the foreign-object-domain initialization more sanely.
JNI wrapper functions treat NULL args as +null-ptr+, return null pointers
as NIL.

File:

• trunk/source/examples/jfli/jni.lisp (modified) (13 diffs)

trunk/source/examples/jfli/jni.lisp

@@ -63 +63 @@
     ())
 
-(ccl::defloadvar *java-object-domain*
-    (ccl::register-foreign-object-domain :java
-                                         :recognize #'ccl::false
-                                         :class-of (lambda (x)
-                                                     (declare (ignore x))
-                                                     (find-class 'java-object))
-                                         :classp #'ccl::false
-                                         :instance-class-wrapper
-                                         (lambda (x)
-                                           (declare (ignore x))
-                                           (ccl::class-own-wrapper
-                                            (find-class 'java-object)))
-                                         :class-own-wrapper
-                                         #'ccl::false
-                                         :slots-vector #'ccl::false
-                                         :class-ordinal #'ccl::false
-                                         :set-class-ordinal
-                                         #'ccl::false))
+(ccl::defloadvar *java-object-domain* nil)
+
+(or *java-object-domain*
+    (setq *java-object-domain*
+          (ccl::register-foreign-object-domain :java
+                                               :recognize #'ccl::false
+                                               :class-of (lambda (x)
+                                                           (declare (ignore x))
+                                                           (find-class 'java-object))
+                                               :classp #'ccl::false
+                                               :instance-class-wrapper
+                                               (lambda (x)
+                                                 (declare (ignore x))
+                                                 (ccl::class-own-wrapper
+                                                  (find-class 'java-object)))
+                                               :class-own-wrapper
+                                               #'ccl::false
+                                               :slots-vector #'ccl::false
+                                               :class-ordinal #'ccl::false
+                                               :set-class-ordinal
+                                               #'ccl::false)))
 
 (deftype java-ref () 'java-object)
@@ -109 +112 @@
 ;;; Map between lisp and Java booleans
 (eval-when (:compile-toplevel)
-  (declaim (inline jboolean-arg jboolean-result jobject-result)))
+  (declaim (inline jboolean-arg jboolean-result jobject-result jobject-arg)))
 
 (defun jboolean-arg (val)
@@ -116 +119 @@
     #$JNI_FALSE))
 
+(defun jobject-arg (val)
+  (or val ccl::+null-ptr+))
+
+
 (defun jboolean-result (val)
   (not (eql val #$JNI_FALSE)))
@@ -122 +129 @@
 (defun jobject-result (val)
   (unless (ccl::%null-ptr-p val)
-    (ccl::%set-macptr-domain val *java-object-domain*))
-  val)
+    (ccl::%set-macptr-domain val *java-object-domain*)
+    val))
 
 
@@ -168 +175 @@
 ;;; JNIEnv functions.
 
+(defun process-jnienv-call-args (specs)
+  (ccl::collect ((args))
+    (do* ((specs specs (cddr specs)))
+         ((null specs) (args))
+      (let* ((type (car specs))
+             (valform (cadr specs)))
+        (args type)
+        (case type
+          (:jboolean (args `(jboolean-arg ,valform)))
+          ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray
+                     #>jbyteArray #>jcharArray #>jshortArray #>jintArray
+                     #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray)
+           (args `(jobject-arg ,valform)))
+          (t (args valform)))))))
+  
 (defmacro jnienv-call ((slot result-type) &rest specs)
   ;; We might want to special-case some result-types for finalization.
@@ -174 +196 @@
          (form
           `(let* ((,env (current-env)))
-            (ff-call (pref ,env ,accessor) :address ,env ,@specs ,result-type))))
+            (ff-call (pref ,env ,accessor) :address ,env ,@(process-jnienv-call-args specs) ,result-type))))
     (case result-type
       (:jboolean `(jboolean-result ,form))
@@ -211 +233 @@
                :jclass cls
                #>jmethodID method-id
-               :jboolean (jboolean-arg is-static)))
+               :jboolean is-static))
 
 (defun get-superclass (sub)
@@ -225 +247 @@
                :jclass cls
                #>jfieldID field-id
-               :jboolean (jboolean-arg is-static)))
+               :jboolean is-static))
 
 (defun jni-throw (obj)
@@ -490 +512 @@
                :jobject obj
                #>jfieldID field-id
-               :jboolean (jboolean-arg val)))
+               :jboolean val))
 
 (defun set-byte-field (obj field-id val)
@@ -669 +691 @@
                :jclass clazz
                #>jfieldID field-id
-               :jboolean (jboolean-arg value)))
+               :jboolean value))
 
 (defun set-static-byte-field (clazz field-id value)
@@ -1156 +1178 @@
 (defcallback |LispInvocationHandler_invoke|
     (:address env :jobject obj :jobject proxy :jobject method :jobject args :jobject)
-  (do-invoke env obj proxy method args))
+  (jobject-result obj)
+  (jobject-result proxy)
+  (jobject-result method)
+  (jobject-result args)
+  (jobject-arg 
+   (do-invoke env obj proxy method args)))
 
 
@@ -1175 +1202 @@
 ;so take advantage of that when possible vs. the call back to exception-check
 (defun try-null (result)
-  (if (ccl:%null-ptr-p result)
+  (if (or (null result) (ccl:%null-ptr-p result))
       (handle-exception)
     result))
@@ -1257 +1284 @@
 (defun process-arg (val type)
   (if (string-equal "java.lang.String" type)
-                 `(convert-string-arg ,val)
-                 val))
+    `(convert-string-arg ,val)
+    `(or ,val ccl::+null-ptr+)))
 
 (defmacro set-arg (args i val type)