Changeset 11447
- Timestamp:
- Nov 29, 2008, 8:34:18 AM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/examples/jfli/jni.lisp
r11442 r11447 52 52 :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field 53 53 :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 )) 55 59 56 60 (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 57 90 58 91 (eval-when (:compile-toplevel :load-toplevel :execute) 59 92 (ccl:use-interface-dir :jni)) 60 93 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)))))) 64 101 65 102 (defvar *jni-lib-path* … … 72 109 ;;; Map between lisp and Java booleans 73 110 (eval-when (:compile-toplevel) 74 (declaim (inline jboolean-arg jboolean-result )))111 (declaim (inline jboolean-arg jboolean-result jobject-result))) 75 112 76 113 (defun jboolean-arg (val) … … 81 118 (defun jboolean-result (val) 82 119 (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) 83 126 84 127 … … 128 171 ;; We might want to special-case some result-types for finalization. 129 172 (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 133 185 134 186 (defun get-version () … … 147 199 (jnienv-call ("FindClass" :jclass) :address cname))) 148 200 201 149 202 (defun from-reflected-method (method) 150 203 (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method)) … … 154 207 155 208 (defun to-reflected-method (cls method-id is-static) 209 156 210 (jnienv-call ("ToReflectedMethod" :jobject) 157 211 :jclass cls … … 163 217 164 218 (defun is-assignable-from (sub sup) 165 (jboolean-result166 (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup)))219 220 (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup)) 167 221 168 222 (defun to-reflected-field (cls field-id is-static) 223 169 224 (jnienv-call ("ToReflectedField" :jobject) 170 225 :jclass cls … … 196 251 197 252 (defun pop-local-frame (result) 253 198 254 (jnienv-call ("PopLocalFrame" :jobject) :jobject result)) 199 255 … … 208 264 209 265 (defun is-same-object (obj1 obj2) 210 (jboolean-result211 (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2)))266 267 (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2)) 212 268 213 269 (defun new-local-ref (ref) 270 214 271 (jnienv-call ("NewLocalRef" :jobject) :jobject ref)) 215 272 … … 225 282 226 283 (defun new-object-a (clazz method-id args) 284 227 285 (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args)) 228 286 … … 230 288 (jnienv-call ("GetObjectClass" :jclass) :jobject obj)) 231 289 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 232 300 ;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA. 233 301 … … 239 307 240 308 (defun call-boolean-method-a (obj method-id args) 241 (jboolean-result242 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)) 246 314 247 315 (defun call-byte-method-a (obj method-id args) … … 301 369 302 370 (defun call-nonvirtual-boolean-method-a (obj method-id args) 303 (jboolean-result304 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)) 308 376 309 377 (defun call-nonvirtual-byte-method-a (obj method-id args) … … 365 433 366 434 (defun get-object-field (obj field-id) 435 367 436 (jnienv-call ("GetObjectField" :jobject) 368 437 :jobject obj … … 370 439 371 440 (defun get-boolean-field (obj field-id) 372 (jboolean-result373 374 :jobject obj 375 #>jfieldID field-id)) )441 442 (jnienv-call ("GetBooleanField" :jboolean) 443 :jobject obj 444 #>jfieldID field-id)) 376 445 377 446 (defun get-byte-field (obj field-id) … … 474 543 475 544 (defun call-static-object-method-a (clazz method-id args) 545 476 546 (jnienv-call ("CallStaticObjectMethodA" :jobject) 477 547 :jclass clazz … … 480 550 481 551 (defun call-static-boolean-method-a (clazz method-id args) 482 (jboolean-result483 484 485 486 (:* :jvalue) args)))552 553 (jnienv-call ("CallStaticBooleanMethodA" :jboolean) 554 :jclass clazz 555 #>jmethodID method-id 556 (:* :jvalue) args)) 487 557 488 558 (defun call-static-byte-method-a (clazz method-id args) … … 548 618 549 619 (defun get-static-boolean-field (clazz field-id) 550 (jboolean-result551 552 :jclass clazz 553 #>jfieldID field-id)) )620 621 (jnienv-call ("GetStaticBooleanField" :jboolean) 622 :jclass clazz 623 #>jfieldID field-id)) 554 624 555 625 (defun get-static-byte-field (clazz field-id) … … 673 743 :jstring str 674 744 (:* :jboolean) is-copy))) 675 (values chars (jboolean-result (pref is-copy :jboolean))))))745 (values chars (pref is-copy :jboolean))))) 676 746 677 747 (defun release-string-utf-chars (str chars) … … 1003 1073 1004 1074 (defun exception-check () 1005 (j boolean-result (jnienv-call ("ExceptionCheck" :jboolean))))1075 (jnienv-call ("ExceptionCheck" :jboolean))) 1006 1076 1007 1077 … … 1080 1150 "this will be set by jfli:enable-java-proxies to a function of 3 args") 1081 1151 1082 #+todo1083 (progn1084 1152 1085 1153 1086 1154 ;;;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) 1089 1158 (do-invoke env obj proxy method args)) 1159 1090 1160 1091 1161 (defun do-invoke (env obj proxy method args) … … 1097 1167 (delete-local-ref obj)))) 1098 1168 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 1099 1181 (defun register-invocation-handler (invocation-handler) 1100 1182 "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath" 1101 1183 (setf *invocation-handler* invocation-handler) 1102 ( fli:with-dynamic-foreign-objects ((method jni-native-method))1184 (rlet ((method #>JNINativeMethod)) 1103 1185 (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))))) 1109 1192 1110 1193 … … 1117 1200 1118 1201 ;found on c.l.l 1119 (eval-when (:compile-toplevel :load-toplevel )1202 (eval-when (:compile-toplevel :load-toplevel :execute) 1120 1203 (defun replace-substrings (string substring replacement) 1121 1204 (declare (optimize (speed 3)) … … 1138 1221 (when lref 1139 1222 (let ((gref (new-global-ref lref))) 1223 #+laster 1140 1224 (flag-special-free-action gref) 1141 1225 (delete-local-ref lref) … … 1155 1239 (let ((chars (try-null (get-string-utf-chars s)))) 1156 1240 (prog1 1157 ( fli:convert-from-foreign-string chars :external-format :utf-8)1241 (ccl::%get-utf-8-cstring chars) 1158 1242 (release-string-utf-chars s chars))))) 1159 1243 … … 1177 1261 1178 1262 (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))) 1183 1266 1184 1267 (defmacro with-arg-array (arg-array-name args &body body) 1185 1268 (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)))) 1190 1270 ,@(mapcar #'(lambda (arg) 1191 1271 (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) 1192 1272 args) 1193 1273 1194 ,@body))) )1274 ,@body))) 1195 1275 1196 1276 (defun build-descriptor (params return-type) … … 1250 1330 (rest prim) 1251 1331 :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))) 1252 1347 1253 1348 (defun name-component-from-typename (tn) … … 1464 1559 ,@body))))) 1465 1560 1466 #| 1561 #|| 1467 1562 It is critical that if you call a JNI function that might throw an exception that you clear it, 1468 1563 otherwise the next Java call you make will cause a crash 1469 |# 1564 ||# 1565 1470 1566 (defun handle-exception () 1471 1567 (let ((e (exception-occurred))) 1472 (when (not ( fli:null-pointer-p e)) ;allow for safe calling in non-exceptional state1568 (when (not (ccl:%null-ptr-p e)) ;allow for safe calling in non-exceptional state 1473 1569 (exception-clear) 1474 1570 ;if the exception occurs in the reflection target, we really want that … … 1480 1576 (format s "~A~%" (object.tostring x)))))))) 1481 1577 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 1493 1581 1494 1582 (defun try-neg (result) … … 1500 1588 ) 1501 1589 1502 ) ; #+todo 1590
Note: See TracChangeset
for help on using the changeset viewer.