Ignore:
Timestamp:
Nov 29, 2008, 8:34:18 AM (11 years ago)
Author:
gb
Message:

java foreign-object-domain stuff. Some fixes/changes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/examples/jfli/jni.lisp

    r11442 r11447  
    5252   :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field
    5353   :jaref :convert-to-java-string :convert-from-java-string :java-ref-p
    54    :is-name-of-primitive :split-package-and-class))
     54   :is-name-of-primitive :split-package-and-class
     55   ;; Export JNIEnv function names, too
     56   :get-array-length :is-same-object :jni-find-class :is-assignable-from
     57   :delete-local-ref :new-object-array :new-int-array
     58   ))
    5559
    5660(in-package :jni)
     61
     62(defclass java-object (ccl::foreign-standard-object)
     63    ())
     64
     65(ccl::defloadvar *java-object-domain*
     66    (ccl::register-foreign-object-domain :java
     67                                         :recognize #'ccl::false
     68                                         :class-of (lambda (x)
     69                                                     (declare (ignore x))
     70                                                     (find-class 'java-object))
     71                                         :classp #'ccl::false
     72                                         :instance-class-wrapper
     73                                         (lambda (x)
     74                                           (declare (ignore x))
     75                                           (ccl::class-own-wrapper
     76                                            (find-class 'java-object)))
     77                                         :class-own-wrapper
     78                                         #'ccl::false
     79                                         :slots-vector #'ccl::false
     80                                         :class-ordinal #'ccl::false
     81                                         :set-class-ordinal
     82                                         #'ccl::false))
     83
     84(deftype java-ref () 'java-object)
     85
     86(defun java-ref-p (x)
     87  (and (eql (ccl::typecode x) target::subtag-macptr)
     88       (eql (ccl::%macptr-domain x) *java-object-domain*)))
     89
    5790
    5891(eval-when (:compile-toplevel :load-toplevel :execute)
    5992  (ccl:use-interface-dir :jni))
    6093
    61 (ccl::%register-type-ordinal-class (ccl::parse-foreign-type :jobject) 'jobject)
    62 (ccl::%register-type-ordinal-class (ccl::parse-foreign-type #>JavaVM) 'java-vm)
    63 
     94(defun string-append (&rest args)
     95  (declare (dynamic-extent args))
     96  (do* ((a args (cdr a)))
     97     ((null a) (apply #'concatenate 'string args))
     98    (let* ((arg (car a)))
     99      (unless (typep arg 'string)
     100        (setf (car a) (string arg))))))
    64101
    65102(defvar *jni-lib-path*
     
    72109;;; Map between lisp and Java booleans
    73110(eval-when (:compile-toplevel)
    74   (declaim (inline jboolean-arg jboolean-result)))
     111  (declaim (inline jboolean-arg jboolean-result jobject-result)))
    75112
    76113(defun jboolean-arg (val)
     
    81118(defun jboolean-result (val)
    82119  (not (eql val #$JNI_FALSE)))
     120
     121;;; Might also want to register p for termination (finalization).
     122(defun jobject-result (val)
     123  (unless (ccl::%null-ptr-p val)
     124    (ccl::%set-macptr-domain val *java-object-domain*))
     125  val)
    83126
    84127
     
    128171  ;; We might want to special-case some result-types for finalization.
    129172  (let* ((env (gensym))
    130          (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot))))
    131     `(let* ((,env (current-env)))
    132       (ff-call (pref ,env ,accessor) :address ,env ,@specs ,result-type))))
     173         (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot)))
     174         (form
     175          `(let* ((,env (current-env)))
     176            (ff-call (pref ,env ,accessor) :address ,env ,@specs ,result-type))))
     177    (case result-type
     178      (:jboolean `(jboolean-result ,form))
     179      ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray
     180                 #>jbyteArray #>jcharArray #>jshortArray #>jintArray
     181                 #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray)
     182       `(jobject-result ,form))
     183      (t form))))
     184                 
    133185
    134186(defun get-version ()
     
    147199    (jnienv-call ("FindClass" :jclass) :address cname)))
    148200
     201
    149202(defun from-reflected-method (method)
    150203  (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method))
     
    154207
    155208(defun to-reflected-method (cls method-id is-static)
     209 
    156210  (jnienv-call ("ToReflectedMethod" :jobject)
    157211               :jclass cls
     
    163217
    164218(defun is-assignable-from (sub sup)
    165   (jboolean-result
    166    (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup)))
     219 
     220  (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup))
    167221
    168222(defun to-reflected-field (cls field-id is-static)
     223 
    169224  (jnienv-call ("ToReflectedField" :jobject)
    170225               :jclass cls
     
    196251
    197252(defun pop-local-frame (result)
     253 
    198254  (jnienv-call ("PopLocalFrame" :jobject) :jobject result))
    199255
     
    208264
    209265(defun is-same-object (obj1 obj2)
    210   (jboolean-result
    211    (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2)))
     266 
     267  (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2))
    212268
    213269(defun new-local-ref (ref)
     270 
    214271  (jnienv-call ("NewLocalRef" :jobject) :jobject ref))
    215272
     
    225282
    226283(defun new-object-a (clazz method-id args)
     284 
    227285  (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args))
    228286
     
    230288  (jnienv-call ("GetObjectClass" :jclass) :jobject obj))
    231289
     290(defun is-instance-of (obj clazz)
     291 
     292  (jnienv-call ("IsInstanceOf" :jboolean) :jobject obj :jclass clazz))
     293
     294(defun get-method-id (clazz name sig)
     295  (ccl::with-utf-8-cstrs ((cname name)
     296                          (csig sig))
     297    (jnienv-call ("GetMethodID" #>jmethodID)
     298                 :jclass clazz :address cname :address csig)))
     299
    232300;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA.
    233301
     
    239307
    240308(defun call-boolean-method-a (obj method-id args)
    241   (jboolean-result
    242    (jnienv-call ("CallBooleanMethodA" :jboolean)
    243                :jobject obj
    244                #>jmethodID method-id
    245                (:* :jvalue) args)))
     309 
     310  (jnienv-call ("CallBooleanMethodA" :jboolean)
     311               :jobject obj
     312               #>jmethodID method-id
     313               (:* :jvalue) args))
    246314
    247315(defun call-byte-method-a (obj method-id args)
     
    301369
    302370(defun call-nonvirtual-boolean-method-a (obj method-id args)
    303   (jboolean-result
    304    (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean)
    305                :jobject obj
    306                #>jmethodID method-id
    307                (:* :jvalue) args)))
     371 
     372  (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean)
     373               :jobject obj
     374               #>jmethodID method-id
     375               (:* :jvalue) args))
    308376
    309377(defun call-nonvirtual-byte-method-a (obj method-id args)
     
    365433
    366434(defun get-object-field (obj field-id)
     435 
    367436  (jnienv-call ("GetObjectField" :jobject)
    368437               :jobject obj
     
    370439
    371440(defun get-boolean-field (obj field-id)
    372   (jboolean-result
    373    (jnienv-call ("GetBooleanField" :jboolean)
    374                :jobject obj
    375                #>jfieldID field-id)))
     441 
     442  (jnienv-call ("GetBooleanField" :jboolean)
     443               :jobject obj
     444               #>jfieldID field-id))
    376445
    377446(defun get-byte-field (obj field-id)
     
    474543
    475544(defun call-static-object-method-a (clazz method-id args)
     545 
    476546  (jnienv-call ("CallStaticObjectMethodA" :jobject)
    477547               :jclass clazz
     
    480550
    481551(defun call-static-boolean-method-a (clazz method-id args)
    482   (jboolean-result
    483    (jnienv-call ("CallStaticBooleanMethodA" :jboolean)
    484                 :jclass clazz
    485                 #>jmethodID method-id
    486                 (:* :jvalue) args)))
     552 
     553  (jnienv-call ("CallStaticBooleanMethodA" :jboolean)
     554               :jclass clazz
     555               #>jmethodID method-id
     556               (:* :jvalue) args))
    487557
    488558(defun call-static-byte-method-a (clazz method-id args)
     
    548618
    549619(defun get-static-boolean-field (clazz field-id)
    550   (jboolean-result
    551    (jnienv-call ("GetStaticBooleanField" :jboolean)
    552                :jclass clazz
    553                #>jfieldID field-id)))
     620 
     621  (jnienv-call ("GetStaticBooleanField" :jboolean)
     622               :jclass clazz
     623               #>jfieldID field-id))
    554624
    555625(defun get-static-byte-field (clazz field-id)
     
    673743                               :jstring str
    674744                               (:* :jboolean) is-copy)))
    675       (values chars (jboolean-result (pref is-copy :jboolean))))))
     745      (values chars  (pref is-copy :jboolean)))))
    676746
    677747(defun release-string-utf-chars (str chars)
     
    10031073
    10041074(defun exception-check ()
    1005   (jboolean-result (jnienv-call ("ExceptionCheck" :jboolean))))
     1075  (jnienv-call ("ExceptionCheck" :jboolean)))
    10061076               
    10071077
     
    10801150  "this will be set by jfli:enable-java-proxies to a function of 3 args")
    10811151
    1082 #+todo
    1083 (progn
    10841152
    10851153
    10861154;;;this will be set as the implementation of a native java function
    1087 (fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type jobject)
    1088     ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobject))
     1155
     1156(defcallback |LispInvocationHandler_invoke|
     1157    (:address env :jobject obj :jobject proxy :jobject method :jobject args :jobject)
    10891158  (do-invoke env obj proxy method args))
     1159
    10901160
    10911161(defun do-invoke (env obj proxy method args)
     
    10971167      (delete-local-ref obj))))
    10981168
     1169(defun try (result)
     1170  (if (exception-check)
     1171      (handle-exception)
     1172    result))
     1173
     1174;JNI will sometimes indicate theere is an exception via a return value
     1175;so take advantage of that when possible vs. the call back to exception-check
     1176(defun try-null (result)
     1177  (if (ccl:%null-ptr-p result)
     1178      (handle-exception)
     1179    result))
     1180
    10991181(defun register-invocation-handler (invocation-handler)
    11001182  "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath"
    11011183  (setf *invocation-handler* invocation-handler)
    1102   (fli:with-dynamic-foreign-objects ((method jni-native-method))
     1184  (rlet ((method #>JNINativeMethod))
    11031185    (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler"))))
    1104       (fli:with-foreign-slots (name signature fn-ptr) method
    1105         (setf name (fli:convert-to-dynamic-foreign-string "invoke")
    1106               signature (fli:convert-to-dynamic-foreign-string "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;")
    1107               fn-ptr (fli:make-pointer :symbol-name "LispInvocationHandler_invoke")))
    1108       (register-natives lih method 1))))
     1186      (with-cstrs ((name "invoke")
     1187                   (signature "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;"))
     1188        (setf (pref method #>JNINativeMethod.name) name
     1189              (pref method #>JNINativeMethod.signature) signature
     1190              (pref method #>JNINativeMethod.fnPtr) |LispInvocationHandler_invoke|)
     1191      (register-natives lih method 1)))))
    11091192
    11101193
     
    11171200
    11181201;found on c.l.l
    1119 (eval-when (:compile-toplevel :load-toplevel)
     1202(eval-when (:compile-toplevel :load-toplevel :execute)
    11201203(defun replace-substrings (string substring replacement)
    11211204  (declare (optimize (speed 3))
     
    11381221  (when lref
    11391222    (let ((gref (new-global-ref lref)))
     1223      #+laster
    11401224      (flag-special-free-action gref)
    11411225      (delete-local-ref lref)
     
    11551239    (let ((chars (try-null (get-string-utf-chars s))))
    11561240      (prog1
    1157           (fli:convert-from-foreign-string chars :external-format :utf-8)
     1241          (ccl::%get-utf-8-cstring chars)
    11581242        (release-string-utf-chars s chars)))))
    11591243
     
    11771261
    11781262(defmacro set-arg (args i val type)
    1179   `(setf (fli:foreign-slot-value (fli:dereference (fli:foreign-array-pointer ,args ,i)
    1180                                                      :copy-foreign-object nil)
    1181                                     ',(slot-from-typename type))
    1182             ,(process-arg val type)))
     1263  `(setf (pref (paref ,args (:* :jvalue) ,i)
     1264          ,(jvalue-accessor-from-typename type))
     1265    ,(process-arg val type)))
    11831266
    11841267(defmacro with-arg-array (arg-array-name args &body body)
    11851268  (let ((i -1))
    1186   `(fli:with-dynamic-foreign-objects ()
    1187      (let ((,arg-array-name
    1188             (fli:allocate-dynamic-foreign-object :type
    1189                                                  '(:c-array jvalue ,(length args)))))
     1269  `(%stack-block ((,arg-array-name (*  ,(length args) (ccl::record-length :jvalue))))
    11901270       ,@(mapcar #'(lambda (arg)
    11911271                     (list 'set-arg arg-array-name (incf i) (first arg) (second arg)))
    11921272                 args)
    11931273
    1194        ,@body))))
     1274       ,@body)))
    11951275
    11961276(defun build-descriptor (params return-type)
     
    12501330        (rest prim)
    12511331      :l)))
     1332
     1333(defun jvalue-accessor-from-typename (tn)
     1334  (let ((prim (assoc tn
     1335                     '(("boolean" . :jvalue.z)
     1336                       ("byte" . :jvalue.b)
     1337                       ("char" . :jvalue.c)
     1338                       ("short" . :jvalue.s)
     1339                       ("int" . :jvalue.i)
     1340                       ("long" . :jvalue.j)
     1341                       ("float" . :jvalue.f)
     1342                       ("double" . :jvalue.d))
     1343                     :test #'string-equal)))
     1344    (if prim
     1345        (rest prim)
     1346      :jvalue.l)))
    12521347
    12531348(defun name-component-from-typename (tn)
     
    14641559           ,@body)))))
    14651560
    1466 #|
     1561#||
    14671562It is critical that if you call a JNI function that might throw an exception that you clear it,
    14681563otherwise the next Java call you make will cause a crash
    1469 |#
     1564||#
     1565
    14701566(defun handle-exception ()
    14711567  (let ((e (exception-occurred)))
    1472     (when (not (fli:null-pointer-p e)) ;allow for safe calling in non-exceptional state
     1568    (when (not (ccl:%null-ptr-p e)) ;allow for safe calling in non-exceptional state
    14731569      (exception-clear)
    14741570      ;if the exception occurs in the reflection target, we really want that
     
    14801576                      (format s "~A~%" (object.tostring x))))))))
    14811577
    1482 (defun try (result)
    1483   (if (exception-check)
    1484       (handle-exception)
    1485     result))
    1486 
    1487 ;JNI will sometimes indicate theere is an exception via a return value
    1488 ;so take advantage of that when possible vs. the call back to exception-check
    1489 (defun try-null (result)
    1490   (if (fli:null-pointer-p result)
    1491       (handle-exception)
    1492     result))
     1578
     1579
     1580
    14931581
    14941582(defun try-neg (result)
     
    15001588)
    15011589
    1502 ) ; #+todo
     1590
Note: See TracChangeset for help on using the changeset viewer.