Changeset 11442


Ignore:
Timestamp:
Nov 28, 2008, 9:33:00 AM (11 years ago)
Author:
gb
Message:

Some down, some to go ...

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/examples/jfli/jni.lisp

    r11436 r11442  
    5656(in-package :jni)
    5757
     58(eval-when (:compile-toplevel :load-toplevel :execute)
     59  (ccl:use-interface-dir :jni))
     60
     61(ccl::%register-type-ordinal-class (ccl::parse-foreign-type :jobject) 'jobject)
     62(ccl::%register-type-ordinal-class (ccl::parse-foreign-type #>JavaVM) 'java-vm)
     63
     64
    5865(defvar *jni-lib-path*
    59 #+:MACOSX "/System/Library/Frameworks/JavaVM.framework/JavaVM"
    60 #+:WIN32 "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
     66#+:darwin-target "/System/Library/Frameworks/JavaVM.framework/JavaVM"
     67#+:win32-target "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
    6168"Set this to point to your jvm dll prior to calling create-jvm")
    6269
    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)
     70(ccl::defloadvar *pvm* nil)
     71
     72;;; Map between lisp and Java booleans
     73(eval-when (:compile-toplevel)
     74  (declaim (inline jboolean-arg jboolean-result)))
     75
     76(defun jboolean-arg (val)
     77  (if (and val (not (eql val #$JNI_FALSE)))
     78    #$JNI_TRUE
     79    #$JNI_FALSE))
     80
     81(defun jboolean-result (val)
     82  (not (eql val #$JNI_FALSE)))
     83
     84
     85
     86(defconstant JNI-VERSION-1-2 #$JNI_VERSION_1_2)
     87(defconstant JNI-VERSION-1-4 #$JNI_VERSION_1_4)
     88(defconstant JNI-OK #$JNI_OK)
    7189
    7290(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   )
     91  (ccl:open-shared-library libpath))
    17692
    17793(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            )
     94  "return a pointer to the current thread's JNIEnv, creating that environment
     95if necessary."
     96  (rlet ((pjnienv :address))
     97    (let* ((jvm (get-pvm)))
     98      (unless (eql jni-ok
     99                   (ff-call (pref jvm #>JavaVM.GetEnv)
     100                            :address jvm
     101                            :address pjnienv
     102                            :jint jni-version-1-4
     103                            :jint))
     104        ;; On Darwin, attaching the current thread to a JVM instance
     105        ;; overwrites the thread's Mach exception ports, which CCL
     106        ;; happens to be using.  We can work around this by calling
     107        ;; a function in the CCL kernel and having that function
     108        ;; call the vm's AttachCurrentThread function and then restore
     109        ;; the thread's exception ports before returning.  Yes, that
     110        ;; -is- total nonsense.
     111        (unless (eql jni-ok
     112                     (ff-call
     113                      (ccl::%kernel-import target::kernel-import-jvm-init)
     114                      :address (pref jvm #>JavaVM.AttachCurrentThread)
     115                      :address jvm
     116                      :address pjnienv
     117                      :address (ccl::%null-ptr)
     118                      :jint))
     119          (error "Can't attach thread to JVM ~s" jvm)))
     120      (let* ((result (pref pjnienv :address)))
     121        (ccl::%set-macptr-type result (load-time-value (ccl::foreign-type-ordinal (ccl::foreign-pointer-type-to (ccl::parse-foreign-type #>JNIEnv)))))
     122        result))))
     123
     124
     125;;; JNIEnv functions.
     126
     127(defmacro jnienv-call ((slot result-type) &rest specs)
     128  ;; We might want to special-case some result-types for finalization.
     129  (let* ((env (gensym))
     130         (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot))))
     131    `(let* ((,env (current-env)))
     132      (ff-call (pref ,env ,accessor) :address ,env ,@specs ,result-type))))
     133
     134(defun get-version ()
     135  (jnienv-call ("GetVersion" :jint)))
     136
     137(defun define-class (name loader buf len)
     138  (ccl::with-utf-8-cstrs ((cname name))
     139    (jnienv-call ("DefineClass" :jclass)
     140                 :address cname
     141                 :jobject loader
     142                 (:* :jbyte) buf
     143                 :jsize len)))
     144
     145(defun jni-find-class (name)
     146  (ccl::with-utf-8-cstrs ((cname name))
     147    (jnienv-call ("FindClass" :jclass) :address cname)))
     148
     149(defun from-reflected-method (method)
     150  (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method))
     151
     152(defun from-reflected-field (field)
     153  (jnienv-call ("FromReflectedField" #>jfieldID) :jobject field))
     154
     155(defun to-reflected-method (cls method-id is-static)
     156  (jnienv-call ("ToReflectedMethod" :jobject)
     157               :jclass cls
     158               #>jmethodID method-id
     159               :jboolean (jboolean-arg is-static)))
     160
     161(defun get-superclass (sub)
     162  (jnienv-call ("GetSuperclass" :jclass) :jclass sub))
     163
     164(defun is-assignable-from (sub sup)
     165  (jboolean-result
     166   (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup)))
     167
     168(defun to-reflected-field (cls field-id is-static)
     169  (jnienv-call ("ToReflectedField" :jobject)
     170               :jclass cls
     171               #>jfieldID field-id
     172               :jboolean (jboolean-arg is-static)))
     173
     174(defun jni-throw (obj)
     175  (jnienv-call ("Throw" :jint) :jthrowable obj))
     176
     177(defun throw-new (clazz msg)
     178  (ccl::with-utf-8-cstrs ((cmsg msg))
     179    (jnienv-call ("ThrowNew" :jint) :jclass clazz :address cmsg)))
     180
     181(defun exception-occurred ()
     182  (jnienv-call ("ExceptionOccurred" :jthrowable)))
     183
     184(defun exception-describe ()
     185  (jnienv-call ("ExceptionDescribe" :void)))
     186
     187(defun exception-clear ()
     188  (jnienv-call ("ExceptionClear" :void)))
     189
     190(defun fatal-error (msg)
     191  (ccl::with-utf-8-cstrs ((cmsg msg))
     192    (jnienv-call ("FatalError" :void) :address cmsg)))
     193 
     194(defun push-local-frame (capacity)
     195  (jnienv-call ("PushLocalFrame" :jint) :jint capacity))
     196
     197(defun pop-local-frame (result)
     198  (jnienv-call ("PopLocalFrame" :jobject) :jobject result))
     199
     200(defun new-global-ref (lobj)
     201  (jnienv-call ("NewGlobalRef" :jobject) :jobject lobj))
     202
     203(defun delete-global-ref (gref)
     204  (jnienv-call ("DeleteGlobalRef" :void) :jobject gref))
     205 
     206(defun delete-local-ref (obj)
     207  (jnienv-call ("DeleteLocalRef" :void) :jobject obj))
     208
     209(defun is-same-object (obj1 obj2)
     210  (jboolean-result
     211   (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2)))
     212
     213(defun new-local-ref (ref)
     214  (jnienv-call ("NewLocalRef" :jobject) :jobject ref))
     215
     216(defun ensure-local-capacity (capacity)
     217  (jnienv-call ("EnsureLocalCapacity" :jint) :jint capacity))
     218
     219(defun alloc-object (clazz)
     220  (jnienv-call ("AllocObject" :jobject) :jclass clazz))
     221
     222;;; We probably can't get very far with NewObject or NewObjectV, which
     223;;; depend on the underlying varargs mechanism.  NewObjectA is more
     224;;; tractable.
     225
     226(defun new-object-a (clazz method-id args)
     227  (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args))
     228
     229(defun get-object-class (obj)
     230  (jnienv-call ("GetObjectClass" :jclass) :jobject obj))
     231
     232;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA.
     233
     234(defun call-object-method-a (obj method-id args)
     235  (jnienv-call ("CallObjectMethodA" :jobject)
     236               :jobject obj
     237               #>jmethodID method-id
     238               (:* :jvalue) args))
     239
     240(defun call-boolean-method-a (obj method-id args)
     241  (jboolean-result
     242   (jnienv-call ("CallBooleanMethodA" :jboolean)
     243               :jobject obj
     244               #>jmethodID method-id
     245               (:* :jvalue) args)))
     246
     247(defun call-byte-method-a (obj method-id args)
     248  (jnienv-call ("CallByteMethodA" :jbyte)
     249               :jobject obj
     250               #>jmethodID method-id
     251               (:* :jvalue) args))
     252
     253(defun call-byte-method-a (obj method-id args)
     254  (jnienv-call ("CallCharMethodA" :jchar)
     255               :jobject obj
     256               #>jmethodID method-id
     257               (:* :jvalue) args))
     258
     259(defun call-short-method-a (obj method-id args)
     260  (jnienv-call ("CallShortMethodA" :jshort)
     261               :jobject obj
     262               #>jmethodID method-id
     263               (:* :jvalue) args))
     264
     265(defun call-int-method-a (obj method-id args)
     266  (jnienv-call ("CallIntMethodA" :jint)
     267               :jobject obj
     268               #>jmethodID method-id
     269               (:* :jvalue) args))
     270
     271(defun call-long-method-a (obj method-id args)
     272  (jnienv-call ("CallLongMethodA" :jlong)
     273               :jobject obj
     274               #>jmethodID method-id
     275               (:* :jvalue) args))
     276
     277(defun call-float-method-a (obj method-id args)
     278  (jnienv-call ("CallFloatMethodA" :jfloat)
     279               :jobject obj
     280               #>jmethodID method-id
     281               (:* :jvalue) args))
     282
     283(defun call-double-method-a (obj method-id args)
     284  (jnienv-call ("CallDoubleMethodA" :jdouble)
     285               :jobject obj
     286               #>jmethodID method-id
     287               (:* :jvalue) args))
     288
     289(defun call-void-method-a (obj method-id args)
     290  (jnienv-call ("CallVoidMethodA" :void)
     291               :jobject obj
     292               #>jmethodID method-id
     293               (:* :jvalue) args))
     294
     295;;; Nonvirtual method calls.
     296(defun call-nonvirtual-object-method-a (obj method-id args)
     297  (jnienv-call ("CallNonvirtualObjectMethodA" :jobject)
     298               :jobject obj
     299               #>jmethodID method-id
     300               (:* :jvalue) args))
     301
     302(defun call-nonvirtual-boolean-method-a (obj method-id args)
     303  (jboolean-result
     304   (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean)
     305               :jobject obj
     306               #>jmethodID method-id
     307               (:* :jvalue) args)))
     308
     309(defun call-nonvirtual-byte-method-a (obj method-id args)
     310  (jnienv-call ("CallNonvirtualByteMethodA" :jbyte)
     311               :jobject obj
     312               #>jmethodID method-id
     313               (:* :jvalue) args))
     314
     315(defun call-nonvirtual-char-method-a (obj method-id args)
     316  (jnienv-call ("CallNonvirtualCharMethodA" :jchar)
     317               :jobject obj
     318               #>jmethodID method-id
     319               (:* :jvalue) args))
     320
     321(defun call-nonvirtual-short-method-a (obj method-id args)
     322  (jnienv-call ("CallNonvirtualShortMethodA" :jshort)
     323               :jobject obj
     324               #>jmethodID method-id
     325               (:* :jvalue) args))
     326
     327
     328(defun call-nonvirtual-int-method-a (obj method-id args)
     329  (jnienv-call ("CallNonvirtualIntMethodA" :jint)
     330               :jobject obj
     331               #>jmethodID method-id
     332               (:* :jvalue) args))
     333
     334(defun call-nonvirtual-long-method-a (obj method-id args)
     335  (jnienv-call ("CallNonvirtualLongMethodA" :jlong)
     336               :jobject obj
     337               #>jmethodID method-id
     338               (:* :jvalue) args))
     339
     340(defun call-nonvirtual-float-method-a (obj method-id args)
     341  (jnienv-call ("CallNonvirtualFloatMethodA" :jfloat)
     342               :jobject obj
     343               #>jmethodID method-id
     344               (:* :jvalue) args))
     345
     346(defun call-nonvirtual-double-method-a (obj method-id args)
     347  (jnienv-call ("CallNonvirtualDoubleMethodA" :jdouble)
     348               :jobject obj
     349               #>jmethodID method-id
     350               (:* :jvalue) args))
     351
     352(defun call-nonvirtual-void-method-a (obj method-id args)
     353  (jnienv-call ("CallNonvirtualVoidMethodA" :void)
     354               :jobject obj
     355               #>jmethodID method-id
     356               (:* :jvalue) args))
     357
     358(defun get-field-id (clazz name sig)
     359  (ccl::with-utf-8-cstrs ((cname name)
     360                          (csig sig))
     361    (jnienv-call ("GetFieldID" #>jfieldID)
     362                 :jclass clazz
     363                 :address cname
     364                 :address csig)))
     365
     366(defun get-object-field (obj field-id)
     367  (jnienv-call ("GetObjectField" :jobject)
     368               :jobject obj
     369               #>jfieldID field-id))
     370
     371(defun get-boolean-field (obj field-id)
     372  (jboolean-result
     373   (jnienv-call ("GetBooleanField" :jboolean)
     374               :jobject obj
     375               #>jfieldID field-id)))
     376
     377(defun get-byte-field (obj field-id)
     378  (jnienv-call ("GetByteField" :jbyte)
     379               :jobject obj
     380               #>jfieldID field-id))
     381
     382(defun get-char-field (obj field-id)
     383  (jnienv-call ("GetCharField" :jchar)
     384               :jobject obj
     385               #>jfieldID field-id))
     386
     387(defun get-short-field (obj field-id)
     388  (jnienv-call ("GetShortField" :jshort)
     389               :jobject obj
     390               #>jfieldID field-id))
     391
     392
     393(defun get-int-field (obj field-id)
     394  (jnienv-call ("GetIntField" :jint)
     395               :jobject obj
     396               #>jfieldID field-id))
     397
     398(defun get-long-field (obj field-id)
     399  (jnienv-call ("GetLongField" :jlong)
     400               :jobject obj
     401               #>jfieldID field-id))
     402
     403(defun get-float-field (obj field-id)
     404  (jnienv-call ("GetFloatField" :jfloat)
     405               :jobject obj
     406               #>jfieldID field-id))
     407
     408(defun get-double-field (obj field-id)
     409  (jnienv-call ("GetDoubleField" :jdouble)
     410               :jobject obj
     411               #>jfieldID field-id))
     412
     413(defun set-object-field (obj field-id val)
     414  (jnienv-call ("SetObjectField" :void)
     415               :jobject obj
     416               #>jfieldID field-id
     417               :jobject val))
     418
     419(defun set-boolean-field (obj field-id val)
     420  (jnienv-call ("SetBooleanField" :void)
     421               :jobject obj
     422               #>jfieldID field-id
     423               :jboolean (jboolean-arg val)))
     424
     425(defun set-byte-field (obj field-id val)
     426  (jnienv-call ("SetByteField" :void)
     427               :jobject obj
     428               #>jfieldID field-id
     429               :jbyte val))
     430
     431(defun set-char-field (obj field-id val)
     432  (jnienv-call ("SetCharField" :void)
     433               :jobject obj
     434               #>jfieldID field-id
     435               :jchar val))
     436
     437(defun set-short-field (obj field-id val)
     438  (jnienv-call ("SetShortField" :void)
     439               :jobject obj
     440               #>jfieldID field-id
     441               :jshort val))
     442
     443(defun set-int-field (obj field-id val)
     444  (jnienv-call ("SetIntField" :void)
     445               :jobject obj
     446               #>jfieldID field-id
     447               :jint val))
     448
     449(defun set-long-field (obj field-id val)
     450  (jnienv-call ("SetLongField" :void)
     451               :jobject obj
     452               #>jfieldID field-id
     453               :jlong val))
     454
     455(defun set-float-field (obj field-id val)
     456  (jnienv-call ("SetFloatField" :void)
     457               :jobject obj
     458               #>jfieldID field-id
     459               :jfloat val))
     460
     461(defun set-double-field (obj field-id val)
     462  (jnienv-call ("SetDoubleField" :void)
     463               :jobject obj
     464               #>jfieldID field-id
     465               :jdouble val))
     466
     467(defun get-static-method-id (clazz name sig)
     468  (ccl::with-utf-8-cstrs ((cname name)
     469                          (csig sig))
     470    (jnienv-call ("GetStaticMethodID" #>jmethodID)
     471                 :jclass clazz
     472                 :address cname
     473                 :address csig)))
     474
     475(defun call-static-object-method-a (clazz method-id args)
     476  (jnienv-call ("CallStaticObjectMethodA" :jobject)
     477               :jclass clazz
     478               #>jmethodID method-id
     479               (:* :jvalue) args))
     480
     481(defun call-static-boolean-method-a (clazz method-id args)
     482  (jboolean-result
     483   (jnienv-call ("CallStaticBooleanMethodA" :jboolean)
     484                :jclass clazz
     485                #>jmethodID method-id
     486                (:* :jvalue) args)))
     487
     488(defun call-static-byte-method-a (clazz method-id args)
     489  (jnienv-call ("CallStaticByteMethodA" :jbyte)
     490               :jclass clazz
     491               #>jmethodID method-id
     492               (:* :jvalue) args))
     493
     494(defun call-static-char-method-a (clazz method-id args)
     495  (jnienv-call ("CallStaticCharMethodA" :jchar)
     496               :jclass clazz
     497               #>jmethodID method-id
     498               (:* :jvalue) args))
     499
     500(defun call-static-short-method-a (clazz method-id args)
     501  (jnienv-call ("CallStaticShortMethodA" :jshort)
     502               :jclass clazz
     503               #>jmethodID method-id
     504               (:* :jvalue) args))
     505
     506(defun call-static-int-method-a (clazz method-id args)
     507  (jnienv-call ("CallStaticIntMethodA" :jint)
     508               :jclass clazz
     509               #>jmethodID method-id
     510               (:* :jvalue) args))
     511
     512(defun call-static-long-method-a (clazz method-id args)
     513  (jnienv-call ("CallStaticLongMethodA" :jlong)
     514               :jclass clazz
     515               #>jmethodID method-id
     516               (:* :jvalue) args))
     517
     518(defun call-static-float-method-a (clazz method-id args)
     519  (jnienv-call ("CallStaticFloatMethodA" :jfloat)
     520               :jclass clazz
     521               #>jmethodID method-id
     522               (:* :jvalue) args))
     523
     524(defun call-static-double-method-a (clazz method-id args)
     525  (jnienv-call ("CallStaticDoubleMethodA" :jdouble)
     526               :jclass clazz
     527               #>jmethodID method-id
     528               (:* :jvalue) args))
     529
     530(defun call-static-void-method-a (clazz method-id args)
     531  (jnienv-call ("CallStaticVoidMethodA" :void)
     532               :jclass clazz
     533               #>jmethodID method-id
     534               (:* :jvalue) args))
     535
     536(defun get-static-field-id (clazz name sig)
     537  (ccl::with-utf-8-cstrs ((cname name)
     538                          (csig sig))
     539    (jnienv-call ("GetStaticFieldID" #>jfieldID)
     540                 :jclass clazz
     541                 :address cname
     542                 :address csig)))
     543
     544(defun get-static-object-field (clazz field-id)
     545  (jnienv-call ("GetStaticObjectField" :jobject)
     546               :jclass clazz
     547               #>jfieldID field-id))
     548
     549(defun get-static-boolean-field (clazz field-id)
     550  (jboolean-result
     551   (jnienv-call ("GetStaticBooleanField" :jboolean)
     552               :jclass clazz
     553               #>jfieldID field-id)))
     554
     555(defun get-static-byte-field (clazz field-id)
     556  (jnienv-call ("GetStaticByteField" :jbyte)
     557               :jclass clazz
     558               #>jfieldID field-id))
     559
     560(defun get-static-char-field (clazz field-id)
     561  (jnienv-call ("GetStaticCharField" :jchar)
     562               :jclass clazz
     563               #>jfieldID field-id))
     564
     565(defun get-static-short-field (clazz field-id)
     566  (jnienv-call ("GetStaticShortField" :jshort)
     567               :jclass clazz
     568               #>jfieldID field-id))
     569
     570(defun get-static-int-field (clazz field-id)
     571  (jnienv-call ("GetStaticIntField" :jint)
     572               :jclass clazz
     573               #>jfieldID field-id))
     574
     575(defun get-static-long-field (clazz field-id)
     576  (jnienv-call ("GetStaticLongField" :jlong)
     577               :jclass clazz
     578               #>jfieldID field-id))
     579
     580(defun get-static-float-field (clazz field-id)
     581  (jnienv-call ("GetStaticFloatField" :jfloat)
     582               :jclass clazz
     583               #>jfieldID field-id))
     584
     585(defun get-static-double-field (clazz field-id)
     586  (jnienv-call ("GetStaticDoubleField" :jdouble)
     587               :jclass clazz
     588               #>jfieldID field-id))
     589
     590
     591(defun set-static-object-field (clazz field-id value)
     592  (jnienv-call ("SetStaticObjectField" :void)
     593               :jclass clazz
     594               #>jfieldID field-id
     595               :jobject value))
     596
     597(defun set-static-boolean-field (clazz field-id value)
     598  (jnienv-call ("SetStaticBooleanField" :void)
     599               :jclass clazz
     600               #>jfieldID field-id
     601               :jboolean (jboolean-arg value)))
     602
     603(defun set-static-byte-field (clazz field-id value)
     604  (jnienv-call ("SetStaticByteField" :void)
     605               :jclass clazz
     606               #>jfieldID field-id
     607               :jbyte value))
     608
     609(defun set-static-char-field (clazz field-id value)
     610  (jnienv-call ("SetStaticCharField" :void)
     611               :jclass clazz
     612               #>jfieldID field-id
     613               :jchar value))
     614
     615(defun set-static-short-field (clazz field-id value)
     616  (jnienv-call ("SetStaticShortField" :void)
     617               :jclass clazz
     618               #>jfieldID field-id
     619               :jshort value))
     620
     621(defun set-static-int-field (clazz field-id value)
     622  (jnienv-call ("SetStaticIntField" :void)
     623               :jclass clazz
     624               #>jfieldID field-id
     625               :jint value))
     626
     627(defun set-static-long-field (clazz field-id value)
     628  (jnienv-call ("SetStaticLongField" :void)
     629               :jclass clazz
     630               #>jfieldID field-id
     631               :jlong value))
     632
     633(defun set-static-float-field (clazz field-id value)
     634  (jnienv-call ("SetStaticFloatField" :void)
     635               :jclass clazz
     636               #>jfieldID field-id
     637               :jfloat value))
     638
     639(defun set-static-double-field (clazz field-id value)
     640  (jnienv-call ("SetStaticDoubleField" :void)
     641               :jclass clazz
     642               #>jfieldID field-id
     643               :jdouble value))
     644
     645(defun new-string (unicode len)
     646  (ccl::with-native-utf-16-cstrs ((cstring unicode))
     647    (jnienv-call ("NewString" :jstring)
     648                 (:* :jchar) cstring
     649                 :jsize len)))
     650
     651(defun get-string-length (str)
     652  (jnienv-call ("GetStringLength" :jsize)
     653               :jstring str))
     654
     655(defun get-string-chars (str is-copy)
     656  (jnienv-call ("GetStringChars" (:* :jchar))
     657               :jstring str
     658               (:* :jboolean) is-copy))
     659
     660(defun release-string-chars (str chars)
     661  (jnienv-call ("ReleaseStringChars" :void)
     662               :jstring str
     663               (:* :jchar) chars))
     664
     665(defun new-string-utf (string)
     666  (ccl::with-utf-8-cstrs ((cstring string))
     667    (jnienv-call ("NewStringUTF" :jstring)
     668                 :address cstring)))
     669
     670(defun get-string-utf-chars (str)
     671  (rlet ((is-copy :jboolean))
     672    (let* ((chars (jnienv-call ("GetStringUTFChars" (:* :char))
     673                               :jstring str
     674                               (:* :jboolean) is-copy)))
     675      (values chars (jboolean-result (pref is-copy :jboolean))))))
     676
     677(defun release-string-utf-chars (str chars)
     678  (jnienv-call ("ReleaseStringUTFChars" :void)
     679               :jstring str
     680               (:* :char) chars))
     681
     682(defun get-array-length (array)
     683  (jnienv-call ("GetArrayLength" :jsize)
     684               :jArray array))
     685
     686(defun new-object-array (len clazz init)
     687  (jnienv-call ("NewObjectArray" #>jobjectArray)
     688               :jsize len
     689               :jclass clazz
     690               :jobject init))
     691
     692(defun get-object-array-element (array index)
     693  (jnienv-call ("GetObjectArrayElement" :jobject)
     694               #>jobjectArray array
     695               :jsize index))
     696
     697(defun set-object-array-element (array index val)
     698  (jnienv-call ("SetObjectArrayElement" :void)
     699               #>jobjectArray array
     700               :jsize index
     701               :jobject val))
     702
     703(defun new-boolean-array (len)
     704  (jnienv-call ("NewBooleanArray" #>jbooleanArray)
     705               :jsize len))
     706
     707(defun new-byte-array (len)
     708  (jnienv-call ("NewByteArray" #>jbyteArray)
     709               :jsize len))
     710
     711(defun new-char-array (len)
     712  (jnienv-call ("NewCharArray" #>jcharArray)
     713               :jsize len))
     714
     715(defun new-short-array (len)
     716  (jnienv-call ("NewShortArray" #>jshortArray)
     717               :jsize len))
     718
     719(defun new-int-array (len)
     720  (jnienv-call ("NewIntArray" #>jintArray)
     721               :jsize len))
     722
     723(defun new-long-array (len)
     724  (jnienv-call ("NewLongArray" #>jlongArray)
     725               :jsize len))
     726
     727(defun new-float-array (len)
     728  (jnienv-call ("NewFloatArray" #>jfloatArray)
     729               :jsize len))
     730
     731(defun new-double-array (len)
     732  (jnienv-call ("NewDoubleArray" #>jdoubleArray)
     733               :jsize len))
     734
     735
     736(defun get-boolean-array-elements (array is-copy)
     737  (jnienv-call ("GetBooleanArrayElements" (:* :jboolean))
     738               #>jbooleanArray array
     739               (:* :jboolean) is-copy))
     740
     741(defun get-byte-array-elements (array is-copy)
     742  (jnienv-call ("GetByteArrayElements" (:* :jbyte))
     743               #>jbyteArray array
     744               (:* :jboolean) is-copy))
     745
     746(defun get-char-array-elements (array is-copy)
     747  (jnienv-call ("GetCharArrayElements" (:* :jchar))
     748               #>jcharArray array
     749               (:* :jboolean) is-copy))
     750
     751(defun get-short-array-elements (array is-copy)
     752  (jnienv-call ("GetShortArrayElements" (:* :jshort))
     753               #>jshortArray array
     754               (:* :jboolean) is-copy))
     755
     756(defun get-int-array-elements (array is-copy)
     757  (jnienv-call ("GetIntArrayElements" (:* :jint))
     758               #>jintArray array
     759               (:* :jboolean) is-copy))
     760
     761(defun get-long-array-elements (array is-copy)
     762  (jnienv-call ("GetLongArrayElements" (:* :jlong))
     763               #>jlongArray array
     764               (:* :jboolean) is-copy))
     765
     766(defun get-float-array-elements (array is-copy)
     767  (jnienv-call ("GetFloatArrayElements" (:* :jfloat))
     768               #>jfloatArray array
     769               (:* :jboolean) is-copy))
     770
     771(defun get-double-array-elements (array is-copy)
     772  (jnienv-call ("GetDoubleArrayElements" (:* :jdouble))
     773               #>jdoubleArray array
     774               (:* :jboolean) is-copy))
     775
     776(defun release-boolean-array-elements (array elems mode)
     777  (jnienv-call ("ReleaseBooleanArrayElements" :void)
     778               #>jbooleanArray array
     779               (:* jboolean) elems
     780               :jint mode))
     781
     782(defun release-byte-array-elements (array elems mode)
     783  (jnienv-call ("ReleaseByteArrayElements" :void)
     784               #>jbyteArray array
     785               (:* jbyte) elems
     786               :jint mode))
     787
     788(defun release-char-array-elements (array elems mode)
     789  (jnienv-call ("ReleaseCharArrayElements" :void)
     790               #>jcharArray array
     791               (:* jchar) elems
     792               :jint mode))
     793
     794(defun release-short-array-elements (array elems mode)
     795  (jnienv-call ("ReleaseShortArrayElements" :void)
     796               #>jshortArray array
     797               (:* jshort) elems
     798               :jint mode))
     799
     800(defun release-int-array-elements (array elems mode)
     801  (jnienv-call ("ReleaseIntArrayElements" :void)
     802               #>jintArray array
     803               (:* jint) elems
     804               :jint mode))
     805
     806(defun release-long-array-elements (array elems mode)
     807  (jnienv-call ("ReleaseLongArrayElements" :void)
     808               #>jlongArray array
     809               (:* jlong) elems
     810               :jint mode))
     811
     812(defun release-float-array-elements (array elems mode)
     813  (jnienv-call ("ReleaseFloatArrayElements" :void)
     814               #>jfloatArray array
     815               (:* jfloat) elems
     816               :jint mode))
     817
     818(defun release-double-array-elements (array elems mode)
     819  (jnienv-call ("ReleaseDoubleArrayElements" :void)
     820               #>jdoubleArray array
     821               (:* jdouble) elems
     822               :jint mode))
     823
     824
     825(defun get-boolean-array-region (array start len buf)
     826  (jnienv-call ("GetBooleanArrayRegion" :void)
     827               #>jbooleanArray array
     828               :jsize start
     829               :jsize len
     830               (:* :jboolean) buf))
     831
     832(defun get-byte-array-region (array start len buf)
     833  (jnienv-call ("GetByteArrayRegion" :void)
     834               #>jbyteArray array
     835               :jsize start
     836               :jsize len
     837               (:* :jbyte) buf))
     838
     839(defun get-char-array-region (array start len buf)
     840  (jnienv-call ("GetCharArrayRegion" :void)
     841               #>jcharArray array
     842               :jsize start
     843               :jsize len
     844               (:* :jchar) buf))
     845
     846(defun get-short-array-region (array start len buf)
     847  (jnienv-call ("GetShortArrayRegion" :void)
     848               #>jshortArray array
     849               :jsize start
     850               :jsize len
     851               (:* :jshort) buf))
     852
     853(defun get-int-array-region (array start len buf)
     854  (jnienv-call ("GetIntArrayRegion" :void)
     855               #>jintArray array
     856               :jsize start
     857               :jsize len
     858               (:* :jint) buf))
     859
     860(defun get-long-array-region (array start len buf)
     861  (jnienv-call ("GetLongArrayRegion" :void)
     862               #>jlongArray array
     863               :jsize start
     864               :jsize len
     865               (:* :jlong) buf))
     866
     867(defun get-float-array-region (array start len buf)
     868  (jnienv-call ("GetFloatArrayRegion" :void)
     869               #>jfloatArray array
     870               :jsize start
     871               :jsize len
     872               (:* :jfloat) buf))
     873
     874(defun get-double-array-region (array start len buf)
     875  (jnienv-call ("GetDoubleArrayRegion" :void)
     876               #>jdoubleArray array
     877               :jsize start
     878               :jsize len
     879               (:* :jdouble) buf))
     880
     881(defun set-boolean-array-region (array start len buf)
     882  (jnienv-call ("SetBooleanArrayRegion" :void)
     883               #>jbooleanArray array
     884               :jsize start
     885               :jsize len
     886               (:* :jboolean) buf))
     887
     888(defun set-byte-array-region (array start len buf)
     889  (jnienv-call ("SetByteArrayRegion" :void)
     890               #>jbyteArray array
     891               :jsize start
     892               :jsize len
     893               (:* :jbyte) buf))
     894
     895(defun set-char-array-region (array start len buf)
     896  (jnienv-call ("SetCharArrayRegion" :void)
     897               #>jcharArray array
     898               :jsize start
     899               :jsize len
     900               (:* :jchar) buf))
     901
     902(defun set-short-array-region (array start len buf)
     903  (jnienv-call ("SetShortArrayRegion" :void)
     904               #>jshortArray array
     905               :jsize start
     906               :jsize len
     907               (:* :jshort) buf))
     908
     909(defun set-int-array-region (array start len buf)
     910  (jnienv-call ("SetIntArrayRegion" :void)
     911               #>jintArray array
     912               :jsize start
     913               :jsize len
     914               (:* :jint) buf))
     915
     916(defun set-long-array-region (array start len buf)
     917  (jnienv-call ("SetLongArrayRegion" :void)
     918               #>jlongArray array
     919               :jsize start
     920               :jsize len
     921               (:* :jlong) buf))
     922
     923(defun set-float-array-region (array start len buf)
     924  (jnienv-call ("SetFloatArrayRegion" :void)
     925               #>jfloatArray array
     926               :jsize start
     927               :jsize len
     928               (:* :jfloat) buf))
     929
     930(defun set-double-array-region (array start len buf)
     931  (jnienv-call ("SetDoubleArrayRegion" :void)
     932               #>jdoubleArray array
     933               :jsize start
     934               :jsize len
     935               (:* :jdouble) buf))
     936
     937
     938(defun register-natives (clazz methods nmethods)
     939  (jnienv-call ("RegisterNatives":jint)
     940               :jclass clazz
     941               (:* #>JNINativeMethod) methods
     942               :jint nmethods))
     943
     944
     945(defun unregister-natives (clazz)
     946  (jnienv-call ("UnregisterNatives" :jint)
     947               :jclass clazz))
     948
     949(defun monitor-enter (obj)
     950  (jnienv-call ("MonitorEnter" :jint)
     951               :jobject obj))
     952
     953(defun monitor-exit (obj)
     954  (jnienv-call ("MonitorExit" :jint)
     955               :jobject obj))
     956
     957(defun get-java-vm (vm)
     958  (jnienv-call ("GetJavaVM" :jint)
     959               (:* (:* #>JavaVM)) vm))
     960
     961(defun get-string-region (str start len buf)
     962  (jnienv-call ("GetStringRegion" :void)
     963               :jstring str
     964               :jsize start
     965               :jsize len
     966               (:* :jchar) buf))
     967
     968(defun get-string-utf-region (str start len buf)
     969  (jnienv-call ("GetStringUTFRegion" :void)
     970               :jstring str
     971               :jsize start
     972               :jsize len
     973               (:* :char) buf))
     974
     975(defun get-primitive-array-critical (array is-copy)
     976  (jnienv-call ("GetPrimitiveArrayCritical" (:* :void))
     977               :jarray array
     978               (:* :jboolean) is-copy))
     979
     980(defun release-primitive-array-critical(jarray carray mode)
     981  (jnienv-call ("ReleasePrimitiveArrayCritical" :void)
     982               :jarray jarray
     983               (:* :void) carray
     984               :jint mode))
     985
     986(defun get-string-critical (string is-copy)
     987  (jnienv-call ("GetStringCritical" (:* :jchar))
     988               :jstring string
     989               (:* :jboolean) is-copy))
     990
     991(defun release-string-critical (string cstring)
     992  (jnienv-call ("ReleaseStringCritical" :void)
     993               :jstring string
     994               (:* :jchar) cstring))
     995
     996(defun new-weak-global-ref (obj)
     997  (jnienv-call ("NewWeakGlobalRef" :jweak)
     998               :jobject obj))
     999
     1000(defun delete-weak-global-ref (ref)
     1001  (jnienv-call ("DeleteWeakGlobalRef" :void)
     1002               :jweak ref))
     1003
     1004(defun exception-check ()
     1005  (jboolean-result (jnienv-call ("ExceptionCheck" :jboolean))))
     1006               
     1007
     1008(defun new-direct-byte-buffer (address capacity)
     1009  (jnienv-call ("NewDirectByteBuffer" :jobject)
     1010               :address address
     1011               :jlong capacity))
     1012
     1013(defun get-direct-buffer-address (buf)
     1014  (jnienv-call ("GetDirectBufferAddress" :address)
     1015               :jobject buf))
     1016
     1017(defun get-direct-buffer-capacity (buf)
     1018  (jnienv-call ("GetDirectBufferCapacity" :jlong)
     1019               :jobject buf))
     1020
     1021;;; End of jnienv functions.  (Finally.)
    7191022
    7201023(defun get-pvm ()
     
    7221025      (error "JVM not loaded")))
    7231026
    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 
     1027#+later
    7851028(defun cleanup-jni-gref (gref)
    7861029  "set as a special free action to free java classes when no longer used by Lisp"
     
    7881031    (delete-global-ref gref)))
    7891032
    790 (defun create-jvm (&rest option-strings)
     1033(defun create-jvm (&rest args)
     1034  (declare (dynamic-extent args))
    7911035  "Creates the JVM, this can only be done once.
    7921036The option strings can be used to control the JVM, esp. the classpath:
     
    7951039    (error "JVM already created, can only be started once"))
    7961040  (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
     1041  (ccl::call-with-string-vector
     1042   (lambda (argv)
     1043     (let* ((nargs (length args)))
     1044       (rlet ((initargs :<J>ava<VMI>nit<A>rgs)
     1045              (env (:* :<JNIE>nv))
     1046              (vm (:* :<J>ava<VM>)))
     1047         (%stack-block ((options (* nargs (ccl::record-length :<J>ava<VMO>ption))))
     1048           (do* ((i 0 (1+ i))
     1049                 (p options (%inc-ptr p (ccl::record-length :<J>ava<VMO>ption))))
     1050                ((= i nargs))
     1051             (setf (pref p :<J>ava<VMO>ption.option<S>tring)
     1052                   (paref argv (:* (:* :char)) i)))
     1053           (setf (pref initargs :<J>ava<VMI>nit<A>rgs.version) #$JNI_VERSION_1_4
     1054                 (pref initargs :<J>ava<VMI>nit<A>rgs.n<O>ptions) nargs
     1055                 (pref initargs :<J>ava<VMI>nit<A>rgs.options) options
     1056                 (pref initargs :<J>ava<VMI>nit<A>rgs.ignore<U>nrecognized) #$JNI_TRUE)
     1057           ;; In Darwin, JNI_CreateJavaVM will clobber the calling thread's
     1058           ;; Mach exception ports, despite the fact that CCL is using them.
     1059           ;; To work around this, call a function in the lisp kernel which
     1060           ;; restores the thread's exception ports after calling
     1061           ;; JNI_CreateJavaVM for us.
     1062           (let* ((result
     1063                   (ff-call (ccl::%kernel-import target::kernel-import-jvm-init)
     1064                            :address (foreign-symbol-address "JNI_CreateJavaVM")
     1065                            :address vm
     1066                            :address env
     1067                            :address initargs
     1068                            :int)))
     1069             (if (>= result 0)
     1070               (progn
     1071                 (setq *pvm* (%get-ptr vm))
     1072                 (values result (%get-ptr vm) (%get-ptr env)))
     1073               (error "Can't create Java VM: result = ~d" result)))))))
     1074   args))
     1075
     1076
     1077;;;this is the FLI side of proxy support
    8191078
    8201079(defvar *invocation-handler* nil
    8211080  "this will be set by jfli:enable-java-proxies to a function of 3 args")
    8221081
    823 ;this will be set as the implementation of a native java function
     1082#+todo
     1083(progn
     1084
     1085
     1086;;;this will be set as the implementation of a native java function
    8241087(fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type jobject)
    8251088    ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobject))
     
    8271090
    8281091(defun do-invoke (env obj proxy method args)
    829   ;(declare (ignore env))
     1092  (declare (ignore env))                ;it's not like we're on another thread
    8301093  (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)))))
     1094    (prog1
     1095        (funcall *invocation-handler* proxy method args)
     1096      ;;(jfli::invocation-handler proxy method args)
     1097      (delete-local-ref obj))))
    8361098
    8371099(defun register-invocation-handler (invocation-handler)
     
    12381500)
    12391501
     1502) ; #+todo
Note: See TracChangeset for help on using the changeset viewer.