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

Last change on this file since 11435 was 11435, checked in by gb, 13 years ago

Rich Hickey's 'jfli' (Lisp<->Java) bridge, as of jfli091104.zip.
The file 'jni.lisp' is LispWorks?-specific FFI code; there'll need
to be something CCL-specific that exports the same interface.

Text files in the .zip were CRLF-terminated; hopefully, svn will
fix that ...

File size: 62.8 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(defvar *jni-lib-path*
59#+:MACOSX "/System/Library/Frameworks/JavaVM.framework/JavaVM"
60#+:WIN32 "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
61"Set this to point to your jvm dll prior to calling create-jvm")
62
63(defparameter *pvm* nil)
64(defparameter *penv* nil)
65
66(defparameter *process-envs* nil)
67
68(defconstant JNI-VERSION-1-2 #X10002)
69(defconstant JNI-VERSION-1-4 #X10004)
70(defconstant JNI-OK 0)
71
72(defun load-jni-lib (&optional (libpath *jni-lib-path*))
73  (fli:register-module :jni-lib
74                     :real-name libpath
75                     :connection-style :immediate))
76
77(fli:define-c-typedef pvoid (:ptr :void))
78(fli:define-c-typedef const-char-* (:reference-pass :ef-mb-string))
79(fli:define-c-typedef const-jchar-* (:reference-pass :ef-wc-string))
80(fli:define-foreign-pointer (java-ref (:allow-null t) (:predicate java-ref-p)) pvoid)
81
82(fli:define-c-typedef jvoid :void)
83(fli:define-c-typedef jboolean (:boolean (:unsigned :byte)))
84(fli:define-c-typedef jbyte :byte)
85(fli:define-c-typedef jchar :wchar-t)
86(fli:define-c-typedef jshort :short)
87(fli:define-c-typedef jint :int)
88(fli:define-c-typedef jlong :long-long)
89(fli:define-c-typedef jfloat :float)
90(fli:define-c-typedef jdouble :double)
91(fli:define-c-typedef jsize jint)
92(fli:define-c-typedef jobject java-ref)
93(fli:define-c-typedef jclass java-ref)
94(fli:define-c-typedef jthrowable java-ref)
95(fli:define-c-typedef jstring java-ref)
96(fli:define-c-typedef jarray java-ref)
97(fli:define-c-typedef jboolean-array java-ref)
98(fli:define-c-typedef jbyte-array java-ref)
99(fli:define-c-typedef jchar-array java-ref)
100(fli:define-c-typedef jshort-array java-ref)
101(fli:define-c-typedef jint-array java-ref)
102(fli:define-c-typedef jlong-array java-ref)
103(fli:define-c-typedef jfloat-array java-ref)
104(fli:define-c-typedef jdouble-array java-ref)
105(fli:define-c-typedef jobject-array java-ref)
106(fli:define-c-typedef jfield-id pvoid)
107(fli:define-c-typedef jmethod-id pvoid)
108(fli:define-c-typedef jweak java-ref)
109
110(fli:define-c-typedef pvm (:ptr (:ptr java-vm)))
111(fli:define-c-typedef penv (:ptr (:ptr jni-env)))
112(fli:define-foreign-type pfunc (&rest fargs)
113  `(:ptr (:function ,@fargs)))
114
115(fli:define-c-union jvalue
116  (:z jboolean)
117  (:b jbyte)
118  (:c jchar)
119  (:s jshort)
120  (:i jint)
121  (:j jlong)
122  (:f jfloat)
123  (:d jdouble)
124  (:l jobject))
125
126(fli:define-c-typedef arg-array (:c-array jvalue))
127
128(eval-when (:compile-toplevel)
129  (defun build-struct-entries (name members)
130    (mapcar #'(lambda (member)
131                (if (= 2 (length member)) ;padding or other non-function entry
132                    member
133                  (destructuring-bind (func args ret &key lambda-list) member
134                    (declare (ignore lambda-list))
135                    `(,func (pfunc ,(cons `(:ptr (:ptr ,name))
136                                          (mapcar #'second args))
137                                   ,ret)))))
138            members)))
139
140(eval-when (:compile-toplevel)
141  (defun build-access-functions (name global members)
142    (mapcar #'(lambda (member)
143                (if (= 2 (length member)) ;padding or other non-function entry
144                    ()
145                  (destructuring-bind (func args ret &key lambda-list) member
146                    (let ((thunk (intern (concatenate 'string (symbol-name func) "-thunk")))
147                          (genv (gensym))
148                        ;(func (intern (symbol-name f)))
149                          )
150                      `(locally
151                         (fli:define-foreign-funcallable
152                          ,thunk
153                          ,(cons `(this (:ptr (:ptr ,name))) args)
154                          :result-type ,ret)
155                         (defun ,func ,(if lambda-list
156                                           lambda-list
157                                         (mapcar #'first args))
158                           (let ((,genv ,global))
159                             (,thunk
160                              (fli:foreign-slot-value (fli:dereference ,genv) ',func)
161                              ,genv
162                              ,@(mapcar #'first args))))
163                         (export ',func))))))
164            members)))
165
166(defmacro defvtable (name global &rest members)
167  `(locally
168     (fli:define-c-struct ,name ,@(build-struct-entries name members))
169     ,@(build-access-functions name global members)))
170
171(fli:define-c-struct jni-native-method
172  (name (:ptr :char))
173  (signature (:ptr :char))
174  (fn-ptr pvoid)
175  )
176
177(defun current-env ()
178  "memoizes attach-current-thread per process"
179  (or
180   *penv*
181   (cdr (assoc mp:*current-process* *process-envs*))
182   (multiple-value-bind (ret env) (attach-current-thread)
183     (declare (ignore ret))
184     (push (cons mp:*current-process* env) *process-envs*)
185     env)))
186
187(defvtable jni-env (current-env)
188           (reserved-0 pvoid)                                              ;0
189           (reserved-1 pvoid)                                              ;1
190           (reserved-2 pvoid)                                              ;2
191           (reserved-3 pvoid)                                              ;3
192  ;some mac nonsense requires this non-portable padding, so much for a binary spec
193           #+:MACOSX  (cfm-padding (:foreign-array pvoid (225)))
194           (get-version () jint)                                           ;4
195           (define-class ((name const-char-*)                              ;5
196                          (loader jobject)
197                          (buf (:ptr jbyte))
198                          (len jsize)) jclass) 
199           (jni-find-class ((name const-char-*)) jclass)                       ;6
200           (from-reflected-method ((method jobject)) jmethod-id)           ;7
201           (from-reflected-field ((field jobject)) jfield-id)              ;8
202           (to-reflected-method ((cls jclass)                              ;9
203                                 (method-id jmethod-id)
204                                 (is-static jboolean)) jobject)
205           (get-superclass ((clazz jclass)) jclass)                        ;10
206           (is-assignable-from ((sub jclass)                               ;11
207                                (sup jclass)) jboolean)
208           (to-reflected-field ((cls jclass)                               ;12
209                                (field-id jfield-id)
210                                (is-static jboolean)) jobject)
211           (jni-throw ((obj jthrowable)) jint)                                 ;13
212           (throw-new ((clazz jclass)                                      ;14
213                       (msg const-char-*)) jint)
214           (exception-occurred () jthrowable)                              ;15
215           (exception-describe () :void)                                   ;16
216           (exception-clear () :void)                                      ;17
217           (fatal-error ((msg const-char-*)) :void)                        ;18
218           (push-local-frame ((capacity jint)) jint)                       ;19
219           (pop-local-frame ((result jobject)) jobject)                    ;20
220           (new-global-ref ((lobj jobject)) jobject)                       ;21
221           (delete-global-ref ((gref jobject)) :void)                      ;22
222           (delete-local-ref ((lref jobject)) :void)                       ;23
223           (is-same-object ((obj1 jobject)                                 ;24
224                            (obj2 jobject)) jboolean)
225           (new-local-ref ((ref jobject)) jobject)                         ;25
226           (ensure-local-capacity ((capacity jint)) jint)                  ;26
227           (alloc-object ((clazz jclass)) jobject)                         ;27
228           (new-object pvoid)                                              ;28
229           (new-object-v pvoid)                                            ;29
230           (new-object-a ((clazz jclass)                                   ;30
231                          (method-id jmethod-id)
232                          (args arg-array)) jobject)
233           (get-object-class ((obj jobject)) jclass)                       ;31
234           (is-instance-of ((obj jobject)                                  ;32
235                            (clazz jclass)) jboolean)
236           (get-method-id ((clazz jclass)                                  ;33
237                           (name const-char-*)
238                           (sig const-char-*)) jmethod-id)
239
240           (call-object-method pvoid)                                      ;34
241           (call-object-method-v pvoid)                                    ;35
242           (call-object-method-a ((obj jobject)                            ;36
243                                  (method-id jmethod-id)
244                                  (args arg-array)) jobject)
245           (call-boolean-method pvoid)                                     ;37
246           (call-boolean-method-v pvoid)                                   ;38
247           (call-boolean-method-a ((obj jobject)                           ;39
248                                   (method-id jmethod-id)                 
249                                   (args arg-array)) jboolean)
250           (call-byte-method pvoid)                                        ;40
251           (call-byte-method-v pvoid)                                      ;41
252           (call-byte-method-a ((obj jobject)                              ;42
253                                (method-id jmethod-id)
254                                (args arg-array)) jbyte)
255           (call-char-method pvoid)                                        ;43
256           (call-char-method-v pvoid)                                      ;44
257           (call-char-method-a ((obj jobject)                              ;45
258                                (method-id jmethod-id)
259                                (args arg-array)) jchar)
260           (call-short-method pvoid)                                       ;46
261           (call-short-method-v pvoid)                                     ;47
262           (call-short-method-a ((obj jobject)                             ;48
263                                 (method-id jmethod-id)
264                                 (args arg-array)) jshort)
265           (call-int-method pvoid)                                         ;49
266           (call-int-method-v pvoid)                                       ;50
267           (call-int-method-a ((obj jobject)                               ;51
268                               (method-id jmethod-id)
269                               (args arg-array)) jint)
270           (call-long-method pvoid)                                        ;52
271           (call-long-method-v pvoid)                                      ;53
272           (call-long-method-a ((obj jobject)                              ;54
273                                (method-id jmethod-id)
274                                (args arg-array)) jlong)
275           (call-float-method pvoid)                                       ;55
276           (call-float-method-v pvoid)                                     ;56
277           (call-float-method-a ((obj jobject)                             ;57
278                                 (method-id jmethod-id)
279                                 (args arg-array)) jfloat)
280           (call-double-method pvoid)                                      ;58
281           (call-double-method-v pvoid)                                    ;59
282           (call-double-method-a ((obj jobject)                            ;60
283                                  (method-id jmethod-id)
284                                  (args arg-array)) jdouble)
285           (call-void-method pvoid)                                        ;61
286           (call-void-method-v pvoid)                                      ;62
287           (call-void-method-a ((obj jobject)                              ;63
288                                (method-id jmethod-id)
289                                (args arg-array)) jvoid)
290
291           (call-nonvirtual-object-method pvoid)                           ;64
292           (call-nonvirtual-object-method-v pvoid)                         ;65
293           (call-nonvirtual-object-method-a ((obj jobject)                 ;66
294                                             (clazz jclass)
295                                             (method-id jmethod-id)
296                                             (args arg-array)) jobject)
297           (call-nonvirtual-boolean-method pvoid)                          ;67
298           (call-nonvirtual-boolean-method-v pvoid)                        ;68
299           (call-nonvirtual-boolean-method-a ((obj jobject)                ;69
300                                              (clazz jclass)
301                                              (method-id jmethod-id)
302                                              (args arg-array)) jboolean)
303           (call-nonvirtual-byte-method pvoid)                             ;70
304           (call-nonvirtual-byte-method-v pvoid)                           ;71
305           (call-nonvirtual-byte-method-a ((obj jobject)                   ;72
306                                           (clazz jclass)
307                                           (method-id jmethod-id)
308                                           (args arg-array)) jbyte)
309           (call-nonvirtual-char-method pvoid)                             ;73
310           (call-nonvirtual-char-method-v pvoid)                           ;74
311           (call-nonvirtual-char-method-a ((obj jobject)                   ;75
312                                           (clazz jclass)
313                                           (method-id jmethod-id)
314                                           (args arg-array)) jchar)
315           (call-nonvirtual-short-method pvoid)                            ;76
316           (call-nonvirtual-short-method-v pvoid)                          ;77
317           (call-nonvirtual-short-method-a ((obj jobject)                  ;78
318                                            (clazz jclass)
319                                            (method-id jmethod-id)
320                                            (args arg-array)) jshort)
321           (call-nonvirtual-int-method pvoid)                              ;79
322           (call-nonvirtual-int-method-v pvoid)                            ;80
323           (call-nonvirtual-int-method-a ((obj jobject)                    ;81
324                                          (clazz jclass)
325                                          (method-id jmethod-id)
326                                          (args arg-array)) jint)
327           (call-nonvirtual-long-method pvoid)                             ;82
328           (call-nonvirtual-long-method-v pvoid)                           ;83
329           (call-nonvirtual-long-method-a ((obj jobject)                   ;84
330                                           (clazz jclass)
331                                           (method-id jmethod-id)
332                                           (args arg-array)) jlong)
333           (call-nonvirtual-float-method pvoid)                            ;85
334           (call-nonvirtual-float-method-v pvoid)                          ;86
335           (call-nonvirtual-float-method-a ((obj jobject)                  ;87
336                                            (clazz jclass)
337                                            (method-id jmethod-id)
338                                            (args arg-array)) jfloat)
339           (call-nonvirtual-double-method pvoid)                           ;88
340           (call-nonvirtual-double-method-v pvoid)                         ;89
341           (call-nonvirtual-double-method-a ((obj jobject)                 ;90
342                                             (clazz jclass)
343                                             (method-id jmethod-id)
344                                             (args arg-array)) jdouble)
345           (call-nonvirtual-void-method pvoid)                             ;91
346           (call-nonvirtual-void-method-v pvoid)                           ;92
347           (call-nonvirtual-void-method-a ((obj jobject)                   ;93
348                                           (clazz jclass)
349                                           (method-id jmethod-id)
350                                           (args arg-array)) jvoid)
351           (get-field-id ((clazz jclass)                                   ;94
352                          (name const-char-*)
353                          (sig const-char-*)) jfield-id)
354
355           (get-object-field ((obj jobject)                                ;95
356                              (field-id jfield-id)) jobject)
357           (get-boolean-field ((obj jobject)                               ;96
358                               (field-id jfield-id)) jboolean) 
359           (get-byte-field ((obj jobject)                                  ;97
360                            (field-id jfield-id)) jbyte) 
361           (get-char-field ((obj jobject)                                  ;98
362                            (field-id jfield-id)) jchar) 
363           (get-short-field ((obj jobject)                                 ;99
364                             (field-id jfield-id)) jshort) 
365           (get-int-field ((obj jobject)                                   ;100
366                           (field-id jfield-id)) jint) 
367           (get-long-field ((obj jobject)                                  ;101
368                            (field-id jfield-id)) jlong) 
369           (get-float-field ((obj jobject)                                 ;102
370                             (field-id jfield-id)) jfloat) 
371           (get-double-field ((obj jobject)                                ;103
372                              (field-id jfield-id)) jdouble) 
373
374           (set-object-field ((obj jobject)                                ;104
375                              (field-id jfield-id)
376                              (val jobject)) jvoid)
377           (set-boolean-field ((obj jobject)                               ;105
378                               (field-id jfield-id)
379                               (val jboolean)) jvoid)
380           (set-byte-field ((obj jobject)                                  ;106
381                            (field-id jfield-id)
382                            (val jbyte)) jvoid)
383           (set-char-field ((obj jobject)                                  ;107
384                            (field-id jfield-id)
385                            (val jchar)) jvoid)
386           (set-short-field ((obj jobject)                                 ;108
387                             (field-id jfield-id)
388                             (val jshort)) jvoid)
389           (set-int-field ((obj jobject)                                   ;109
390                           (field-id jfield-id)
391                           (val jint)) jvoid)
392           (set-long-field ((obj jobject)                                  ;110
393                            (field-id jfield-id)
394                            (val jlong)) jvoid)
395           (set-float-field ((obj jobject)                                 ;111
396                             (field-id jfield-id)
397                             (val jfloat)) jvoid)
398           (set-double-field ((obj jobject)                                ;112
399                              (field-id jfield-id)
400                              (val jdouble)) jvoid)
401
402           (get-static-method-id ((clazz jclass)                           ;113
403                                  (name const-char-*)
404                                  (sig const-char-*)) jmethod-id)
405
406           (call-static-object-method pvoid)                               ;114
407           (call-static-object-method-v pvoid)                             ;115
408           (call-static-object-method-a ((clazz jclass)                    ;116
409                                         (method-id jmethod-id)
410                                         (args arg-array)) jobject)
411           (call-static-boolean-method pvoid)                              ;117
412           (call-static-boolean-method-v pvoid)                            ;118
413           (call-static-boolean-method-a ((clazz jclass)                   ;119
414                                          (method-id jmethod-id)
415                                          (args arg-array)) jboolean)
416           (call-static-byte-method pvoid)                                 ;120
417           (call-static-byte-method-v pvoid)                               ;121
418           (call-static-byte-method-a ((clazz jclass)                      ;122
419                                       (method-id jmethod-id)
420                                       (args arg-array)) jbyte)
421           (call-static-char-method pvoid)                                 ;123
422           (call-static-char-method-v pvoid)                               ;124
423           (call-static-char-method-a ((clazz jclass)                      ;125
424                                       (method-id jmethod-id)
425                                       (args arg-array)) jchar)
426           (call-static-short-method pvoid)                                ;126
427           (call-static-short-method-v pvoid)                              ;127
428           (call-static-short-method-a ((clazz jclass)                     ;128
429                                        (method-id jmethod-id)
430                                        (args arg-array)) jshort)
431           (call-static-int-method pvoid)                                  ;129
432           (call-static-int-method-v pvoid)                                ;130
433           (call-static-int-method-a ((clazz jclass)                       ;131
434                                      (method-id jmethod-id)
435                                      (args arg-array)) jint)
436           (call-static-long-method pvoid)                                 ;132
437           (call-static-long-method-v pvoid)                               ;133
438           (call-static-long-method-a ((clazz jclass)                      ;134
439                                       (method-id jmethod-id)
440                                       (args arg-array)) jlong)
441           (call-static-float-method pvoid)                                ;135
442           (call-static-float-method-v pvoid)                              ;136
443           (call-static-float-method-a ((clazz jclass)                     ;137
444                                        (method-id jmethod-id)
445                                        (args arg-array)) jfloat)
446           (call-static-double-method pvoid)                               ;138
447           (call-static-double-method-v pvoid)                             ;139
448           (call-static-double-method-a ((clazz jclass)                    ;140
449                                         (method-id jmethod-id)
450                                         (args arg-array)) jdouble)
451           (call-static-void-method pvoid)                                 ;141
452           (call-static-void-method-v pvoid)                               ;142
453           (call-static-void-method-a ((clazz jclass)                      ;143
454                                       (method-id jmethod-id)
455                                       (args arg-array)) jvoid)
456
457           (get-static-field-id ((clazz jclass)                            ;144
458                                 (name const-char-*)
459                                 (sig const-char-*)) jfield-id)
460
461           (get-static-object-field ((clazz jclass)                        ;145
462                                     (field-id jfield-id)) jobject)
463           (get-static-boolean-field ((clazz jclass)                       ;146
464                                      (field-id jfield-id)) jboolean)
465           (get-static-byte-field ((clazz jclass)                          ;147
466                                   (field-id jfield-id)) jbyte)
467           (get-static-char-field ((clazz jclass)                          ;148
468                                   (field-id jfield-id)) jchar)
469           (get-static-short-field ((clazz jclass)                         ;149
470                                    (field-id jfield-id)) jshort)
471           (get-static-int-field ((clazz jclass)                           ;150
472                                  (field-id jfield-id)) jint)
473           (get-static-long-field ((clazz jclass)                          ;151
474                                   (field-id jfield-id)) jlong)
475           (get-static-float-field ((clazz jclass)                         ;152
476                                    (field-id jfield-id)) jfloat)
477           (get-static-double-field ((clazz jclass)                        ;153
478                                     (field-id jfield-id)) jdouble)
479
480           (set-static-object-field ((clazz jclass)                        ;154
481                                     (field-id jfield-id)
482                                     (val jobject)) jvoid)
483           (set-static-boolean-field ((clazz jclass)                       ;155
484                                      (field-id jfield-id)
485                                      (val jboolean)) jvoid)
486           (set-static-byte-field ((clazz jclass)                          ;156
487                                   (field-id jfield-id)
488                                   (val jbyte)) jvoid)
489           (set-static-char-field ((clazz jclass)                          ;157
490                                   (field-id jfield-id)
491                                   (val jchar)) jvoid)
492           (set-static-short-field ((clazz jclass)                         ;158
493                                    (field-id jfield-id)
494                                    (val jshort)) jvoid)
495           (set-static-int-field ((clazz jclass)                           ;159
496                                  (field-id jfield-id)
497                                  (val jint)) jvoid)
498           (set-static-long-field ((clazz jclass)                          ;160
499                                   (field-id jfield-id)
500                                   (val jlong)) jvoid)
501           (set-static-float-field ((clazz jclass)                         ;161
502                                    (field-id jfield-id)
503                                    (val jfloat)) jvoid)
504           (set-static-double-field ((clazz jclass)                        ;162
505                                     (field-id jfield-id)
506                                     (val jdouble)) jvoid)
507
508           (new-string ((uchars (:reference-pass :ef-wc-string))               ;163
509                        (len jsize)) jstring)
510           (get-string-length ((str jstring)) jsize)                       ;164
511           (get-string-chars ((str jstring)                                ;165
512                              (is-copy (:reference-return jboolean)))
513                             ;(:c-array jchar 1000)
514                             (:ptr :wchar-t)
515                             ;(:ef-wc-string :external-format :unicode)
516                             :lambda-list (str &optional is-copy))
517           (release-string-chars ((str jstring)                            ;166
518                                  (chars (:ptr jchar))) jvoid)
519
520           (new-string-utf ((chars const-char-*)) jstring)                 ;167
521           (get-string-utf-length ((str jstring)) jsize)                   ;168
522           (get-string-utf-chars ((str jstring)                            ;169
523                                  (is-copy (:reference-return jboolean)))
524                                 ;(:c-array :char 1000)
525                                 (:ptr :char)
526                                 :lambda-list (str &optional is-copy))
527           (release-string-utf-chars ((str jstring)                        ;170
528                                      (chars (:ptr :char))) jvoid)
529
530           (get-array-length ((array jarray)) jsize)                       ;171
531           
532           (new-object-array ((len jsize)                                  ;172
533                              (element-type jclass)
534                              (initial-element jobject)) jarray)
535           (get-object-array-element ((array jobject-array)                ;173
536                                      (index jsize)) jobject)
537           (set-object-array-element ((array jobject-array)                ;174
538                                      (index jsize)
539                                      (val jobject)) jvoid)
540
541           (new-boolean-array ((len jsize)) jboolean-array)                ;175
542           (new-byte-array ((len jsize)) jbyte-array)                      ;176
543           (new-char-array ((len jsize)) jchar-array)                      ;177
544           (new-short-array ((len jsize)) jshort-array)                    ;178
545           (new-int-array ((len jsize)) jint-array)                        ;179
546           (new-long-array ((len jsize)) jlong-array)                      ;180
547           (new-float-array ((len jsize)) jfloat-array)                    ;181
548           (new-double-array ((len jsize)) jdouble-array)                  ;182
549
550           (get-boolean-array-elements ((array jboolean-array)             ;183
551                                        (is-copy (:reference-return jboolean)))
552                                       (:ptr jboolean)
553                                       :lambda-list (array &optional is-copy))
554           (get-byte-array-elements ((array jbyte-array)                   ;184
555                                     (is-copy (:reference-return jboolean)))
556                                    (:ptr jbyte)
557                                    :lambda-list (array &optional is-copy))
558           (get-char-array-elements ((array jchar-array)                   ;185
559                                     (is-copy (:reference-return jboolean)))
560                                    (:ptr jchar)
561                                    :lambda-list (array &optional is-copy))
562           (get-short-array-elements ((array jshort-array)                 ;186
563                                      (is-copy (:reference-return jboolean)))
564                                     (:ptr jshort)
565                                     :lambda-list (array &optional is-copy))
566           (get-int-array-elements ((array jint-array)                     ;187
567                                    (is-copy (:reference-return jboolean)))
568                                   (:ptr jint)
569                                   :lambda-list (array &optional is-copy))
570           (get-long-array-elements ((array jlong-array)                   ;188
571                                     (is-copy (:reference-return jboolean)))
572                                    (:ptr jlong)
573                                    :lambda-list (array &optional is-copy))
574           (get-float-array-elements ((array jfloat-array)                 ;189
575                                      (is-copy (:reference-return jboolean)))
576                                     (:ptr jfloat)
577                                     :lambda-list (array &optional is-copy))
578           (get-double-array-elements ((array jdouble-array)               ;190
579                                       (is-copy (:reference-return jboolean)))
580                                      (:ptr jdouble)
581                                      :lambda-list (array &optional is-copy))
582
583           (release-boolean-array-elements ((array jboolean-array)         ;191
584                                            (elems (:ptr jboolean))
585                                            (mode jint)) jvoid
586                                           :lambda-list (array elems &optional (mode 0)))
587           (release-byte-array-elements ((array jbyte-array)               ;192
588                                         (elems (:ptr jbyte))
589                                         (mode jint)) jvoid
590                                        :lambda-list (array elems &optional (mode 0)))
591           (release-char-array-elements ((array jchar-array)               ;193
592                                         (elems (:ptr jchar))
593                                         (mode jint)) jvoid
594                                        :lambda-list (array elems &optional (mode 0)))
595           (release-short-array-elements ((array jshort-array)             ;194
596                                          (elems (:ptr jshort))
597                                          (mode jint)) jvoid
598                                         :lambda-list (array elems &optional (mode 0)))
599           (release-int-array-elements ((array jint-array)                 ;195
600                                        (elems (:ptr jint))
601                                        (mode jint)) jvoid
602                                       :lambda-list (array elems &optional (mode 0)))
603           (release-long-array-elements ((array jlong-array)               ;196
604                                         (elems (:ptr jlong))
605                                         (mode jint)) jvoid
606                                        :lambda-list (array elems &optional (mode 0)))
607           (release-float-array-elements ((array jfloat-array)             ;197
608                                          (elems (:ptr jfloat))
609                                          (mode jint)) jvoid
610                                         :lambda-list (array elems &optional (mode 0)))
611           (release-double-array-elements ((array jdouble-array)           ;198
612                                           (elems (:ptr jdouble))
613                                           (mode jint)) jvoid
614                                          :lambda-list (array elems &optional (mode 0)))
615
616           (get-boolean-array-region ((array jboolean-array)               ;199
617                                      (start jsize)
618                                      (len jsize)
619                                      (buf (:ptr jboolean))) jvoid)
620           (get-byte-array-region ((array jbyte-array)                     ;200
621                                   (start jsize)
622                                   (len jsize)
623                                   (buf (:ptr jbyte))) jvoid)
624           (get-char-array-region ((array jchar-array)                     ;201
625                                   (start jsize)
626                                   (len jsize)
627                                   (buf (:ptr jchar))) jvoid)
628           (get-short-array-region ((array jshort-array)                   ;202
629                                    (start jsize)
630                                    (len jsize)
631                                    (buf (:ptr jshort))) jvoid)
632           (get-int-array-region ((array jint-array)                       ;203
633                                  (start jsize)
634                                  (len jsize)
635                                  (buf (:ptr jint))) jvoid)
636           (get-long-array-region ((array jlong-array)                     ;204
637                                   (start jsize)
638                                   (len jsize)
639                                   (buf (:ptr jlong))) jvoid)
640           (get-float-array-region ((array jfloat-array)                   ;205
641                                    (start jsize)
642                                    (len jsize)
643                                    (buf (:ptr jfloat))) jvoid)
644           (get-double-array-region ((array jdouble-array)                 ;206
645                                     (start jsize)
646                                     (len jsize)
647                                     (buf (:ptr jdouble))) jvoid)
648
649           (set-boolean-array-region ((array jboolean-array)               ;207
650                                      (start jsize)
651                                      (len jsize)
652                                      (buf (:ptr jboolean))) jvoid)
653           (set-byte-array-region ((array jbyte-array)                     ;208
654                                   (start jsize)
655                                   (len jsize)
656                                   (buf (:ptr jbyte))) jvoid)
657           (set-char-array-region ((array jchar-array)                     ;209
658                                   (start jsize)
659                                   (len jsize)
660                                   (buf (:ptr jchar))) jvoid)
661           (set-short-array-region ((array jshort-array)                   ;210
662                                    (start jsize)
663                                    (len jsize)
664                                    (buf (:ptr jshort))) jvoid)
665           (set-int-array-region ((array jint-array)                       ;211
666                                  (start jsize)
667                                  (len jsize)
668                                  (buf (:ptr jint))) jvoid)
669           (set-long-array-region ((array jlong-array)                     ;212
670                                   (start jsize)
671                                   (len jsize)
672                                   (buf (:ptr jlong))) jvoid)
673           (set-float-array-region ((array jfloat-array)                   ;213
674                                    (start jsize)
675                                    (len jsize)
676                                    (buf (:ptr jfloat))) jvoid)
677           (set-double-array-region ((array jdouble-array)                 ;214
678                                     (start jsize)
679                                     (len jsize)
680                                     (buf (:ptr jdouble))) jvoid)
681
682           (register-natives ((clazz jclass)                               ;215
683                              (methods (:ptr jni-native-method))
684                              (n-methods jsize)) jint)
685           (unregister-natives ((clazz jclass)) jint)                      ;216
686           (monitor-enter ((obj jobject)) jint)                            ;217
687           (monitor-exit ((obj jobject)) jint)                             ;218
688
689           (get-java-vm ((vm (:reference-return pvm))) jint                ;219
690                        :lambda-list (&optional (vm t)))
691
692           (get-string-region ((str jstring)                               ;220
693                               (start jsize)
694                               (len jsize)
695                               (buf (:ptr jchar))) jvoid)
696           (get-string-utf-region ((str jstring)                           ;221
697                               (start jsize)
698                               (len jsize)
699                               (buf (:ptr :char))) jvoid)
700
701           (get-primitive-array-critical ((array jarray)                   ;222
702                                          (is-copy (:reference-return jboolean))) pvoid
703                                         :lambda-list (array &optional is-copy))
704           (release-primitive-array-critical ((array jarray)               ;223
705                                            (carray pvoid)
706                                            (mode jint)) jvoid
707                                           :lambda-list (array carray &optional (mode 0)))
708           
709           (get-string-critical ((str jstring)                             ;224
710                                 (is-copy (:reference-return jboolean)))
711                                (:ptr jchar)
712                                :lambda-list (str &optional is-copy))
713           (release-string-critical ((str jstring)                         ;225
714                                     (cstring (:ptr jchar))) jvoid)
715           (new-weak-global-ref ((obj jobject)) jweak)                     ;226
716           (delete-weak-global-ref ((ref jweak)) jvoid)                    ;227
717           (exception-check () jboolean)                                   ;228
718           )
719
720(defun get-pvm ()
721  (or *pvm*
722      (error "JVM not loaded")))
723
724(defvtable java-vm (get-pvm)
725  (reserved-0 pvoid)
726  (reserved-1 pvoid)
727  (reserved-2 pvoid)
728#+:MACOSX  (cfm-padding (:foreign-array pvoid (4)))
729  (destroy-java-vm () jint)
730  (attach-current-thread ((penv (:reference-return penv)) (args pvoid)) jint
731                         :lambda-list (&optional args (penv t)))
732  (detach-current-thread () jint)
733  (get-env ((penv (:reference-return penv)) (interface-id jint)) jint
734           :lambda-list (interface-id &optional (penv t))))
735 
736(fli:define-c-struct java-vm-option
737  (option-string (:ptr :char))
738  (extra-info pvoid))
739
740(fli:define-c-struct jdk-1-1-init-args
741  (version jint)
742  (properties (:ptr (:ptr char)))
743  (check-source jint)
744  (native-stack-size jint)
745  (java-stack-size jint)
746  (min-heap-size jint)
747  (max-heap-size jint)
748  (verify-mode jint)
749  (class-path (:ptr :char))
750  (vprintf pvoid)
751  (exit pvoid)
752  (abort pvoid)
753  (enable-class-gc jint)
754  (enable-verbose-gc jint)
755  (disable-async-gc jint)
756  (reserved-0 jint)
757  (reserved-1 jint)
758  (reserved-2 jint))
759 
760(fli:define-foreign-function (jni-get-default-java-vm-init-args "JNI_GetDefaultJavaVMInitArgs")
761    ((init-args (:ptr jdk-1-1-init-args)))
762  :result-type jint)
763
764(fli:define-c-struct java-vm-init-args
765  (version jint)
766  (n-options jint)
767  (options (:ptr java-vm-option))
768  (ignore-unrecognized jboolean))
769
770(fli:define-foreign-function (jni-create-java-vm "JNI_CreateJavaVM" :source)
771    ((pvm (:reference-return pvm))
772     (penv (:reference-return penv))
773     (vm-args (:ptr java-vm-init-args)))
774  :result-type jint
775  :lambda-list (vm-args &optional (pvm t) (penv t))
776;  :module :jni-lib ;refused on Mac OSX, even though register-module is supported
777  )
778
779(fli:define-foreign-function (jni-get-created-java-vms "JNI_GetCreatedJavaVMs" :source)
780    ((vm-buf (:c-array pvm))
781     (buf-len jsize)
782     (n-vms (:reference-return jsize)))
783  :result-type jint)
784
785(defun cleanup-jni-gref (gref)
786  "set as a special free action to free java classes when no longer used by Lisp"
787  (when (java-ref-p gref)
788    (delete-global-ref gref)))
789
790(defun create-jvm (&rest option-strings)
791  "Creates the JVM, this can only be done once.
792The option strings can be used to control the JVM, esp. the classpath:
793\"-Djava.class.path=/Users/rich/Lisp/jfli.jar\""
794  (when *pvm*
795    (error "JVM already created, can only be started once"))
796  (load-jni-lib)
797  (let ((nopts (length option-strings))
798         (option-array nil))
799    (fli:with-dynamic-foreign-objects ((ia java-vm-init-args))
800      (when option-strings
801        (setf option-array (fli:allocate-dynamic-foreign-object :type 'java-vm-option :nelems nopts))
802        (dotimes (n nopts)
803          (setf (fli:foreign-slot-value (fli:dereference option-array
804                                                         :index n
805                                                         :copy-foreign-object nil) 'option-string)
806                (fli:convert-to-dynamic-foreign-string (nth n option-strings)))))
807      (fli:with-foreign-slots (VERSION N-OPTIONS OPTIONS IGNORE-UNRECOGNIZED) ia
808        (setf version JNI-VERSION-1-4
809              n-options nopts
810              OPTIONS option-array
811              IGNORE-UNRECOGNIZED nil)
812        (multiple-value-bind (ret vm env)
813            (jni-create-java-vm ia)
814          (setf *pvm* vm)
815          (add-special-free-action #'cleanup-jni-gref)
816          (values ret vm env))))))
817
818;this is the FLI side of proxy support
819
820(defvar *invocation-handler* nil
821  "this will be set by jfli:enable-java-proxies to a function of 3 args")
822
823;this will be set as the implementation of a native java function
824(fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type jobject)
825    ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobject))
826  (do-invoke env obj proxy method args))
827
828(defun do-invoke (env obj proxy method args)
829  ;(declare (ignore env))
830  (when *invocation-handler*
831    (let ((*penv* env))
832      (prog1
833          (funcall *invocation-handler* proxy method args)
834        ;(jfli::invocation-handler proxy method args)
835        (delete-local-ref obj)))))
836
837(defun register-invocation-handler (invocation-handler)
838  "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath"
839  (setf *invocation-handler* invocation-handler)
840  (fli:with-dynamic-foreign-objects ((method jni-native-method))
841    (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler"))))
842      (fli:with-foreign-slots (name signature fn-ptr) method
843        (setf name (fli:convert-to-dynamic-foreign-string "invoke")
844              signature (fli:convert-to-dynamic-foreign-string "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;")
845              fn-ptr (fli:make-pointer :symbol-name "LispInvocationHandler_invoke")))
846      (register-natives lih method 1))))
847
848
849;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
850;the code below provides for the generation of wrapper functions that use JNI to access
851;methods and fields. This low-level interface is unsafe, in that JNI will not
852;check arg types etc on calls, and therefore should only be used to build safer high-level interfaces
853;i.e. use jfli!
854;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
855
856;found on c.l.l
857(eval-when (:compile-toplevel :load-toplevel)
858(defun replace-substrings (string substring replacement)
859  (declare (optimize (speed 3))
860           (type simple-string string substring replacement))
861  (assert (> (length substring) 0) (substring)
862    "Substring ~A must be of length ~D > 0"
863    substring (length substring))
864  (with-output-to-string (stream)
865    (loop with substring-length = (length substring)
866          for index = 0 then (+ match-index substring-length)
867          for match-index = (search substring string :start2 index)
868          do
869          (write-string string stream :start index :end match-index)
870          (when match-index
871            (write-string replacement stream))
872          while match-index)))
873
874
875(defun local-ref-to-global-ref (lref)
876  (when lref
877    (let ((gref (new-global-ref lref)))
878      (flag-special-free-action gref)
879      (delete-local-ref lref)
880      gref)))
881
882(defun local-ref-to-string (lref)
883  (prog1
884      (convert-from-java-string lref)
885    (delete-local-ref lref)))
886
887(defun convert-to-java-string (s)
888  (when s
889    (try-null (new-string-utf (string s)))))
890
891(defun convert-from-java-string (s)
892  (when s
893    (let ((chars (try-null (get-string-utf-chars s))))
894      (prog1
895          (fli:convert-from-foreign-string chars :external-format :utf-8)
896        (release-string-utf-chars s chars)))))
897
898(defun jaref (array index)
899  (try (get-object-array-element array index)))
900
901(defun (setf jaref) (val array index)
902  (try (set-object-array-element array index val)))
903
904(defun convert-string-arg (s)
905  "if s is stringp, make into java string, else presume it is a java string and return it"
906  ;presumably faster than checking if s is a foreign pointer?
907  (if (or (stringp s) (symbolp s))
908      (convert-to-java-string s)
909    s))
910
911(defun process-arg (val type)
912  (if (string-equal "java.lang.String" type)
913                 `(convert-string-arg ,val)
914                 val))
915
916(defmacro set-arg (args i val type)
917  `(setf (fli:foreign-slot-value (fli:dereference (fli:foreign-array-pointer ,args ,i)
918                                                     :copy-foreign-object nil)
919                                    ',(slot-from-typename type))
920            ,(process-arg val type)))
921
922(defmacro with-arg-array (arg-array-name args &body body)
923  (let ((i -1))
924  `(fli:with-dynamic-foreign-objects ()
925     (let ((,arg-array-name
926            (fli:allocate-dynamic-foreign-object :type
927                                                 '(:c-array jvalue ,(length args)))))
928       ,@(mapcar #'(lambda (arg)
929                     (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) 
930                 args)
931
932       ,@body))))
933
934(defun build-descriptor (params return-type)
935  (string-append
936   "("
937   (apply #'string-append (mapcar #'(lambda (p)
938                                      (type-descriptor-from-typename (second p)))
939                                  params))
940   ")"
941   (type-descriptor-from-typename return-type)))
942
943(defun get-class-and-method-id (class-name method-name descriptor is-static)
944  (let ((class (local-ref-to-global-ref
945                (try-null (jni-find-class class-name)))))
946    (values class
947            (if is-static
948                (try-null (get-static-method-id class method-name descriptor))
949              (try-null (get-method-id class method-name descriptor))))))
950
951
952(defun get-class-and-field-id (class-name field-name descriptor is-static)
953  (let ((class (local-ref-to-global-ref
954                (try-null (jni-find-class class-name)))))
955    (values class
956            (if is-static
957                (try-null (get-static-field-id class field-name descriptor))
958              (try-null (get-field-id class field-name descriptor))))))
959
960(defun is-name-of-primitive (s)
961  (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void")
962          :test #'string-equal))
963
964(defun package-qualified-name (classname packagename)
965  (cond
966   ((is-name-of-primitive (subseq classname 0 (position #\< classname))) classname)
967   ((find #\. classname) classname)     ;already qualified, presumably by another package
968   (t (string-append packagename "." classname)))) 
969
970(defun split-package-and-class (name)
971    (let ((p (position #\. name :from-end t)))
972      (unless p (error "must supply package-qualified classname"))
973      (values (subseq name 0 p)
974              (subseq name (1+ p)))))
975
976(defun slot-from-typename (tn)
977  (let ((prim (assoc tn
978                     '(("boolean" . :z)
979                       ("byte" . :b)
980                       ("char" . :c)
981                       ("short" . :s)
982                       ("int" . :i)
983                       ("long" . :j)
984                       ("float" . :f)
985                       ("double" . :d))
986                     :test #'string-equal)))
987    (if prim
988        (rest prim)
989      :l)))
990
991(defun name-component-from-typename (tn)
992  (if (is-name-of-primitive tn)
993      tn
994    "object"))
995
996(defun type-descriptor-from-typename (tn)
997  (let ((prim (assoc tn
998                     '(("boolean" . "Z")
999                       ("byte" . "B")
1000                       ("char" . "C")
1001                       ("short" . "S")
1002                       ("int" . "I")
1003                       ("long" . "J")
1004                       ("float" . "F")
1005                       ("double" . "D")
1006                       ("void" . "V"))
1007                     :test #'string-equal)))
1008    (if prim
1009        (rest prim)
1010      (let ((array-depth (count #\< tn))
1011            (tn-with-slashes (replace-substrings tn "." "/")))
1012        (if (= 0 array-depth)
1013            (string-append "L" tn-with-slashes ";")
1014          (with-output-to-string (s)
1015            (dotimes (x array-depth)
1016              (write-string "[" s))
1017            (write-string (type-descriptor-from-typename
1018                           (subseq tn-with-slashes 0 (position #\< tn-with-slashes))) s)))))))
1019
1020;not an exact reciprocal of type-descriptor-from-typename since reflection uses . not / as separator
1021(defun typename-from-reflection-type-descriptor (tn)
1022  (let ((prim (assoc tn
1023                     '(("Z" . "boolean")
1024                       ("B" . "byte")
1025                       ("C" . "char")
1026                       ("S" . "short")
1027                       ("I" . "int")
1028                       ("J" . "long")
1029                       ("F" . "float")
1030                       ("D" . "double")
1031                       ("V" . "void"))
1032                     :test #'string-equal)))
1033    (if prim
1034        (rest prim)
1035      (let ((array-depth (count #\[ tn)))
1036        (if (= 0 array-depth)
1037            (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
1038          (with-output-to-string (s)
1039            (write-string (typename-from-reflection-type-descriptor (subseq tn array-depth)) s)
1040            (dotimes (x array-depth)
1041              (write-string "<>" s))))))))
1042
1043(defun method-name-from-typename (tn static)
1044    (find-symbol (string-upcase (string-append "call-"
1045                                               (if static "static-" "")
1046                                             (name-component-from-typename tn)
1047                                             "-method-a")) :jni))
1048
1049(defun field-get-name-from-typename (tn static)
1050    (find-symbol (string-upcase (string-append "get-"
1051                                               (if static "static-" "")
1052                                             (name-component-from-typename tn)
1053                                             "-field")) :jni))
1054
1055(defun field-set-name-from-typename (tn static)
1056    (find-symbol (string-upcase (string-append "set-"
1057                                               (if static "static-" "")
1058                                             (name-component-from-typename tn)
1059                                             "-field")) :jni))
1060(defun process-return (return-type f &key raw-return)
1061  (cond
1062   ((or raw-return (is-name-of-primitive return-type)) f)
1063   ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f))
1064   (t `(local-ref-to-global-ref ,f))))
1065
1066;JNI wrapper generators - will create functions in current package
1067;this needs more docs
1068(defmacro define-java-function (fname class-name return-type method-name params &key static raw-return)
1069  (let ((this (gensym))
1070        (class (gensym))
1071        (id (gensym))
1072        (args (gensym)))
1073    `(let (,class ,id)
1074       (defun ,fname ,(if static (mapcar #'first params)
1075                        (cons this (mapcar #'first params)))
1076         (when (null ,class)
1077           (multiple-value-setq (,class ,id)
1078               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1079                                        ,method-name ,(build-descriptor params return-type) ,static)))
1080         (with-arg-array ,args ,(mapcar #'(lambda (param)
1081                                           (list (first param) (second param)))
1082                                       params)
1083           ,(process-return return-type
1084                            `(try (,(method-name-from-typename return-type static)
1085                                   ,(if static class this) ,id ,args))
1086                            :raw-return raw-return))))))
1087
1088(defmacro define-java-field (getname class-name field-type field-name &key static)
1089  (let ((this (gensym))
1090        (class (gensym))
1091        (id (gensym))
1092        (val (gensym)))
1093    `(let (,class ,id)
1094       (flet ((load-ids ()
1095                (when (null ,class)
1096                  (multiple-value-setq (,class ,id)
1097                      (get-class-and-field-id ,(replace-substrings class-name "." "/")
1098                                              ,field-name ,(type-descriptor-from-typename field-type)
1099                                              ,static)))))
1100         (defun ,getname ,(if static () (list this))
1101           (load-ids)
1102           ,(process-return field-type
1103                            `(try (,(field-get-name-from-typename field-type static)
1104                                   ,(if static class this) ,id))))
1105         (defun (setf ,getname) ,(if static (list val) (list this val))
1106           (load-ids)
1107           (try (,(field-set-name-from-typename field-type static)
1108                 ,(if static class this) ,id ,(process-arg val field-type)))
1109           ,val)))))
1110
1111(defmacro define-java-constructor (fname class-name params)
1112  (let ((class (gensym))
1113        (id (gensym))
1114        (args (gensym)))
1115    `(let (,class ,id)
1116       (defun ,fname ,(mapcar #'first params)
1117         (when (null ,class)
1118           (multiple-value-setq (,class ,id)
1119               (get-class-and-method-id ,(replace-substrings class-name "." "/")
1120                                        "<init>" ,(build-descriptor params "void") nil)))
1121         (with-arg-array ,args ,(mapcar #'(lambda (param)
1122                                           (list (first param) (second param)))
1123                                       params)
1124           (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,args))))))))
1125
1126(defun make-func-name (class method params append-param-types)
1127  ;probably a format one-liner that can do this
1128    (let ((base (string-append class "." method)))
1129      (if append-param-types
1130          (string-append base
1131                         (let ((param-types (mapcar #'second params)))
1132                           (if param-types
1133                               (string-append "<"
1134                                              (reduce #'(lambda (x y)
1135                                                          (string-append x "-" y)) param-types)
1136                                              ">")
1137                             "<>")))
1138        base)))
1139
1140;these just do some name twiddling before calling define-java-xxx above
1141(defmacro def-jni-function (package-and-class method params return-typename
1142                                               &key static overloaded raw-return)
1143  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1144    (let* ((fname (make-func-name class method params overloaded))
1145           (fsym (read-from-string fname)))
1146      `(locally ,(list 'define-java-function
1147                     fsym
1148                     package-and-class
1149                     (package-qualified-name return-typename package)
1150                     method
1151                     (mapcar #'(lambda (p)
1152                                 (list (first p) (package-qualified-name (second p) package)))
1153                             params)
1154                     :static static :raw-return raw-return)))))
1155
1156(defmacro def-jni-functions (package-and-class &rest decls)
1157  `(locally ,@(mapcar #'(lambda (decl)
1158                          (list* 'def-jni-function package-and-class decl))
1159                      decls)))
1160
1161(defmacro def-jni-constructor (package-and-class params &key overloaded)
1162  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1163    (let* ((fname (make-func-name class "new" params overloaded))
1164           (fsym (read-from-string fname)))
1165      `(locally ,(list 'define-java-constructor
1166                     fsym 
1167                     package-and-class 
1168                     (mapcar #'(lambda (p)
1169                                 (list (first p) (package-qualified-name (second p) package)))
1170                             params))))))
1171
1172(defmacro def-jni-field (package-and-class field typename &key static)
1173  (multiple-value-bind (package class) (split-package-and-class package-and-class)
1174    (let ((getsym (read-from-string (string-append class "." field
1175                                                   (if static "-accessor" ""))))
1176          (macsym (read-from-string (string-append class "." field))))
1177      `(locally 
1178         ,(list 'define-java-field getsym package-and-class
1179                (package-qualified-name typename package) field :static static)
1180         ,(when static
1181            `(define-symbol-macro ,macsym (,getsym)))))))
1182
1183;we're going to use a little Java to do exception handling below
1184(def-jni-function "java.lang.Object"
1185                   "toString" () "String")
1186
1187(def-jni-function "java.lang.reflect.InvocationTargetException"
1188                  "getTargetException" () "java.lang.Throwable")
1189
1190(def-jni-functions "java.lang.Throwable"
1191                   ("getMessage" () "String")
1192                   ("getStackTrace" () "StackTraceElement<>"))
1193
1194(defmacro do-jarray ((x array) &body body)
1195  (let ((gcount (gensym))
1196        (gi (gensym))
1197        (garray (gensym)))
1198    `(let* ((,garray ,array)
1199            (,gcount (get-array-length ,garray)))
1200       (dotimes (,gi ,gcount)
1201         (let ((,x (jaref ,garray ,gi)))
1202           ,@body)))))
1203
1204#|
1205It is critical that if you call a JNI function that might throw an exception that you clear it,
1206otherwise the next Java call you make will cause a crash
1207|#
1208(defun handle-exception ()
1209  (let ((e (exception-occurred)))
1210    (when (not (fli:null-pointer-p e)) ;allow for safe calling in non-exceptional state
1211      (exception-clear)
1212      ;if the exception occurs in the reflection target, we really want that
1213      (when (is-instance-of e (jni-find-class "java/lang/reflect/InvocationTargetException"))
1214        (setf e (invocationtargetexception.gettargetexception e)))
1215      (error "~A" (with-output-to-string (s)
1216                    (format s "~A~%" (object.tostring e))
1217                    (do-jarray (x (throwable.getstacktrace e))
1218                      (format s "~A~%" (object.tostring x))))))))
1219
1220(defun try (result)
1221  (if (exception-check)
1222      (handle-exception)
1223    result))
1224
1225;JNI will sometimes indicate theere is an exception via a return value
1226;so take advantage of that when possible vs. the call back to exception-check
1227(defun try-null (result)
1228  (if (fli:null-pointer-p result)
1229      (handle-exception)
1230    result))
1231
1232(defun try-neg (result)
1233  (if (minusp result)
1234      (handle-exception)
1235    result))
1236
1237
1238)
1239
Note: See TracBrowser for help on using the repository browser.