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

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

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