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

Last change on this file since 16357 was 16357, checked in by rme, 4 years ago

In create-jvm, specify :utf-8 as encoding arg in call-with-string-vector.

Closes ticket:1275.

File size: 55.1 KB
Line 
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
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   ))
59
60(in-package :jni)
61
62(defclass java-object (ccl::foreign-standard-object)
63    ())
64
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
69(ccl::defloadvar *java-object-domain* nil)
70
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
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
98(eval-when (:compile-toplevel :load-toplevel :execute)
99  (ccl:use-interface-dir :jni))
100
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))))))
108
109(defvar *jni-lib-path*
110#+:darwin-target "/System/Library/Frameworks/JavaVM.framework/JavaVM"
111#+:win32-target "C:/Program Files/Java/jre6/bin/client/jvm.dll"
112#+android-target "libdvm.so"
113#-(or darwin-target win32-target android-target)
114"need to define *jni-lib-path*"
115"Set this to point to your jvm dll prior to calling create-jvm")
116
117(ccl::defloadvar *pvm* nil)
118
119;;; Map between lisp and Java booleans
120(eval-when (:compile-toplevel)
121  (declaim (inline jboolean-arg jboolean-result jobject-result jobject-arg)))
122
123(defun jboolean-arg (val)
124  (if (and val (not (eql val #$JNI_FALSE)))
125    #$JNI_TRUE
126    #$JNI_FALSE))
127
128(defun jobject-arg (val)
129  (or val ccl::+null-ptr+))
130
131
132(defun jboolean-result (val)
133  (not (eql val #$JNI_FALSE)))
134
135;;; Might also want to register p for termination (finalization).
136(defun jobject-result (val)
137  (unless (ccl::%null-ptr-p val)
138    (ccl::%set-macptr-domain val *java-object-domain*)
139    val))
140
141
142
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
147(defun load-jni-lib (&optional (libpath *jni-lib-path*))
148  (ccl:open-shared-library libpath))
149
150
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
164                      (pref jvm #>JavaVM.AttachCurrentThread)
165                      :address jvm
166                      :address pjnienv
167                      :address (ccl::%null-ptr)
168                      :jint))
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)))
173
174
175;;; JNIEnv functions.
176
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 
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))
195         (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot)))
196         (form
197          `(let* ((,env (current-env)))
198            (ff-call (pref ,env ,accessor) :address ,env ,@(process-jnienv-call-args specs) ,result-type))))
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                 
207
208(defun get-version ()
209  (jnienv-call ("GetVersion" :jint)))
210
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)))
218
219(defun jni-find-class (name)
220  (ccl::with-utf-8-cstrs ((cname name))
221    (jnienv-call ("FindClass" :jclass) :address cname)))
222
223
224(defun from-reflected-method (method)
225  (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method))
226
227(defun from-reflected-field (field)
228  (jnienv-call ("FromReflectedField" #>jfieldID) :jobject field))
229
230(defun to-reflected-method (cls method-id is-static)
231  (jnienv-call ("ToReflectedMethod" :jobject)
232               :jclass cls
233               #>jmethodID method-id
234               :jboolean is-static))
235
236(defun get-superclass (sub)
237  (jnienv-call ("GetSuperclass" :jclass) :jclass sub))
238
239(defun is-assignable-from (sub sup)
240 
241  (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup))
242
243(defun to-reflected-field (cls field-id is-static) 
244  (jnienv-call ("ToReflectedField" :jobject)
245               :jclass cls
246               #>jfieldID field-id
247               :jboolean is-static))
248
249(defun jni-throw (obj)
250  (jnienv-call ("Throw" :jint) :jthrowable obj))
251
252(defun throw-new (clazz msg)
253  (ccl::with-utf-8-cstrs ((cmsg msg))
254    (jnienv-call ("ThrowNew" :jint) :jclass clazz :address cmsg)))
255
256(defun exception-occurred ()
257  (jnienv-call ("ExceptionOccurred" :jthrowable)))
258
259(defun exception-describe ()
260  (jnienv-call ("ExceptionDescribe" :void)))
261
262(defun exception-clear ()
263  (jnienv-call ("ExceptionClear" :void)))
264
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))
271
272(defun pop-local-frame (result)
273 
274  (jnienv-call ("PopLocalFrame" :jobject) :jobject result))
275
276(defun new-global-ref (lobj)
277  (jnienv-call ("NewGlobalRef" :jobject) :jobject lobj))
278
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))
284
285(defun is-same-object (obj1 obj2)
286 
287  (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2))
288
289(defun new-local-ref (ref)
290 
291  (jnienv-call ("NewLocalRef" :jobject) :jobject ref))
292
293(defun ensure-local-capacity (capacity)
294  (jnienv-call ("EnsureLocalCapacity" :jint) :jint capacity))
295
296(defun alloc-object (clazz)
297  (jnienv-call ("AllocObject" :jobject) :jclass clazz))
298
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.
302
303(defun new-object-a (clazz method-id args)
304 
305  (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args))
306
307(defun get-object-class (obj)
308  (jnienv-call ("GetObjectClass" :jclass) :jobject obj))
309
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
320;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA.
321
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))
327
328(defun call-boolean-method-a (obj method-id args)
329 
330  (jnienv-call ("CallBooleanMethodA" :jboolean)
331               :jobject obj
332               #>jmethodID method-id
333               (:* :jvalue) args))
334
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))
340
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))
346
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))
352
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))
358
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))
364
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))
370
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)
391 
392  (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean)
393               :jobject obj
394               #>jmethodID method-id
395               (:* :jvalue) args))
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)
455 
456  (jnienv-call ("GetObjectField" :jobject)
457               :jobject obj
458               #>jfieldID field-id))
459
460(defun get-boolean-field (obj field-id)
461 
462  (jnienv-call ("GetBooleanField" :jboolean)
463               :jobject obj
464               #>jfieldID field-id))
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
512               :jboolean val))
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)
565 
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)
572 
573  (jnienv-call ("CallStaticBooleanMethodA" :jboolean)
574               :jclass clazz
575               #>jmethodID method-id
576               (:* :jvalue) args))
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)
640 
641  (jnienv-call ("GetStaticBooleanField" :jboolean)
642               :jclass clazz
643               #>jfieldID field-id))
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
691               :jboolean value))
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)))
765      (values chars  (pref is-copy :jboolean)))))
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 ()
1095  (jnienv-call ("ExceptionCheck" :jboolean)))
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
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
1123(defun create-jvm (&rest args)
1124  (declare (dynamic-extent args))
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)
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
1153                   (ff-call #+darwin-target (ccl::%kernel-import target::kernel-import-jvm-init)
1154                            #+darwin-target :address
1155                            (foreign-symbol-address "JNI_CreateJavaVM")
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
1166   :utf-8
1167   ))
1168
1169
1170;;;this is the FLI side of proxy support
1171
1172(defvar *invocation-handler* nil
1173  "this will be set by jfli:enable-java-proxies to a function of 3 args")
1174
1175
1176
1177;;;this will be set as the implementation of a native java function
1178
1179(defcallback |LispInvocationHandler_invoke|
1180    (:address env :jobject obj :jobject proxy :jobject method :jobject args :jobject)
1181  (jobject-result obj)
1182  (jobject-result proxy)
1183  (jobject-result method)
1184  (jobject-result args)
1185  (jobject-arg 
1186   (do-invoke env obj proxy method args)))
1187
1188
1189(defun do-invoke (env obj proxy method args)
1190  (declare (ignore env))                ;it's not like we're on another thread
1191  (when *invocation-handler*
1192    (prog1
1193        (funcall *invocation-handler* proxy method args)
1194      ;;(jfli::invocation-handler proxy method args)
1195      (delete-local-ref obj))))
1196
1197(defun try (result)
1198  (if (exception-check)
1199      (handle-exception)
1200    result))
1201
1202;JNI will sometimes indicate theere is an exception via a return value
1203;so take advantage of that when possible vs. the call back to exception-check
1204(defun try-null (result)
1205  (if (or (null result) (ccl:%null-ptr-p result))
1206      (handle-exception)
1207    result))
1208
1209(defun register-invocation-handler (invocation-handler)
1210  "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath"
1211  (setf *invocation-handler* invocation-handler)
1212  (rlet ((method #>JNINativeMethod))
1213    (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler"))))
1214      (with-cstrs ((name "invoke")
1215                   (signature "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;"))
1216        (setf (pref method #>JNINativeMethod.name) name
1217              (pref method #>JNINativeMethod.signature) signature
1218              (pref method #>JNINativeMethod.fnPtr) |LispInvocationHandler_invoke|)
1219      (register-natives lih method 1)))))
1220
1221
1222;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1223;the code below provides for the generation of wrapper functions that use JNI to access
1224;methods and fields. This low-level interface is unsafe, in that JNI will not
1225;check arg types etc on calls, and therefore should only be used to build safer high-level interfaces
1226;i.e. use jfli!
1227;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1228
1229;found on c.l.l
1230(eval-when (:compile-toplevel :load-toplevel :execute)
1231(defun replace-substrings (string substring replacement)
1232  (declare (optimize (speed 3))
1233           (type simple-string string substring replacement))
1234  (assert (> (length substring) 0) (substring)
1235    "Substring ~A must be of length ~D > 0"
1236    substring (length substring))
1237  (with-output-to-string (stream)
1238    (loop with substring-length = (length substring)
1239          for index = 0 then (+ match-index substring-length)
1240          for match-index = (search substring string :start2 index)
1241          do
1242          (write-string string stream :start index :end match-index)
1243          (when match-index
1244            (write-string replacement stream))
1245          while match-index)))
1246
1247
1248(defun local-ref-to-global-ref (lref)
1249  (when lref
1250    (let ((gref (new-global-ref lref)))
1251      #+laster
1252      (flag-special-free-action gref)
1253      (delete-local-ref lref)
1254      gref)))
1255
1256(defun local-ref-to-string (lref)
1257  (prog1
1258      (convert-from-java-string lref)
1259    (delete-local-ref lref)))
1260
1261(defun convert-to-java-string (s)
1262  (when s
1263    (try-null (new-string-utf (string s)))))
1264
1265(defun convert-from-java-string (s)
1266  (when s
1267    (let ((chars (try-null (get-string-utf-chars s))))
1268      (prog1
1269          (ccl::%get-utf-8-cstring chars)
1270        (release-string-utf-chars s chars)))))
1271
1272(defun jaref (array index)
1273  (try (get-object-array-element array index)))
1274
1275(defun (setf jaref) (val array index)
1276  (try (set-object-array-element array index val)))
1277
1278(defun convert-string-arg (s)
1279  "if s is stringp, make into java string, else presume it is a java string and return it"
1280  ;presumably faster than checking if s is a foreign pointer?
1281  (if (or (stringp s) (symbolp s))
1282      (convert-to-java-string s)
1283    s))
1284
1285(defun process-arg (val type)
1286  (if (string-equal "java.lang.String" type)
1287    `(convert-string-arg ,val)
1288    `(or ,val ccl::+null-ptr+)))
1289
1290(defmacro set-arg (args i val type)
1291  `(setf (pref (paref ,args (:* :jvalue) ,i)
1292          ,(jvalue-accessor-from-typename type))
1293    ,(process-arg val type)))
1294
1295(defmacro with-arg-array (arg-array-name args &body body)
1296  (let ((i -1))
1297  `(%stack-block ((,arg-array-name (*  ,(length args) (ccl::record-length :jvalue))))
1298       ,@(mapcar #'(lambda (arg)
1299                     (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) 
1300                 args)
1301
1302       ,@body)))
1303
1304(defun build-descriptor (params return-type)
1305  (string-append
1306   "("
1307   (apply #'string-append (mapcar #'(lambda (p)
1308                                      (type-descriptor-from-typename (second p)))
1309                                  params))
1310   ")"
1311   (type-descriptor-from-typename return-type)))
1312
1313(defun get-class-and-method-id (class-name method-name descriptor is-static)
1314  (let ((class (local-ref-to-global-ref
1315                (try-null (jni-find-class class-name)))))
1316    (values class
1317            (if is-static
1318                (try-null (get-static-method-id class method-name descriptor))
1319              (try-null (get-method-id class method-name descriptor))))))
1320
1321
1322(defun get-class-and-field-id (class-name field-name descriptor is-static)
1323  (let ((class (local-ref-to-global-ref
1324                (try-null (jni-find-class class-name)))))
1325    (values class
1326            (if is-static
1327                (try-null (get-static-field-id class field-name descriptor))
1328              (try-null (get-field-id class field-name descriptor))))))
1329
1330(defun is-name-of-primitive (s)
1331  (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void")
1332          :test #'string-equal))
1333
1334(defun package-qualified-name (classname packagename)
1335  (cond
1336   ((is-name-of-primitive (subseq classname 0 (position #\< classname))) classname)
1337   ((find #\. classname) classname)     ;already qualified, presumably by another package
1338   (t (string-append packagename "." classname)))) 
1339
1340(defun split-package-and-class (name)
1341    (let ((p (position #\. name :from-end t)))
1342      (unless p (error "must supply package-qualified classname"))
1343      (values (subseq name 0 p)
1344              (subseq name (1+ p)))))
1345
1346(defun slot-from-typename (tn)
1347  (let ((prim (assoc tn
1348                     '(("boolean" . :z)
1349                       ("byte" . :b)
1350                       ("char" . :c)
1351                       ("short" . :s)
1352                       ("int" . :i)
1353                       ("long" . :j)
1354                       ("float" . :f)
1355                       ("double" . :d))
1356                     :test #'string-equal)))
1357    (if prim
1358        (rest prim)
1359      :l)))
1360
1361(defun jvalue-accessor-from-typename (tn)
1362  (let ((prim (assoc tn
1363                     '(("boolean" . :jvalue.z)
1364                       ("byte" . :jvalue.b)
1365                       ("char" . :jvalue.c)
1366                       ("short" . :jvalue.s)
1367                       ("int" . :jvalue.i)
1368                       ("long" . :jvalue.j)
1369                       ("float" . :jvalue.f)
1370                       ("double" . :jvalue.d))
1371                     :test #'string-equal)))
1372    (if prim
1373        (rest prim)
1374      :jvalue.l)))
1375
1376(defun name-component-from-typename (tn)
1377  (if (is-name-of-primitive tn)
1378      tn
1379    "object"))
1380
1381(defun type-descriptor-from-typename (tn)
1382  (let ((prim (assoc tn
1383                     '(("boolean" . "Z")
1384                       ("byte" . "B")
1385                       ("char" . "C")
1386                       ("short" . "S")
1387                       ("int" . "I")
1388                       ("long" . "J")
1389                       ("float" . "F")
1390                       ("double" . "D")
1391                       ("void" . "V"))
1392                     :test #'string-equal)))
1393    (if prim
1394        (rest prim)
1395      (let ((array-depth (count #\< tn))
1396            (tn-with-slashes (replace-substrings tn "." "/")))
1397        (if (= 0 array-depth)
1398            (string-append "L" tn-with-slashes ";")
1399          (with-output-to-string (s)
1400            (dotimes (x array-depth)
1401              (write-string "[" s))
1402            (write-string (type-descriptor-from-typename
1403                           (subseq tn-with-slashes 0 (position #\< tn-with-slashes))) s)))))))
1404
1405;not an exact reciprocal of type-descriptor-from-typename since reflection uses . not / as separator
1406(defun typename-from-reflection-type-descriptor (tn)
1407  (let ((prim (assoc tn
1408                     '(("Z" . "boolean")
1409                       ("B" . "byte")
1410                       ("C" . "char")
1411                       ("S" . "short")
1412                       ("I" . "int")
1413                       ("J" . "long")
1414                       ("F" . "float")
1415                       ("D" . "double")
1416                       ("V" . "void"))
1417                     :test #'string-equal)))
1418    (if prim
1419        (rest prim)
1420      (let ((array-depth (count #\[ tn)))
1421        (if (= 0 array-depth)
1422            (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
1423          (with-output-to-string (s)
1424            (write-string (typename-from-reflection-type-descriptor (subseq tn array-depth)) s)
1425            (dotimes (x array-depth)
1426              (write-string "<>" s))))))))
1427
1428(defun method-name-from-typename (tn static)
1429    (find-symbol (string-upcase (string-append "call-"
1430                                               (if static "static-" "")
1431                                             (name-component-from-typename tn)
1432                                             "-method-a")) :jni))
1433
1434(defun field-get-name-from-typename (tn static)
1435    (find-symbol (string-upcase (string-append "get-"
1436                                               (if static "static-" "")
1437                                             (name-component-from-typename tn)
1438                                             "-field")) :jni))
1439
1440(defun field-set-name-from-typename (tn static)
1441    (find-symbol (string-upcase (string-append "set-"
1442                                               (if static "static-" "")
1443                                             (name-component-from-typename tn)
1444                                             "-field")) :jni))
1445(defun process-return (return-type f &key raw-return)
1446  (cond
1447   ((or raw-return (is-name-of-primitive return-type)) f)
1448   ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f))
1449   (t `(local-ref-to-global-ref ,f))))
1450
1451;JNI wrapper generators - will create functions in current package
1452;this needs more docs
1453(defmacro define-java-function (fname class-name return-type method-name params &key static raw-return)
1454  (let ((this (gensym))
1455        (class (gensym))
1456        (id (gensym))
1457        (args (gensym)))
1458    `(let (,class ,id)
1459       (defun ,fname ,(if static (mapcar #'first params)
1460                        (cons this (mapcar #'first params)))
1461         (when (null ,class)
1462           (multiple-value-setq (,class ,id)
1463               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1464                                        ,method-name ,(build-descriptor params return-type) ,static)))
1465         (with-arg-array ,args ,(mapcar #'(lambda (param)
1466                                           (list (first param) (second param)))
1467                                       params)
1468           ,(process-return return-type
1469                            `(try (,(method-name-from-typename return-type static)
1470                                   ,(if static class this) ,id ,args))
1471                            :raw-return raw-return))))))
1472
1473(defmacro define-java-field (getname class-name field-type field-name &key static)
1474  (let ((this (gensym))
1475        (class (gensym))
1476        (id (gensym))
1477        (val (gensym)))
1478    `(let (,class ,id)
1479       (flet ((load-ids ()
1480                (when (null ,class)
1481                  (multiple-value-setq (,class ,id)
1482                      (get-class-and-field-id ,(replace-substrings class-name "." "/")
1483                                              ,field-name ,(type-descriptor-from-typename field-type)
1484                                              ,static)))))
1485         (defun ,getname ,(if static () (list this))
1486           (load-ids)
1487           ,(process-return field-type
1488                            `(try (,(field-get-name-from-typename field-type static)
1489                                   ,(if static class this) ,id))))
1490         (defun (setf ,getname) ,(if static (list val) (list this val))
1491           (load-ids)
1492           (try (,(field-set-name-from-typename field-type static)
1493                 ,(if static class this) ,id ,(process-arg val field-type)))
1494           ,val)))))
1495
1496(defmacro define-java-constructor (fname class-name params)
1497  (let ((class (gensym))
1498        (id (gensym))
1499        (args (gensym)))
1500    `(let (,class ,id)
1501       (defun ,fname ,(mapcar #'first params)
1502         (when (null ,class)
1503           (multiple-value-setq (,class ,id)
1504               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1505                                        "<init>" ,(build-descriptor params "void") nil)))
1506         (with-arg-array ,args ,(mapcar #'(lambda (param)
1507                                           (list (first param) (second param)))
1508                                       params)
1509           (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,args))))))))
1510
1511(defun make-func-name (class method params append-param-types)
1512  ;probably a format one-liner that can do this
1513    (let ((base (string-append class "." method)))
1514      (if append-param-types
1515          (string-append base
1516                         (let ((param-types (mapcar #'second params)))
1517                           (if param-types
1518                               (string-append "<"
1519                                              (reduce #'(lambda (x y)
1520                                                          (string-append x "-" y)) param-types)
1521                                              ">")
1522                             "<>")))
1523        base)))
1524
1525;these just do some name twiddling before calling define-java-xxx above
1526(defmacro def-jni-function (package-and-class method params return-typename
1527                                               &key static overloaded raw-return)
1528  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1529    (let* ((fname (make-func-name class method params overloaded))
1530           (fsym (read-from-string fname)))
1531      `(locally ,(list 'define-java-function
1532                     fsym
1533                     package-and-class
1534                     (package-qualified-name return-typename package)
1535                     method
1536                     (mapcar #'(lambda (p)
1537                                 (list (first p) (package-qualified-name (second p) package)))
1538                             params)
1539                     :static static :raw-return raw-return)))))
1540
1541(defmacro def-jni-functions (package-and-class &rest decls)
1542  `(locally ,@(mapcar #'(lambda (decl)
1543                          (list* 'def-jni-function package-and-class decl))
1544                      decls)))
1545
1546(defmacro def-jni-constructor (package-and-class params &key overloaded)
1547  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1548    (let* ((fname (make-func-name class "new" params overloaded))
1549           (fsym (read-from-string fname)))
1550      `(locally ,(list 'define-java-constructor
1551                     fsym 
1552                     package-and-class 
1553                     (mapcar #'(lambda (p)
1554                                 (list (first p) (package-qualified-name (second p) package)))
1555                             params))))))
1556
1557(defmacro def-jni-field (package-and-class field typename &key static)
1558  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1559    (let ((getsym (read-from-string (string-append class "." field
1560                                                   (if static "-accessor" ""))))
1561          (macsym (read-from-string (string-append class "." field))))
1562      `(locally 
1563         ,(list 'define-java-field getsym package-and-class
1564                (package-qualified-name typename package) field :static static)
1565         ,(when static
1566            `(define-symbol-macro ,macsym (,getsym)))))))
1567
1568;we're going to use a little Java to do exception handling below
1569(def-jni-function "java.lang.Object"
1570                   "toString" () "String")
1571
1572(def-jni-function "java.lang.reflect.InvocationTargetException"
1573                  "getTargetException" () "java.lang.Throwable")
1574
1575(def-jni-functions "java.lang.Throwable"
1576                   ("getMessage" () "String")
1577                   ("getStackTrace" () "StackTraceElement<>"))
1578
1579(defmacro do-jarray ((x array) &body body)
1580  (let ((gcount (gensym))
1581        (gi (gensym))
1582        (garray (gensym)))
1583    `(let* ((,garray ,array)
1584            (,gcount (get-array-length ,garray)))
1585       (dotimes (,gi ,gcount)
1586         (let ((,x (jaref ,garray ,gi)))
1587           ,@body)))))
1588
1589#||
1590It is critical that if you call a JNI function that might throw an exception that you clear it,
1591otherwise the next Java call you make will cause a crash
1592||#
1593
1594(defun handle-exception ()
1595  (let ((e (exception-occurred)))
1596    (when (not (ccl:%null-ptr-p e)) ;allow for safe calling in non-exceptional state
1597      (exception-clear)
1598      ;if the exception occurs in the reflection target, we really want that
1599      (when (is-instance-of e (jni-find-class "java/lang/reflect/InvocationTargetException"))
1600        (setf e (invocationtargetexception.gettargetexception e)))
1601      (error "~A" (with-output-to-string (s)
1602                    (format s "~A~%" (object.tostring e))
1603                    (do-jarray (x (throwable.getstacktrace e))
1604                      (format s "~A~%" (object.tostring x))))))))
1605
1606
1607
1608
1609
1610(defun try-neg (result)
1611  (if (minusp result)
1612      (handle-exception)
1613    result))
1614
1615
1616)
1617
1618
Note: See TracBrowser for help on using the repository browser.