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

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

Some down, some to go ...

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