source: trunk/source/examples/jfli/jni.lisp @ 11557

Last change on this file since 11557 was 11557, checked in by gb, 12 years ago

Provide a plausible Win32 default for *JNI-LIB-PATH*.

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