source: trunk/source/library/jni.lisp @ 15191

Last change on this file since 15191 was 15191, checked in by gb, 8 years ago

Use a cast in the code that sets up errno_loc in the TCR.
Revive jvm_init(), since Apple's JVM still/again clobbers Mach exception
ports.

Add kernel-import info for jvm-init for all architectures. (The kernel
import table isn't architecture-specific, though some entries effectively
are.)

Tweak jni.lisp a bit; still needs lots of work.

File size: 55.1 KB
RevLine 
[11436]1;    Copyright (c) Rich Hickey. All rights reserved.
2;    The use and distribution terms for this software are covered by the
3;    Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
4;    which can be found in the file CPL.TXT at the root of this distribution.
5;    By using this software in any fashion, you are agreeing to be bound by
6;    the terms of this license.
7;    You must not remove this notice, or any other, from this software.
8
9#|
10This is a straight wrapper around the JNI API
11Originally I intended to expose this API directly, but it turns out
12that JNI is very sensitive to errors, and, given bad args, wrong types etc
13causes the JVM (and Lisp) to crash, not very much in the spirit of safe, robust,
14interactive development offered by Lisp
15
16So, now this just forms the substrate under jfli, which uses the Reflection API, and is much
17more robust and error tolerant, at some cost in speed I guess.
18
19Bottom line is you shouldn't be using this API directly unless you are extending jfli,
20and then you must take care not to allow bad end-user data to pass through to JNI.
21
22Caveat emptor.
23
24I have tried to limit LispWorks FLI code to this file.
25|#
26
27(defpackage :jni
28  (:export
29   :*jni-lib-path*
30   :*pvm*
31   :*penv*
32   :register-invocation-handler
33   :create-jvm
34   :JNI-VERSION-1-2
35   :JNI-VERSION-1-4
36   :JNI-OK
37   :java-ref
38   :jvoid :jboolean :jbyte :jchar :jshort :jint :jlong :jfloat :jdouble :jsize
39   :jobject :jclass :jthrowable :jstring :jarray
40   :jboolean-array :jbyte-array :jchar-array :jshort-array :jint-array :jlong-array
41   :jfloat-array :jdouble-array :jobject-array
42   :jfield-id :jmethod-id :jweak
43   :pvm :penv
44   :jvalue
45   :arg-array
46   :jni-native-method :jni-env
47   :java-vm :java-vm-option :jdk-1-1-init-args
48   :jni-get-default-java-vm-init-args :java-vm-inits-args
49   :jni-create-java-vm :jni-get-created-java-vms
50   :try :try-null :try-neg
51   :local-ref-to-global-ref :local-ref-to-string
52   :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field
53   :jaref :convert-to-java-string :convert-from-java-string :java-ref-p
[11447]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   ))
[11436]59
60(in-package :jni)
61
[11447]62(defclass java-object (ccl::foreign-standard-object)
63    ())
64
[15191]65(defmethod print-object ((object java-object) stream)
66  (print-unreadable-object (object stream :type t :identity t)
67    (format stream "@#x~x" (ccl::%ptr-to-int object))))
68
[11454]69(ccl::defloadvar *java-object-domain* nil)
[11447]70
[11454]71(or *java-object-domain*
72    (setq *java-object-domain*
73          (ccl::register-foreign-object-domain :java
74                                               :recognize #'ccl::false
75                                               :class-of (lambda (x)
76                                                           (declare (ignore x))
77                                                           (find-class 'java-object))
78                                               :classp #'ccl::false
79                                               :instance-class-wrapper
80                                               (lambda (x)
81                                                 (declare (ignore x))
82                                                 (ccl::class-own-wrapper
83                                                  (find-class 'java-object)))
84                                               :class-own-wrapper
85                                               #'ccl::false
86                                               :slots-vector #'ccl::false
87                                               :class-ordinal #'ccl::false
88                                               :set-class-ordinal
89                                               #'ccl::false)))
90
[11447]91(deftype java-ref () 'java-object)
92
93(defun java-ref-p (x)
94  (and (eql (ccl::typecode x) target::subtag-macptr)
95       (eql (ccl::%macptr-domain x) *java-object-domain*)))
96
97
[11442]98(eval-when (:compile-toplevel :load-toplevel :execute)
99  (ccl:use-interface-dir :jni))
100
[11447]101(defun string-append (&rest args)
102  (declare (dynamic-extent args))
103  (do* ((a args (cdr a)))
104     ((null a) (apply #'concatenate 'string args))
105    (let* ((arg (car a)))
106      (unless (typep arg 'string)
107        (setf (car a) (string arg))))))
[11442]108
[11436]109(defvar *jni-lib-path*
[11442]110#+:darwin-target "/System/Library/Frameworks/JavaVM.framework/JavaVM"
[11557]111#+:win32-target "C:/Program Files/Java/jre6/bin/client/jvm.dll"
[15191]112#+android-target "libdvm.so"
113#-(or darwin-target win32-target android-target)
114"need to define *jni-lib-path*"
[11436]115"Set this to point to your jvm dll prior to calling create-jvm")
116
[11442]117(ccl::defloadvar *pvm* nil)
[11436]118
[11442]119;;; Map between lisp and Java booleans
120(eval-when (:compile-toplevel)
[11454]121  (declaim (inline jboolean-arg jboolean-result jobject-result jobject-arg)))
[11436]122
[11442]123(defun jboolean-arg (val)
124  (if (and val (not (eql val #$JNI_FALSE)))
125    #$JNI_TRUE
126    #$JNI_FALSE))
[11436]127
[11454]128(defun jobject-arg (val)
129  (or val ccl::+null-ptr+))
130
131
[11442]132(defun jboolean-result (val)
133  (not (eql val #$JNI_FALSE)))
134
[11447]135;;; Might also want to register p for termination (finalization).
136(defun jobject-result (val)
137  (unless (ccl::%null-ptr-p val)
[11454]138    (ccl::%set-macptr-domain val *java-object-domain*)
139    val))
[11442]140
141
[11447]142
[11442]143(defconstant JNI-VERSION-1-2 #$JNI_VERSION_1_2)
144(defconstant JNI-VERSION-1-4 #$JNI_VERSION_1_4)
145(defconstant JNI-OK #$JNI_OK)
146
[11436]147(defun load-jni-lib (&optional (libpath *jni-lib-path*))
[11442]148  (ccl:open-shared-library libpath))
[11436]149
[15191]150
[11442]151(defun current-env ()
152  "return a pointer to the current thread's JNIEnv, creating that environment
153if necessary."
154  (rlet ((pjnienv :address))
155    (let* ((jvm (get-pvm)))
156      (unless (eql jni-ok
157                   (ff-call (pref jvm #>JavaVM.GetEnv)
158                            :address jvm
159                            :address pjnienv
160                            :jint jni-version-1-4
161                            :jint))
162        (unless (eql jni-ok
163                     (ff-call
[15189]164                      (pref jvm #>JavaVM.AttachCurrentThread)
[11442]165                      :address jvm
166                      :address pjnienv
167                      :address (ccl::%null-ptr)
168                      :jint))
[15191]169          (error "Can't attach thread to JVM ~s" jvm))))
170    (let* ((result (pref pjnienv :address)))
171      (ccl::%set-macptr-type result (load-time-value (ccl::foreign-type-ordinal (ccl::foreign-pointer-type-to (ccl::parse-foreign-type #>JNIEnv)))))
172      result)))
[11436]173
174
[11442]175;;; JNIEnv functions.
[11436]176
[11454]177(defun process-jnienv-call-args (specs)
178  (ccl::collect ((args))
179    (do* ((specs specs (cddr specs)))
180         ((null specs) (args))
181      (let* ((type (car specs))
182             (valform (cadr specs)))
183        (args type)
184        (case type
185          (:jboolean (args `(jboolean-arg ,valform)))
186          ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray
187                     #>jbyteArray #>jcharArray #>jshortArray #>jintArray
188                     #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray)
189           (args `(jobject-arg ,valform)))
190          (t (args valform)))))))
191 
[11442]192(defmacro jnienv-call ((slot result-type) &rest specs)
193  ;; We might want to special-case some result-types for finalization.
194  (let* ((env (gensym))
[11447]195         (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot)))
196         (form
197          `(let* ((,env (current-env)))
[11454]198            (ff-call (pref ,env ,accessor) :address ,env ,@(process-jnienv-call-args specs) ,result-type))))
[11447]199    (case result-type
200      (:jboolean `(jboolean-result ,form))
201      ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray
202                 #>jbyteArray #>jcharArray #>jshortArray #>jintArray
203                 #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray)
204       `(jobject-result ,form))
205      (t form))))
206                 
[11436]207
[11442]208(defun get-version ()
209  (jnienv-call ("GetVersion" :jint)))
[11436]210
[11442]211(defun define-class (name loader buf len)
212  (ccl::with-utf-8-cstrs ((cname name))
213    (jnienv-call ("DefineClass" :jclass) 
214                 :address cname
215                 :jobject loader
216                 (:* :jbyte) buf
217                 :jsize len)))
[11436]218
[11442]219(defun jni-find-class (name)
220  (ccl::with-utf-8-cstrs ((cname name))
221    (jnienv-call ("FindClass" :jclass) :address cname)))
[11436]222
[11447]223
[11442]224(defun from-reflected-method (method)
225  (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method))
[11436]226
[11442]227(defun from-reflected-field (field)
228  (jnienv-call ("FromReflectedField" #>jfieldID) :jobject field))
[11436]229
[11442]230(defun to-reflected-method (cls method-id is-static)
231  (jnienv-call ("ToReflectedMethod" :jobject)
232               :jclass cls
233               #>jmethodID method-id
[11454]234               :jboolean is-static))
[11436]235
[11442]236(defun get-superclass (sub)
237  (jnienv-call ("GetSuperclass" :jclass) :jclass sub))
[11436]238
[11442]239(defun is-assignable-from (sub sup)
[11447]240 
241  (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup))
[11436]242
[15191]243(defun to-reflected-field (cls field-id is-static) 
[11442]244  (jnienv-call ("ToReflectedField" :jobject)
245               :jclass cls
246               #>jfieldID field-id
[11454]247               :jboolean is-static))
[11436]248
[11442]249(defun jni-throw (obj)
250  (jnienv-call ("Throw" :jint) :jthrowable obj))
[11436]251
[11442]252(defun throw-new (clazz msg)
253  (ccl::with-utf-8-cstrs ((cmsg msg))
254    (jnienv-call ("ThrowNew" :jint) :jclass clazz :address cmsg)))
[11436]255
[11442]256(defun exception-occurred ()
257  (jnienv-call ("ExceptionOccurred" :jthrowable)))
[11436]258
[11442]259(defun exception-describe ()
260  (jnienv-call ("ExceptionDescribe" :void)))
[11436]261
[11442]262(defun exception-clear ()
263  (jnienv-call ("ExceptionClear" :void)))
[11436]264
[11442]265(defun fatal-error (msg)
266  (ccl::with-utf-8-cstrs ((cmsg msg))
267    (jnienv-call ("FatalError" :void) :address cmsg)))
268 
269(defun push-local-frame (capacity)
270  (jnienv-call ("PushLocalFrame" :jint) :jint capacity))
[11436]271
[11442]272(defun pop-local-frame (result)
[11447]273 
[11442]274  (jnienv-call ("PopLocalFrame" :jobject) :jobject result))
[11436]275
[11442]276(defun new-global-ref (lobj)
277  (jnienv-call ("NewGlobalRef" :jobject) :jobject lobj))
[11436]278
[11442]279(defun delete-global-ref (gref)
280  (jnienv-call ("DeleteGlobalRef" :void) :jobject gref))
281 
282(defun delete-local-ref (obj)
283  (jnienv-call ("DeleteLocalRef" :void) :jobject obj))
[11436]284
[11442]285(defun is-same-object (obj1 obj2)
[11447]286 
287  (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2))
[11436]288
[11442]289(defun new-local-ref (ref)
[11447]290 
[11442]291  (jnienv-call ("NewLocalRef" :jobject) :jobject ref))
[11436]292
[11442]293(defun ensure-local-capacity (capacity)
294  (jnienv-call ("EnsureLocalCapacity" :jint) :jint capacity))
[11436]295
[11442]296(defun alloc-object (clazz)
297  (jnienv-call ("AllocObject" :jobject) :jclass clazz))
[11436]298
[11442]299;;; We probably can't get very far with NewObject or NewObjectV, which
300;;; depend on the underlying varargs mechanism.  NewObjectA is more
301;;; tractable.
[11436]302
[11442]303(defun new-object-a (clazz method-id args)
[11447]304 
[11442]305  (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args))
[11436]306
[11442]307(defun get-object-class (obj)
308  (jnienv-call ("GetObjectClass" :jclass) :jobject obj))
[11436]309
[11447]310(defun is-instance-of (obj clazz)
311 
312  (jnienv-call ("IsInstanceOf" :jboolean) :jobject obj :jclass clazz))
313
314(defun get-method-id (clazz name sig)
315  (ccl::with-utf-8-cstrs ((cname name)
316                          (csig sig))
317    (jnienv-call ("GetMethodID" #>jmethodID)
318                 :jclass clazz :address cname :address csig)))
319
[11442]320;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA.
[11436]321
[11442]322(defun call-object-method-a (obj method-id args)
323  (jnienv-call ("CallObjectMethodA" :jobject)
324               :jobject obj
325               #>jmethodID method-id
326               (:* :jvalue) args))
[11436]327
[11442]328(defun call-boolean-method-a (obj method-id args)
[11447]329 
330  (jnienv-call ("CallBooleanMethodA" :jboolean)
[11442]331               :jobject obj
332               #>jmethodID method-id
[11447]333               (:* :jvalue) args))
[11436]334
[11442]335(defun call-byte-method-a (obj method-id args)
336  (jnienv-call ("CallByteMethodA" :jbyte)
337               :jobject obj
338               #>jmethodID method-id
339               (:* :jvalue) args))
[11436]340
[11442]341(defun call-byte-method-a (obj method-id args)
342  (jnienv-call ("CallCharMethodA" :jchar)
343               :jobject obj
344               #>jmethodID method-id
345               (:* :jvalue) args))
[11436]346
[11442]347(defun call-short-method-a (obj method-id args)
348  (jnienv-call ("CallShortMethodA" :jshort)
349               :jobject obj
350               #>jmethodID method-id
351               (:* :jvalue) args))
[11436]352
[11442]353(defun call-int-method-a (obj method-id args)
354  (jnienv-call ("CallIntMethodA" :jint)
355               :jobject obj
356               #>jmethodID method-id
357               (:* :jvalue) args))
[11436]358
[11442]359(defun call-long-method-a (obj method-id args)
360  (jnienv-call ("CallLongMethodA" :jlong)
361               :jobject obj
362               #>jmethodID method-id
363               (:* :jvalue) args))
[11436]364
[11442]365(defun call-float-method-a (obj method-id args)
366  (jnienv-call ("CallFloatMethodA" :jfloat)
367               :jobject obj
368               #>jmethodID method-id
369               (:* :jvalue) args))
[11436]370
[11442]371(defun call-double-method-a (obj method-id args)
372  (jnienv-call ("CallDoubleMethodA" :jdouble)
373               :jobject obj
374               #>jmethodID method-id
375               (:* :jvalue) args))
376
377(defun call-void-method-a (obj method-id args)
378  (jnienv-call ("CallVoidMethodA" :void)
379               :jobject obj
380               #>jmethodID method-id
381               (:* :jvalue) args))
382
383;;; Nonvirtual method calls.
384(defun call-nonvirtual-object-method-a (obj method-id args)
385  (jnienv-call ("CallNonvirtualObjectMethodA" :jobject)
386               :jobject obj
387               #>jmethodID method-id
388               (:* :jvalue) args))
389
390(defun call-nonvirtual-boolean-method-a (obj method-id args)
[11447]391 
392  (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean)
[11442]393               :jobject obj
394               #>jmethodID method-id
[11447]395               (:* :jvalue) args))
[11442]396
397(defun call-nonvirtual-byte-method-a (obj method-id args)
398  (jnienv-call ("CallNonvirtualByteMethodA" :jbyte)
399               :jobject obj
400               #>jmethodID method-id
401               (:* :jvalue) args))
402
403(defun call-nonvirtual-char-method-a (obj method-id args)
404  (jnienv-call ("CallNonvirtualCharMethodA" :jchar)
405               :jobject obj
406               #>jmethodID method-id
407               (:* :jvalue) args))
408
409(defun call-nonvirtual-short-method-a (obj method-id args)
410  (jnienv-call ("CallNonvirtualShortMethodA" :jshort)
411               :jobject obj
412               #>jmethodID method-id
413               (:* :jvalue) args))
414
415
416(defun call-nonvirtual-int-method-a (obj method-id args)
417  (jnienv-call ("CallNonvirtualIntMethodA" :jint)
418               :jobject obj
419               #>jmethodID method-id
420               (:* :jvalue) args))
421
422(defun call-nonvirtual-long-method-a (obj method-id args)
423  (jnienv-call ("CallNonvirtualLongMethodA" :jlong)
424               :jobject obj
425               #>jmethodID method-id
426               (:* :jvalue) args))
427
428(defun call-nonvirtual-float-method-a (obj method-id args)
429  (jnienv-call ("CallNonvirtualFloatMethodA" :jfloat)
430               :jobject obj
431               #>jmethodID method-id
432               (:* :jvalue) args))
433
434(defun call-nonvirtual-double-method-a (obj method-id args)
435  (jnienv-call ("CallNonvirtualDoubleMethodA" :jdouble)
436               :jobject obj
437               #>jmethodID method-id
438               (:* :jvalue) args))
439
440(defun call-nonvirtual-void-method-a (obj method-id args)
441  (jnienv-call ("CallNonvirtualVoidMethodA" :void)
442               :jobject obj
443               #>jmethodID method-id
444               (:* :jvalue) args))
445
446(defun get-field-id (clazz name sig)
447  (ccl::with-utf-8-cstrs ((cname name)
448                          (csig sig))
449    (jnienv-call ("GetFieldID" #>jfieldID)
450                 :jclass clazz
451                 :address cname
452                 :address csig)))
453
454(defun get-object-field (obj field-id)
[11447]455 
[11442]456  (jnienv-call ("GetObjectField" :jobject)
457               :jobject obj
458               #>jfieldID field-id))
459
460(defun get-boolean-field (obj field-id)
[11447]461 
462  (jnienv-call ("GetBooleanField" :jboolean)
[11442]463               :jobject obj
[11447]464               #>jfieldID field-id))
[11442]465
466(defun get-byte-field (obj field-id)
467  (jnienv-call ("GetByteField" :jbyte)
468               :jobject obj
469               #>jfieldID field-id))
470
471(defun get-char-field (obj field-id)
472  (jnienv-call ("GetCharField" :jchar)
473               :jobject obj
474               #>jfieldID field-id))
475
476(defun get-short-field (obj field-id)
477  (jnienv-call ("GetShortField" :jshort)
478               :jobject obj
479               #>jfieldID field-id))
480
481
482(defun get-int-field (obj field-id)
483  (jnienv-call ("GetIntField" :jint)
484               :jobject obj
485               #>jfieldID field-id))
486
487(defun get-long-field (obj field-id)
488  (jnienv-call ("GetLongField" :jlong)
489               :jobject obj
490               #>jfieldID field-id))
491
492(defun get-float-field (obj field-id)
493  (jnienv-call ("GetFloatField" :jfloat)
494               :jobject obj
495               #>jfieldID field-id))
496
497(defun get-double-field (obj field-id)
498  (jnienv-call ("GetDoubleField" :jdouble)
499               :jobject obj
500               #>jfieldID field-id))
501
502(defun set-object-field (obj field-id val)
503  (jnienv-call ("SetObjectField" :void)
504               :jobject obj
505               #>jfieldID field-id
506               :jobject val))
507
508(defun set-boolean-field (obj field-id val)
509  (jnienv-call ("SetBooleanField" :void)
510               :jobject obj
511               #>jfieldID field-id
[11454]512               :jboolean val))
[11442]513
514(defun set-byte-field (obj field-id val)
515  (jnienv-call ("SetByteField" :void)
516               :jobject obj
517               #>jfieldID field-id
518               :jbyte val))
519
520(defun set-char-field (obj field-id val)
521  (jnienv-call ("SetCharField" :void)
522               :jobject obj
523               #>jfieldID field-id
524               :jchar val))
525
526(defun set-short-field (obj field-id val)
527  (jnienv-call ("SetShortField" :void)
528               :jobject obj
529               #>jfieldID field-id
530               :jshort val))
531
532(defun set-int-field (obj field-id val)
533  (jnienv-call ("SetIntField" :void)
534               :jobject obj
535               #>jfieldID field-id
536               :jint val))
537
538(defun set-long-field (obj field-id val)
539  (jnienv-call ("SetLongField" :void)
540               :jobject obj
541               #>jfieldID field-id
542               :jlong val))
543
544(defun set-float-field (obj field-id val)
545  (jnienv-call ("SetFloatField" :void)
546               :jobject obj
547               #>jfieldID field-id
548               :jfloat val))
549
550(defun set-double-field (obj field-id val)
551  (jnienv-call ("SetDoubleField" :void)
552               :jobject obj
553               #>jfieldID field-id
554               :jdouble val))
555
556(defun get-static-method-id (clazz name sig)
557  (ccl::with-utf-8-cstrs ((cname name)
558                          (csig sig))
559    (jnienv-call ("GetStaticMethodID" #>jmethodID)
560                 :jclass clazz
561                 :address cname
562                 :address csig)))
563
564(defun call-static-object-method-a (clazz method-id args)
[11447]565 
[11442]566  (jnienv-call ("CallStaticObjectMethodA" :jobject)
567               :jclass clazz
568               #>jmethodID method-id
569               (:* :jvalue) args))
570
571(defun call-static-boolean-method-a (clazz method-id args)
[11447]572 
573  (jnienv-call ("CallStaticBooleanMethodA" :jboolean)
574               :jclass clazz
575               #>jmethodID method-id
576               (:* :jvalue) args))
[11442]577
578(defun call-static-byte-method-a (clazz method-id args)
579  (jnienv-call ("CallStaticByteMethodA" :jbyte)
580               :jclass clazz
581               #>jmethodID method-id
582               (:* :jvalue) args))
583
584(defun call-static-char-method-a (clazz method-id args)
585  (jnienv-call ("CallStaticCharMethodA" :jchar)
586               :jclass clazz
587               #>jmethodID method-id
588               (:* :jvalue) args))
589
590(defun call-static-short-method-a (clazz method-id args)
591  (jnienv-call ("CallStaticShortMethodA" :jshort)
592               :jclass clazz
593               #>jmethodID method-id
594               (:* :jvalue) args))
595
596(defun call-static-int-method-a (clazz method-id args)
597  (jnienv-call ("CallStaticIntMethodA" :jint)
598               :jclass clazz
599               #>jmethodID method-id
600               (:* :jvalue) args))
601
602(defun call-static-long-method-a (clazz method-id args)
603  (jnienv-call ("CallStaticLongMethodA" :jlong)
604               :jclass clazz
605               #>jmethodID method-id
606               (:* :jvalue) args))
607
608(defun call-static-float-method-a (clazz method-id args)
609  (jnienv-call ("CallStaticFloatMethodA" :jfloat)
610               :jclass clazz
611               #>jmethodID method-id
612               (:* :jvalue) args))
613
614(defun call-static-double-method-a (clazz method-id args)
615  (jnienv-call ("CallStaticDoubleMethodA" :jdouble)
616               :jclass clazz
617               #>jmethodID method-id
618               (:* :jvalue) args))
619
620(defun call-static-void-method-a (clazz method-id args)
621  (jnienv-call ("CallStaticVoidMethodA" :void)
622               :jclass clazz
623               #>jmethodID method-id
624               (:* :jvalue) args))
625
626(defun get-static-field-id (clazz name sig)
627  (ccl::with-utf-8-cstrs ((cname name)
628                          (csig sig))
629    (jnienv-call ("GetStaticFieldID" #>jfieldID)
630                 :jclass clazz
631                 :address cname
632                 :address csig)))
633
634(defun get-static-object-field (clazz field-id)
635  (jnienv-call ("GetStaticObjectField" :jobject)
636               :jclass clazz
637               #>jfieldID field-id))
638
639(defun get-static-boolean-field (clazz field-id)
[11447]640 
641  (jnienv-call ("GetStaticBooleanField" :jboolean)
[11442]642               :jclass clazz
[11447]643               #>jfieldID field-id))
[11442]644
645(defun get-static-byte-field (clazz field-id)
646  (jnienv-call ("GetStaticByteField" :jbyte)
647               :jclass clazz
648               #>jfieldID field-id))
649
650(defun get-static-char-field (clazz field-id)
651  (jnienv-call ("GetStaticCharField" :jchar)
652               :jclass clazz
653               #>jfieldID field-id))
654
655(defun get-static-short-field (clazz field-id)
656  (jnienv-call ("GetStaticShortField" :jshort)
657               :jclass clazz
658               #>jfieldID field-id))
659
660(defun get-static-int-field (clazz field-id)
661  (jnienv-call ("GetStaticIntField" :jint)
662               :jclass clazz
663               #>jfieldID field-id))
664
665(defun get-static-long-field (clazz field-id)
666  (jnienv-call ("GetStaticLongField" :jlong)
667               :jclass clazz
668               #>jfieldID field-id))
669
670(defun get-static-float-field (clazz field-id)
671  (jnienv-call ("GetStaticFloatField" :jfloat)
672               :jclass clazz
673               #>jfieldID field-id))
674
675(defun get-static-double-field (clazz field-id)
676  (jnienv-call ("GetStaticDoubleField" :jdouble)
677               :jclass clazz
678               #>jfieldID field-id))
679
680
681(defun set-static-object-field (clazz field-id value)
682  (jnienv-call ("SetStaticObjectField" :void)
683               :jclass clazz
684               #>jfieldID field-id
685               :jobject value))
686
687(defun set-static-boolean-field (clazz field-id value)
688  (jnienv-call ("SetStaticBooleanField" :void)
689               :jclass clazz
690               #>jfieldID field-id
[11454]691               :jboolean value))
[11442]692
693(defun set-static-byte-field (clazz field-id value)
694  (jnienv-call ("SetStaticByteField" :void)
695               :jclass clazz
696               #>jfieldID field-id
697               :jbyte value))
698
699(defun set-static-char-field (clazz field-id value)
700  (jnienv-call ("SetStaticCharField" :void)
701               :jclass clazz
702               #>jfieldID field-id
703               :jchar value))
704
705(defun set-static-short-field (clazz field-id value)
706  (jnienv-call ("SetStaticShortField" :void)
707               :jclass clazz
708               #>jfieldID field-id
709               :jshort value))
710
711(defun set-static-int-field (clazz field-id value)
712  (jnienv-call ("SetStaticIntField" :void)
713               :jclass clazz
714               #>jfieldID field-id
715               :jint value))
716
717(defun set-static-long-field (clazz field-id value)
718  (jnienv-call ("SetStaticLongField" :void)
719               :jclass clazz
720               #>jfieldID field-id
721               :jlong value))
722
723(defun set-static-float-field (clazz field-id value)
724  (jnienv-call ("SetStaticFloatField" :void)
725               :jclass clazz
726               #>jfieldID field-id
727               :jfloat value))
728
729(defun set-static-double-field (clazz field-id value)
730  (jnienv-call ("SetStaticDoubleField" :void)
731               :jclass clazz
732               #>jfieldID field-id
733               :jdouble value))
734
735(defun new-string (unicode len)
736  (ccl::with-native-utf-16-cstrs ((cstring unicode))
737    (jnienv-call ("NewString" :jstring)
738                 (:* :jchar) cstring
739                 :jsize len)))
740
741(defun get-string-length (str)
742  (jnienv-call ("GetStringLength" :jsize)
743               :jstring str))
744
745(defun get-string-chars (str is-copy)
746  (jnienv-call ("GetStringChars" (:* :jchar))
747               :jstring str
748               (:* :jboolean) is-copy))
749
750(defun release-string-chars (str chars)
751  (jnienv-call ("ReleaseStringChars" :void)
752               :jstring str
753               (:* :jchar) chars))
754
755(defun new-string-utf (string)
756  (ccl::with-utf-8-cstrs ((cstring string))
757    (jnienv-call ("NewStringUTF" :jstring)
758                 :address cstring)))
759
760(defun get-string-utf-chars (str)
761  (rlet ((is-copy :jboolean))
762    (let* ((chars (jnienv-call ("GetStringUTFChars" (:* :char))
763                               :jstring str
764                               (:* :jboolean) is-copy)))
[11447]765      (values chars  (pref is-copy :jboolean)))))
[11442]766
767(defun release-string-utf-chars (str chars)
768  (jnienv-call ("ReleaseStringUTFChars" :void)
769               :jstring str
770               (:* :char) chars))
771
772(defun get-array-length (array)
773  (jnienv-call ("GetArrayLength" :jsize)
774               :jArray array))
775
776(defun new-object-array (len clazz init)
777  (jnienv-call ("NewObjectArray" #>jobjectArray)
778               :jsize len
779               :jclass clazz
780               :jobject init))
781
782(defun get-object-array-element (array index)
783  (jnienv-call ("GetObjectArrayElement" :jobject)
784               #>jobjectArray array
785               :jsize index))
786
787(defun set-object-array-element (array index val)
788  (jnienv-call ("SetObjectArrayElement" :void)
789               #>jobjectArray array
790               :jsize index
791               :jobject val))
792
793(defun new-boolean-array (len)
794  (jnienv-call ("NewBooleanArray" #>jbooleanArray)
795               :jsize len))
796
797(defun new-byte-array (len)
798  (jnienv-call ("NewByteArray" #>jbyteArray)
799               :jsize len))
800
801(defun new-char-array (len)
802  (jnienv-call ("NewCharArray" #>jcharArray)
803               :jsize len))
804
805(defun new-short-array (len)
806  (jnienv-call ("NewShortArray" #>jshortArray)
807               :jsize len))
808
809(defun new-int-array (len)
810  (jnienv-call ("NewIntArray" #>jintArray)
811               :jsize len))
812
813(defun new-long-array (len)
814  (jnienv-call ("NewLongArray" #>jlongArray)
815               :jsize len))
816
817(defun new-float-array (len)
818  (jnienv-call ("NewFloatArray" #>jfloatArray)
819               :jsize len))
820
821(defun new-double-array (len)
822  (jnienv-call ("NewDoubleArray" #>jdoubleArray)
823               :jsize len))
824
825
826(defun get-boolean-array-elements (array is-copy)
827  (jnienv-call ("GetBooleanArrayElements" (:* :jboolean))
828               #>jbooleanArray array
829               (:* :jboolean) is-copy))
830
831(defun get-byte-array-elements (array is-copy)
832  (jnienv-call ("GetByteArrayElements" (:* :jbyte))
833               #>jbyteArray array
834               (:* :jboolean) is-copy))
835
836(defun get-char-array-elements (array is-copy)
837  (jnienv-call ("GetCharArrayElements" (:* :jchar))
838               #>jcharArray array
839               (:* :jboolean) is-copy))
840
841(defun get-short-array-elements (array is-copy)
842  (jnienv-call ("GetShortArrayElements" (:* :jshort))
843               #>jshortArray array
844               (:* :jboolean) is-copy))
845
846(defun get-int-array-elements (array is-copy)
847  (jnienv-call ("GetIntArrayElements" (:* :jint))
848               #>jintArray array
849               (:* :jboolean) is-copy))
850
851(defun get-long-array-elements (array is-copy)
852  (jnienv-call ("GetLongArrayElements" (:* :jlong))
853               #>jlongArray array
854               (:* :jboolean) is-copy))
855
856(defun get-float-array-elements (array is-copy)
857  (jnienv-call ("GetFloatArrayElements" (:* :jfloat))
858               #>jfloatArray array
859               (:* :jboolean) is-copy))
860
861(defun get-double-array-elements (array is-copy)
862  (jnienv-call ("GetDoubleArrayElements" (:* :jdouble))
863               #>jdoubleArray array
864               (:* :jboolean) is-copy))
865
866(defun release-boolean-array-elements (array elems mode)
867  (jnienv-call ("ReleaseBooleanArrayElements" :void)
868               #>jbooleanArray array
869               (:* jboolean) elems
870               :jint mode))
871
872(defun release-byte-array-elements (array elems mode)
873  (jnienv-call ("ReleaseByteArrayElements" :void)
874               #>jbyteArray array
875               (:* jbyte) elems
876               :jint mode))
877
878(defun release-char-array-elements (array elems mode)
879  (jnienv-call ("ReleaseCharArrayElements" :void)
880               #>jcharArray array
881               (:* jchar) elems
882               :jint mode))
883
884(defun release-short-array-elements (array elems mode)
885  (jnienv-call ("ReleaseShortArrayElements" :void)
886               #>jshortArray array
887               (:* jshort) elems
888               :jint mode))
889
890(defun release-int-array-elements (array elems mode)
891  (jnienv-call ("ReleaseIntArrayElements" :void)
892               #>jintArray array
893               (:* jint) elems
894               :jint mode))
895
896(defun release-long-array-elements (array elems mode)
897  (jnienv-call ("ReleaseLongArrayElements" :void)
898               #>jlongArray array
899               (:* jlong) elems
900               :jint mode))
901
902(defun release-float-array-elements (array elems mode)
903  (jnienv-call ("ReleaseFloatArrayElements" :void)
904               #>jfloatArray array
905               (:* jfloat) elems
906               :jint mode))
907
908(defun release-double-array-elements (array elems mode)
909  (jnienv-call ("ReleaseDoubleArrayElements" :void)
910               #>jdoubleArray array
911               (:* jdouble) elems
912               :jint mode))
913
914
915(defun get-boolean-array-region (array start len buf)
916  (jnienv-call ("GetBooleanArrayRegion" :void)
917               #>jbooleanArray array
918               :jsize start
919               :jsize len
920               (:* :jboolean) buf))
921
922(defun get-byte-array-region (array start len buf)
923  (jnienv-call ("GetByteArrayRegion" :void)
924               #>jbyteArray array
925               :jsize start
926               :jsize len
927               (:* :jbyte) buf))
928
929(defun get-char-array-region (array start len buf)
930  (jnienv-call ("GetCharArrayRegion" :void)
931               #>jcharArray array
932               :jsize start
933               :jsize len
934               (:* :jchar) buf))
935
936(defun get-short-array-region (array start len buf)
937  (jnienv-call ("GetShortArrayRegion" :void)
938               #>jshortArray array
939               :jsize start
940               :jsize len
941               (:* :jshort) buf))
942
943(defun get-int-array-region (array start len buf)
944  (jnienv-call ("GetIntArrayRegion" :void)
945               #>jintArray array
946               :jsize start
947               :jsize len
948               (:* :jint) buf))
949
950(defun get-long-array-region (array start len buf)
951  (jnienv-call ("GetLongArrayRegion" :void)
952               #>jlongArray array
953               :jsize start
954               :jsize len
955               (:* :jlong) buf))
956
957(defun get-float-array-region (array start len buf)
958  (jnienv-call ("GetFloatArrayRegion" :void)
959               #>jfloatArray array
960               :jsize start
961               :jsize len
962               (:* :jfloat) buf))
963
964(defun get-double-array-region (array start len buf)
965  (jnienv-call ("GetDoubleArrayRegion" :void)
966               #>jdoubleArray array
967               :jsize start
968               :jsize len
969               (:* :jdouble) buf))
970
971(defun set-boolean-array-region (array start len buf)
972  (jnienv-call ("SetBooleanArrayRegion" :void)
973               #>jbooleanArray array
974               :jsize start
975               :jsize len
976               (:* :jboolean) buf))
977
978(defun set-byte-array-region (array start len buf)
979  (jnienv-call ("SetByteArrayRegion" :void)
980               #>jbyteArray array
981               :jsize start
982               :jsize len
983               (:* :jbyte) buf))
984
985(defun set-char-array-region (array start len buf)
986  (jnienv-call ("SetCharArrayRegion" :void)
987               #>jcharArray array
988               :jsize start
989               :jsize len
990               (:* :jchar) buf))
991
992(defun set-short-array-region (array start len buf)
993  (jnienv-call ("SetShortArrayRegion" :void)
994               #>jshortArray array
995               :jsize start
996               :jsize len
997               (:* :jshort) buf))
998
999(defun set-int-array-region (array start len buf)
1000  (jnienv-call ("SetIntArrayRegion" :void)
1001               #>jintArray array
1002               :jsize start
1003               :jsize len
1004               (:* :jint) buf))
1005
1006(defun set-long-array-region (array start len buf)
1007  (jnienv-call ("SetLongArrayRegion" :void)
1008               #>jlongArray array
1009               :jsize start
1010               :jsize len
1011               (:* :jlong) buf))
1012
1013(defun set-float-array-region (array start len buf)
1014  (jnienv-call ("SetFloatArrayRegion" :void)
1015               #>jfloatArray array
1016               :jsize start
1017               :jsize len
1018               (:* :jfloat) buf))
1019
1020(defun set-double-array-region (array start len buf)
1021  (jnienv-call ("SetDoubleArrayRegion" :void)
1022               #>jdoubleArray array
1023               :jsize start
1024               :jsize len
1025               (:* :jdouble) buf))
1026
1027
1028(defun register-natives (clazz methods nmethods)
1029  (jnienv-call ("RegisterNatives":jint)
1030               :jclass clazz
1031               (:* #>JNINativeMethod) methods
1032               :jint nmethods))
1033
1034
1035(defun unregister-natives (clazz)
1036  (jnienv-call ("UnregisterNatives" :jint)
1037               :jclass clazz))
1038
1039(defun monitor-enter (obj)
1040  (jnienv-call ("MonitorEnter" :jint)
1041               :jobject obj))
1042
1043(defun monitor-exit (obj)
1044  (jnienv-call ("MonitorExit" :jint)
1045               :jobject obj))
1046
1047(defun get-java-vm (vm)
1048  (jnienv-call ("GetJavaVM" :jint)
1049               (:* (:* #>JavaVM)) vm))
1050
1051(defun get-string-region (str start len buf)
1052  (jnienv-call ("GetStringRegion" :void)
1053               :jstring str
1054               :jsize start
1055               :jsize len
1056               (:* :jchar) buf))
1057
1058(defun get-string-utf-region (str start len buf)
1059  (jnienv-call ("GetStringUTFRegion" :void)
1060               :jstring str
1061               :jsize start
1062               :jsize len
1063               (:* :char) buf))
1064
1065(defun get-primitive-array-critical (array is-copy)
1066  (jnienv-call ("GetPrimitiveArrayCritical" (:* :void))
1067               :jarray array
1068               (:* :jboolean) is-copy))
1069
1070(defun release-primitive-array-critical(jarray carray mode)
1071  (jnienv-call ("ReleasePrimitiveArrayCritical" :void)
1072               :jarray jarray
1073               (:* :void) carray
1074               :jint mode))
1075
1076(defun get-string-critical (string is-copy)
1077  (jnienv-call ("GetStringCritical" (:* :jchar))
1078               :jstring string
1079               (:* :jboolean) is-copy))
1080
1081(defun release-string-critical (string cstring)
1082  (jnienv-call ("ReleaseStringCritical" :void)
1083               :jstring string
1084               (:* :jchar) cstring))
1085
1086(defun new-weak-global-ref (obj)
1087  (jnienv-call ("NewWeakGlobalRef" :jweak)
1088               :jobject obj))
1089
1090(defun delete-weak-global-ref (ref)
1091  (jnienv-call ("DeleteWeakGlobalRef" :void)
1092               :jweak ref))
1093
1094(defun exception-check ()
[11447]1095  (jnienv-call ("ExceptionCheck" :jboolean)))
[11442]1096               
1097
1098(defun new-direct-byte-buffer (address capacity)
1099  (jnienv-call ("NewDirectByteBuffer" :jobject)
1100               :address address
1101               :jlong capacity))
1102
1103(defun get-direct-buffer-address (buf)
1104  (jnienv-call ("GetDirectBufferAddress" :address)
1105               :jobject buf))
1106
1107(defun get-direct-buffer-capacity (buf)
1108  (jnienv-call ("GetDirectBufferCapacity" :jlong)
1109               :jobject buf))
1110
1111;;; End of jnienv functions.  (Finally.)
1112
1113(defun get-pvm ()
1114  (or *pvm*
1115      (error "JVM not loaded")))
1116
1117#+later
[11436]1118(defun cleanup-jni-gref (gref)
1119  "set as a special free action to free java classes when no longer used by Lisp"
1120  (when (java-ref-p gref)
1121    (delete-global-ref gref)))
1122
[11442]1123(defun create-jvm (&rest args)
1124  (declare (dynamic-extent args))
[11436]1125  "Creates the JVM, this can only be done once.
1126The option strings can be used to control the JVM, esp. the classpath:
1127\"-Djava.class.path=/Users/rich/Lisp/jfli.jar\""
1128  (when *pvm*
1129    (error "JVM already created, can only be started once"))
1130  (load-jni-lib)
[11442]1131  (ccl::call-with-string-vector
1132   (lambda (argv)
1133     (let* ((nargs (length args)))
1134       (rlet ((initargs :<J>ava<VMI>nit<A>rgs)
1135              (env (:* :<JNIE>nv))
1136              (vm (:* :<J>ava<VM>)))
1137         (%stack-block ((options (* nargs (ccl::record-length :<J>ava<VMO>ption))))
1138           (do* ((i 0 (1+ i))
1139                 (p options (%inc-ptr p (ccl::record-length :<J>ava<VMO>ption))))
1140                ((= i nargs))
1141             (setf (pref p :<J>ava<VMO>ption.option<S>tring)
1142                   (paref argv (:* (:* :char)) i)))
1143           (setf (pref initargs :<J>ava<VMI>nit<A>rgs.version) #$JNI_VERSION_1_4
1144                 (pref initargs :<J>ava<VMI>nit<A>rgs.n<O>ptions) nargs
1145                 (pref initargs :<J>ava<VMI>nit<A>rgs.options) options
1146                 (pref initargs :<J>ava<VMI>nit<A>rgs.ignore<U>nrecognized) #$JNI_TRUE)
1147           ;; In Darwin, JNI_CreateJavaVM will clobber the calling thread's
1148           ;; Mach exception ports, despite the fact that CCL is using them.
1149           ;; To work around this, call a function in the lisp kernel which
1150           ;; restores the thread's exception ports after calling
1151           ;; JNI_CreateJavaVM for us.
1152           (let* ((result
[15191]1153                   (ff-call #+darwin-target (ccl::%kernel-import target::kernel-import-jvm-init)
1154                            #+darwin-target :address
1155                            (foreign-symbol-address "JNI_CreateJavaVM")
[11442]1156                            :address vm
1157                            :address env
1158                            :address initargs
1159                            :int)))
1160             (if (>= result 0)
1161               (progn
1162                 (setq *pvm* (%get-ptr vm))
1163                 (values result (%get-ptr vm) (%get-ptr env)))
1164               (error "Can't create Java VM: result = ~d" result)))))))
1165   args))
[11436]1166
1167
[11442]1168;;;this is the FLI side of proxy support
1169
[11436]1170(defvar *invocation-handler* nil
1171  "this will be set by jfli:enable-java-proxies to a function of 3 args")
1172
[11442]1173
1174
1175;;;this will be set as the implementation of a native java function
[11447]1176
1177(defcallback |LispInvocationHandler_invoke|
1178    (:address env :jobject obj :jobject proxy :jobject method :jobject args :jobject)
[11454]1179  (jobject-result obj)
1180  (jobject-result proxy)
1181  (jobject-result method)
1182  (jobject-result args)
1183  (jobject-arg 
1184   (do-invoke env obj proxy method args)))
[11436]1185
[11447]1186
[11436]1187(defun do-invoke (env obj proxy method args)
[11442]1188  (declare (ignore env))                ;it's not like we're on another thread
[11436]1189  (when *invocation-handler*
[11442]1190    (prog1
1191        (funcall *invocation-handler* proxy method args)
1192      ;;(jfli::invocation-handler proxy method args)
1193      (delete-local-ref obj))))
[11436]1194
[11447]1195(defun try (result)
1196  (if (exception-check)
1197      (handle-exception)
1198    result))
1199
1200;JNI will sometimes indicate theere is an exception via a return value
1201;so take advantage of that when possible vs. the call back to exception-check
1202(defun try-null (result)
[11454]1203  (if (or (null result) (ccl:%null-ptr-p result))
[11447]1204      (handle-exception)
1205    result))
1206
[11436]1207(defun register-invocation-handler (invocation-handler)
1208  "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath"
1209  (setf *invocation-handler* invocation-handler)
[11447]1210  (rlet ((method #>JNINativeMethod))
[11436]1211    (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler"))))
[11447]1212      (with-cstrs ((name "invoke")
1213                   (signature "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;"))
1214        (setf (pref method #>JNINativeMethod.name) name
1215              (pref method #>JNINativeMethod.signature) signature
1216              (pref method #>JNINativeMethod.fnPtr) |LispInvocationHandler_invoke|)
1217      (register-natives lih method 1)))))
[11436]1218
1219
1220;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1221;the code below provides for the generation of wrapper functions that use JNI to access
1222;methods and fields. This low-level interface is unsafe, in that JNI will not
1223;check arg types etc on calls, and therefore should only be used to build safer high-level interfaces
1224;i.e. use jfli!
1225;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1226
1227;found on c.l.l
[11447]1228(eval-when (:compile-toplevel :load-toplevel :execute)
[11436]1229(defun replace-substrings (string substring replacement)
1230  (declare (optimize (speed 3))
1231           (type simple-string string substring replacement))
1232  (assert (> (length substring) 0) (substring)
1233    "Substring ~A must be of length ~D > 0"
1234    substring (length substring))
1235  (with-output-to-string (stream)
1236    (loop with substring-length = (length substring)
1237          for index = 0 then (+ match-index substring-length)
1238          for match-index = (search substring string :start2 index)
1239          do
1240          (write-string string stream :start index :end match-index)
1241          (when match-index
1242            (write-string replacement stream))
1243          while match-index)))
1244
1245
1246(defun local-ref-to-global-ref (lref)
1247  (when lref
1248    (let ((gref (new-global-ref lref)))
[11447]1249      #+laster
[11436]1250      (flag-special-free-action gref)
1251      (delete-local-ref lref)
1252      gref)))
1253
1254(defun local-ref-to-string (lref)
1255  (prog1
1256      (convert-from-java-string lref)
1257    (delete-local-ref lref)))
1258
1259(defun convert-to-java-string (s)
1260  (when s
1261    (try-null (new-string-utf (string s)))))
1262
1263(defun convert-from-java-string (s)
1264  (when s
1265    (let ((chars (try-null (get-string-utf-chars s))))
1266      (prog1
[11447]1267          (ccl::%get-utf-8-cstring chars)
[11436]1268        (release-string-utf-chars s chars)))))
1269
1270(defun jaref (array index)
1271  (try (get-object-array-element array index)))
1272
1273(defun (setf jaref) (val array index)
1274  (try (set-object-array-element array index val)))
1275
1276(defun convert-string-arg (s)
1277  "if s is stringp, make into java string, else presume it is a java string and return it"
1278  ;presumably faster than checking if s is a foreign pointer?
1279  (if (or (stringp s) (symbolp s))
1280      (convert-to-java-string s)
1281    s))
1282
1283(defun process-arg (val type)
1284  (if (string-equal "java.lang.String" type)
[11454]1285    `(convert-string-arg ,val)
1286    `(or ,val ccl::+null-ptr+)))
[11436]1287
1288(defmacro set-arg (args i val type)
[11447]1289  `(setf (pref (paref ,args (:* :jvalue) ,i)
1290          ,(jvalue-accessor-from-typename type))
1291    ,(process-arg val type)))
[11436]1292
1293(defmacro with-arg-array (arg-array-name args &body body)
1294  (let ((i -1))
[11447]1295  `(%stack-block ((,arg-array-name (*  ,(length args) (ccl::record-length :jvalue))))
[11436]1296       ,@(mapcar #'(lambda (arg)
1297                     (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) 
1298                 args)
1299
[11447]1300       ,@body)))
[11436]1301
1302(defun build-descriptor (params return-type)
1303  (string-append
1304   "("
1305   (apply #'string-append (mapcar #'(lambda (p)
1306                                      (type-descriptor-from-typename (second p)))
1307                                  params))
1308   ")"
1309   (type-descriptor-from-typename return-type)))
1310
1311(defun get-class-and-method-id (class-name method-name descriptor is-static)
1312  (let ((class (local-ref-to-global-ref
1313                (try-null (jni-find-class class-name)))))
1314    (values class
1315            (if is-static
1316                (try-null (get-static-method-id class method-name descriptor))
1317              (try-null (get-method-id class method-name descriptor))))))
1318
1319
1320(defun get-class-and-field-id (class-name field-name descriptor is-static)
1321  (let ((class (local-ref-to-global-ref
1322                (try-null (jni-find-class class-name)))))
1323    (values class
1324            (if is-static
1325                (try-null (get-static-field-id class field-name descriptor))
1326              (try-null (get-field-id class field-name descriptor))))))
1327
1328(defun is-name-of-primitive (s)
1329  (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void")
1330          :test #'string-equal))
1331
1332(defun package-qualified-name (classname packagename)
1333  (cond
1334   ((is-name-of-primitive (subseq classname 0 (position #\< classname))) classname)
1335   ((find #\. classname) classname)     ;already qualified, presumably by another package
1336   (t (string-append packagename "." classname)))) 
1337
1338(defun split-package-and-class (name)
1339    (let ((p (position #\. name :from-end t)))
1340      (unless p (error "must supply package-qualified classname"))
1341      (values (subseq name 0 p)
1342              (subseq name (1+ p)))))
1343
1344(defun slot-from-typename (tn)
1345  (let ((prim (assoc tn
1346                     '(("boolean" . :z)
1347                       ("byte" . :b)
1348                       ("char" . :c)
1349                       ("short" . :s)
1350                       ("int" . :i)
1351                       ("long" . :j)
1352                       ("float" . :f)
1353                       ("double" . :d))
1354                     :test #'string-equal)))
1355    (if prim
1356        (rest prim)
1357      :l)))
1358
[11447]1359(defun jvalue-accessor-from-typename (tn)
1360  (let ((prim (assoc tn
1361                     '(("boolean" . :jvalue.z)
1362                       ("byte" . :jvalue.b)
1363                       ("char" . :jvalue.c)
1364                       ("short" . :jvalue.s)
1365                       ("int" . :jvalue.i)
1366                       ("long" . :jvalue.j)
1367                       ("float" . :jvalue.f)
1368                       ("double" . :jvalue.d))
1369                     :test #'string-equal)))
1370    (if prim
1371        (rest prim)
1372      :jvalue.l)))
1373
[11436]1374(defun name-component-from-typename (tn)
1375  (if (is-name-of-primitive tn)
1376      tn
1377    "object"))
1378
1379(defun type-descriptor-from-typename (tn)
1380  (let ((prim (assoc tn
1381                     '(("boolean" . "Z")
1382                       ("byte" . "B")
1383                       ("char" . "C")
1384                       ("short" . "S")
1385                       ("int" . "I")
1386                       ("long" . "J")
1387                       ("float" . "F")
1388                       ("double" . "D")
1389                       ("void" . "V"))
1390                     :test #'string-equal)))
1391    (if prim
1392        (rest prim)
1393      (let ((array-depth (count #\< tn))
1394            (tn-with-slashes (replace-substrings tn "." "/")))
1395        (if (= 0 array-depth)
1396            (string-append "L" tn-with-slashes ";")
1397          (with-output-to-string (s)
1398            (dotimes (x array-depth)
1399              (write-string "[" s))
1400            (write-string (type-descriptor-from-typename
1401                           (subseq tn-with-slashes 0 (position #\< tn-with-slashes))) s)))))))
1402
1403;not an exact reciprocal of type-descriptor-from-typename since reflection uses . not / as separator
1404(defun typename-from-reflection-type-descriptor (tn)
1405  (let ((prim (assoc tn
1406                     '(("Z" . "boolean")
1407                       ("B" . "byte")
1408                       ("C" . "char")
1409                       ("S" . "short")
1410                       ("I" . "int")
1411                       ("J" . "long")
1412                       ("F" . "float")
1413                       ("D" . "double")
1414                       ("V" . "void"))
1415                     :test #'string-equal)))
1416    (if prim
1417        (rest prim)
1418      (let ((array-depth (count #\[ tn)))
1419        (if (= 0 array-depth)
1420            (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
1421          (with-output-to-string (s)
1422            (write-string (typename-from-reflection-type-descriptor (subseq tn array-depth)) s)
1423            (dotimes (x array-depth)
1424              (write-string "<>" s))))))))
1425
1426(defun method-name-from-typename (tn static)
1427    (find-symbol (string-upcase (string-append "call-"
1428                                               (if static "static-" "")
1429                                             (name-component-from-typename tn)
1430                                             "-method-a")) :jni))
1431
1432(defun field-get-name-from-typename (tn static)
1433    (find-symbol (string-upcase (string-append "get-"
1434                                               (if static "static-" "")
1435                                             (name-component-from-typename tn)
1436                                             "-field")) :jni))
1437
1438(defun field-set-name-from-typename (tn static)
1439    (find-symbol (string-upcase (string-append "set-"
1440                                               (if static "static-" "")
1441                                             (name-component-from-typename tn)
1442                                             "-field")) :jni))
1443(defun process-return (return-type f &key raw-return)
1444  (cond
1445   ((or raw-return (is-name-of-primitive return-type)) f)
1446   ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f))
1447   (t `(local-ref-to-global-ref ,f))))
1448
1449;JNI wrapper generators - will create functions in current package
1450;this needs more docs
1451(defmacro define-java-function (fname class-name return-type method-name params &key static raw-return)
1452  (let ((this (gensym))
1453        (class (gensym))
1454        (id (gensym))
1455        (args (gensym)))
1456    `(let (,class ,id)
1457       (defun ,fname ,(if static (mapcar #'first params)
1458                        (cons this (mapcar #'first params)))
1459         (when (null ,class)
1460           (multiple-value-setq (,class ,id)
1461               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1462                                        ,method-name ,(build-descriptor params return-type) ,static)))
1463         (with-arg-array ,args ,(mapcar #'(lambda (param)
1464                                           (list (first param) (second param)))
1465                                       params)
1466           ,(process-return return-type
1467                            `(try (,(method-name-from-typename return-type static)
1468                                   ,(if static class this) ,id ,args))
1469                            :raw-return raw-return))))))
1470
1471(defmacro define-java-field (getname class-name field-type field-name &key static)
1472  (let ((this (gensym))
1473        (class (gensym))
1474        (id (gensym))
1475        (val (gensym)))
1476    `(let (,class ,id)
1477       (flet ((load-ids ()
1478                (when (null ,class)
1479                  (multiple-value-setq (,class ,id)
1480                      (get-class-and-field-id ,(replace-substrings class-name "." "/")
1481                                              ,field-name ,(type-descriptor-from-typename field-type)
1482                                              ,static)))))
1483         (defun ,getname ,(if static () (list this))
1484           (load-ids)
1485           ,(process-return field-type
1486                            `(try (,(field-get-name-from-typename field-type static)
1487                                   ,(if static class this) ,id))))
1488         (defun (setf ,getname) ,(if static (list val) (list this val))
1489           (load-ids)
1490           (try (,(field-set-name-from-typename field-type static)
1491                 ,(if static class this) ,id ,(process-arg val field-type)))
1492           ,val)))))
1493
1494(defmacro define-java-constructor (fname class-name params)
1495  (let ((class (gensym))
1496        (id (gensym))
1497        (args (gensym)))
1498    `(let (,class ,id)
1499       (defun ,fname ,(mapcar #'first params)
1500         (when (null ,class)
1501           (multiple-value-setq (,class ,id)
1502               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1503                                        "<init>" ,(build-descriptor params "void") nil)))
1504         (with-arg-array ,args ,(mapcar #'(lambda (param)
1505                                           (list (first param) (second param)))
1506                                       params)
1507           (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,args))))))))
1508
1509(defun make-func-name (class method params append-param-types)
1510  ;probably a format one-liner that can do this
1511    (let ((base (string-append class "." method)))
1512      (if append-param-types
1513          (string-append base
1514                         (let ((param-types (mapcar #'second params)))
1515                           (if param-types
1516                               (string-append "<"
1517                                              (reduce #'(lambda (x y)
1518                                                          (string-append x "-" y)) param-types)
1519                                              ">")
1520                             "<>")))
1521        base)))
1522
1523;these just do some name twiddling before calling define-java-xxx above
1524(defmacro def-jni-function (package-and-class method params return-typename
1525                                               &key static overloaded raw-return)
1526  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1527    (let* ((fname (make-func-name class method params overloaded))
1528           (fsym (read-from-string fname)))
1529      `(locally ,(list 'define-java-function
1530                     fsym
1531                     package-and-class
1532                     (package-qualified-name return-typename package)
1533                     method
1534                     (mapcar #'(lambda (p)
1535                                 (list (first p) (package-qualified-name (second p) package)))
1536                             params)
1537                     :static static :raw-return raw-return)))))
1538
1539(defmacro def-jni-functions (package-and-class &rest decls)
1540  `(locally ,@(mapcar #'(lambda (decl)
1541                          (list* 'def-jni-function package-and-class decl))
1542                      decls)))
1543
1544(defmacro def-jni-constructor (package-and-class params &key overloaded)
1545  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1546    (let* ((fname (make-func-name class "new" params overloaded))
1547           (fsym (read-from-string fname)))
1548      `(locally ,(list 'define-java-constructor
1549                     fsym 
1550                     package-and-class 
1551                     (mapcar #'(lambda (p)
1552                                 (list (first p) (package-qualified-name (second p) package)))
1553                             params))))))
1554
1555(defmacro def-jni-field (package-and-class field typename &key static)
1556  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1557    (let ((getsym (read-from-string (string-append class "." field
1558                                                   (if static "-accessor" ""))))
1559          (macsym (read-from-string (string-append class "." field))))
1560      `(locally 
1561         ,(list 'define-java-field getsym package-and-class
1562                (package-qualified-name typename package) field :static static)
1563         ,(when static
1564            `(define-symbol-macro ,macsym (,getsym)))))))
1565
1566;we're going to use a little Java to do exception handling below
1567(def-jni-function "java.lang.Object"
1568                   "toString" () "String")
1569
1570(def-jni-function "java.lang.reflect.InvocationTargetException"
1571                  "getTargetException" () "java.lang.Throwable")
1572
1573(def-jni-functions "java.lang.Throwable"
1574                   ("getMessage" () "String")
1575                   ("getStackTrace" () "StackTraceElement<>"))
1576
1577(defmacro do-jarray ((x array) &body body)
1578  (let ((gcount (gensym))
1579        (gi (gensym))
1580        (garray (gensym)))
1581    `(let* ((,garray ,array)
1582            (,gcount (get-array-length ,garray)))
1583       (dotimes (,gi ,gcount)
1584         (let ((,x (jaref ,garray ,gi)))
1585           ,@body)))))
1586
[11447]1587#||
[11436]1588It is critical that if you call a JNI function that might throw an exception that you clear it,
1589otherwise the next Java call you make will cause a crash
[11447]1590||#
1591
[11436]1592(defun handle-exception ()
1593  (let ((e (exception-occurred)))
[11447]1594    (when (not (ccl:%null-ptr-p e)) ;allow for safe calling in non-exceptional state
[11436]1595      (exception-clear)
1596      ;if the exception occurs in the reflection target, we really want that
1597      (when (is-instance-of e (jni-find-class "java/lang/reflect/InvocationTargetException"))
1598        (setf e (invocationtargetexception.gettargetexception e)))
1599      (error "~A" (with-output-to-string (s)
1600                    (format s "~A~%" (object.tostring e))
1601                    (do-jarray (x (throwable.getstacktrace e))
1602                      (format s "~A~%" (object.tostring x))))))))
1603
1604
1605
[11447]1606
1607
[11436]1608(defun try-neg (result)
1609  (if (minusp result)
1610      (handle-exception)
1611    result))
1612
1613
1614)
1615
[11447]1616
Note: See TracBrowser for help on using the repository browser.