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

Last change on this file since 15189 was 15189, checked in by gb, 7 years ago

Move jni.lisp from examples/jfli/ to library. We don't need the
kernel-imprort-jvm-init hack on Darwin anymore.

Tweak the jfli swtdemo to REQUIRE jni.

I imagine that more stuff will need to be modified/moved around
in order to make things work and make things more general.

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