source: project/jni/jni-base.scm @ 45

Last change on this file since 45 was 45, checked in by daishi, 15 years ago

jni: emit-jni-method (experimental)

File size: 34.7 KB
Line 
1;;;; jni-base.scm
2
3
4(declare
5 (usual-integrations)
6 (export jni:find-class jni:define-class
7         jni:get-version jni:get-superclass
8         jni:is-assignable-from? jni:throw jni:throw-new jni:exception-occurred
9         jni:exception-describe jni:exception-clear jni:fatal-error
10         jni:is-same-object?
11         jni:get-object-class jni:is-instance-of?
12         jni:new-string jni:get-string-length jni:exception-check
13         jni:monitor-enter jni:monitor-exit
14         jni:field jni:static-field jni:get-array-length
15         jni:new-boolean-array jni:new-byte-array jni:new-int-array jni:new-short-array
16         jni:new-char-array jni:new-float-array jni:new-double-array jni:new-long-array
17         jni:new-object-array jni:get-object-array-element jni:set-object-array-element!
18         jni:object? jni:new-string-utf
19         jni:method jni:static-method jni:nonvirtual-method jni:constructor)
20 #;(no-bound-checks))
21
22#>
23#ifdef C_MACOSX
24# include <JavaVM/jni.h>
25#else
26# include <jni.h>
27#endif
28
29static JNIEnv *env;
30static JavaVM *jvm;
31
32static void jni_panic(const char* msg);
33static void init_jvm();
34
35void jni_panic(const char* msg){
36  fprintf(stderr, "jni_panic: %s\n", msg);
37  C_halt(C_SCHEME_FALSE);
38}
39
40void init_jvm(){
41  JavaVMInitArgs vm_args;
42  jint res;
43  vm_args.version = JNI_VERSION_1_2;
44  JNI_GetDefaultJavaVMInitArgs(&vm_args);
45  res = JNI_CreateJavaVM(&jvm, (void **)&env, &vm_args);
46  if(res < 0){
47    jni_panic("cannot create jvm");
48  }
49}             
50<#
51
52(include "jni.scm")
53
54(define-record jni:object ptr)
55
56(define-record-printer (jni:object x p)
57  (fprintf p "#<jobject ~x>" (##sys#pointer->address (jni:object-ptr x))) )
58
59(define (wrap-object ptr)
60  (and ptr
61       (let ((ptr2 (jni:new-global-ref ptr)))
62         (jni:delete-local-ref ptr)
63         (let ((r (make-jni:object ptr2)))
64           (set-finalizer! 
65            r 
66            (lambda (x)
67              #+debug (print "finalizing " x " ...")
68              (jni:delete-global-ref (jni:object-ptr x)) ) )
69           r) ) ) )
70
71(define (unwrap-object o)
72  (and o (jni:object-ptr o)))
73
74(define-foreign-type jobject c-pointer unwrap-object wrap-object)
75
76(define (class-name->class-descriptor name)
77  (string-translate (->string name) "." "/") )
78
79(define-foreign-type class-descriptor c-string class-name->class-descriptor)
80
81#>!
82___declare(default_renaming, "")
83___declare(type, "jniobject;c-pointer;unwrap-object;wrap-object")
84
85#ifndef CHICKEN
86
87static char *build_errmsg = NULL;
88static void *build_errval = NULL;
89
90static jvalue *build_arglist(jvalue *buf, int len, ___scheme_value args, char *sig)
91{
92  int i = 0;
93  jvalue *ptr = buf;
94  ___scheme_value x, args0 = args;
95
96  if(build_errval == NULL) 
97    build_errval = CHICKEN_new_gc_root();
98
99  if(build_errmsg != NULL) build_errmsg = NULL;
100
101  ++sig;
102
103  while(len--) {
104    if(args == C_SCHEME_END_OF_LIST) {
105      build_errmsg = "too few arguments in method call";
106      CHICKEN_gc_root_set(build_errval, args0);
107      return NULL;
108    }
109    else x = C_u_i_car(args);
110   
111    switch(*(sig++)) {
112    case 'Z': ptr->z = x != C_SCHEME_FALSE; break;
113
114    case 'B': 
115      if((x & C_FIXNUM_BIT) != 0)
116        ptr->b = C_unfix(x);
117      else {
118        build_errmsg = "bad argument type - not an exact integer";
119        CHICKEN_gc_root_set(build_errval, x);
120        return NULL;
121      }
122
123      break;
124
125    case 'C': 
126      if((C_header_bits(x) & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
127        ptr->c = C_character_code(x);
128      else {
129        build_errmsg = "bad argument type - not a character";
130        CHICKEN_gc_root_set(build_errval, x);
131        return NULL;
132      }
133
134      break;
135
136    case 'S': 
137      if((x & C_FIXNUM_BIT) != 0) 
138        ptr->s = C_unfix(x);
139      else {
140        build_errmsg = "bad argument type - not an exact integer";
141        CHICKEN_gc_root_set(build_errval, x);
142        return NULL;
143      }
144
145      break;
146
147    case 'I': 
148      if((x & C_FIXNUM_BIT) != 0 || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG))
149        ptr->i = C_num_to_int(x);
150      else {
151        build_errmsg = "bad argument type - not a number";
152        CHICKEN_gc_root_set(build_errval, x);
153        return NULL;
154      }
155
156      break;
157
158    case 'J':
159      if((x & C_FIXNUM_BIT) != 0 || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG))
160        ptr->j = C_num_to_long(x);
161      else {
162        build_errmsg = "bad argument type - not a number";
163        CHICKEN_gc_root_set(build_errval, x);
164        return NULL;
165      }
166
167      break;
168
169    case 'F':
170      if((x & C_FIXNUM_BIT) != 0 || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG))
171        ptr->f = C_c_double(x);
172      else {
173        build_errmsg = "bad argument type - not a number";
174        CHICKEN_gc_root_set(build_errval, x);
175        return NULL;
176      }
177
178      break;
179
180    case 'D':
181      if((x & C_FIXNUM_BIT) != 0 || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG))
182        ptr->d = C_c_double(x);
183      else {
184        build_errmsg = "bad argument type - not a number";
185        CHICKEN_gc_root_set(build_errval, x);
186        return NULL;
187      }
188
189      break;
190
191    case 'L':
192    case'[':
193      while(*sig == '[') ++sig;
194                 
195      if(*sig == 'L') {
196        while(*(sig++) != ';');
197      }
198      else ++sig;
199
200      if(x == C_SCHEME_FALSE) ptr->l = NULL;
201      else if(C_block_header(x) == C_POINTER_TAG || C_block_header(x) == C_TAGGED_POINTER_TAG || C_block_header(x) == C_SWIG_POINTER_TAG)
202        ptr->l = C_c_pointer_nn(x);
203      else {
204        build_errmsg = "bad argument type - not a pointer";
205        CHICKEN_gc_root_set(build_errval, x);
206        return NULL;
207      }
208
209      break;
210    }
211
212    ++ptr;
213    args = C_u_i_cdr(args);
214  }
215
216  return buf;
217}
218
219#endif
220<#
221
222(define-macro (emit-callers tmap #!optional classarg)
223  (define (emit1 ctype call safe?)
224    `(foreign-parse/declare
225      ,(conc (if safe? "___safe " "")
226            "static "
227            ctype
228            " invoke_" call (if safe? "_safe" "")
229            "(jniobject inst, "
230            (if classarg "jniobject clazz, " "") 
231            (let ((ret (not (eq? ctype 'void))))
232            #<#EOF
233___scheme_value md, void *mid, ___scheme_value args, ___fixnum len)
234{
235  jvalue *buf = build_arglist(C_alloca(sizeof(jvalue) * len), len, args, C_c_string(md));
236  if(buf == NULL) return#{(if ret (if (eq? 'jniobject ctype) " NULL" " C_SCHEME_FALSE") "")};
237  #{(if ret "return " "")} (*env)->#{call}A(env, (jobject)inst, #{(if classarg "(jobject)clazz, " "")}(jmethodID)mid, buf);
238}
239EOF
240) ) ) )
241`(begin
242   ,@(map
243     (rec (emit mp)
244      (match mp
245        ((ctype call)
246         (emit `(,ctype ,call #t)))
247        ((ctype call #t)
248         `(begin
249            ,(emit1 ctype call #t)
250            ,(emit1 ctype call #f) ) )
251        ((ctype call _)
252         (emit1 ctype call #f) ) ) )
253     tmap) ) )
254
255(emit-callers ((void CallVoidMethod)
256               (int CallIntMethod)
257               (___bool CallBooleanMethod)
258               (___fixnum CallByteMethod)
259               (char CallCharMethod)
260               (___fixnum CallShortMethod)
261               (int CallLongMethod)
262               (float CallFloatMethod)
263               (double CallDoubleMethod)
264               (jniobject CallObjectMethod) )
265              #f)
266
267(emit-callers ((void CallStaticVoidMethod)
268               (int CallStaticIntMethod)
269               (___bool CallStaticBooleanMethod)
270               (___fixnum CallStaticByteMethod)
271               (char CallStaticCharMethod)
272               (___fixnum CallStaticShortMethod)
273               (int CallStaticLongMethod)
274               (float CallStaticFloatMethod)
275               (double CallStaticDoubleMethod)
276               (jniobject CallStaticObjectMethod) )
277              #f)
278
279(emit-callers ((void CallNonvirtualVoidMethod)
280               (int CallNonvirtualIntMethod)
281               (___bool CallNonvirtualBooleanMethod)
282               (___fixnum CallNonvirtualByteMethod)
283               (char CallNonvirtualCharMethod)
284               (___fixnum CallNonvirtualShortMethod)
285               (int CallNonvirtualLongMethod)
286               (float CallNonvirtualFloatMethod)
287               (double CallNonvirtualDoubleMethod)
288               (jniobject CallNonvirtualObjectMethod) )
289              #t)
290
291(emit-callers ((jniobject NewObject))
292              #f)
293
294
295(define-macro (jni-declare prototype)
296
297  (define usual-naming-transform
298    (let ()
299      (define (downcase-string str)     ; so we don't have to use srfi-13
300        (let ([s2 (string-copy str)]
301              [n (string-length str)] )
302          (do ([i 0 (fx+ i 1)])
303              ((fx>= i n) s2)
304            (string-set! s2 i (char-downcase (string-ref str i))) ) ) )
305      (lambda (m)
306        (downcase-string
307         (string-translate
308          (string-substitute "([a-z])([A-Z])" "\\1-\\2" m #t)
309          "_" "-") ) ) ) )
310
311  (define (ctype->ftype t)
312    (set! t (string-substitute* t '(("const " . "") ("\\s" . ""))))
313    (case (string->symbol t)
314      ((void) 'void)
315      ((jobject jclass jthrowable jstring jarray jobjectArray
316        jbooleanArray jbyteArray jcharArray jshortArray
317        jintArray jlongArray jfloatArray jdoubleArray) 'jobject)
318      ((jmethodID jfieldID) 'c-pointer)
319      ((jboolean) 'bool)
320      ((jbyte) 'byte)
321      ((jchar) 'unsigned-short)
322      ((jshort) 'short)
323      ((jint jlong jsize) 'long)
324      ((jfloat) 'float)
325      ((jdouble) 'double)
326      ((char*) 'c-string)
327      ((jbyte*) 's8vector)
328      ((jchar*) 'u16vector)
329      (else (error "unknown ctype" t))))
330 
331  (let ([matched (string-match "\\s*([^(]+)\\(JNICALL \\*(\\w+)\\)\\s+\\(([^)]+)\\);?" prototype)])
332    (unless matched
333      (error "unknown prototype" prototype))
334    (let ([rettype (ctype->ftype (list-ref matched 1))]
335          [name (list-ref matched 2)]
336          [argtypes (map (lambda (x) (list (ctype->ftype x) (gensym)))
337                         (cdr (string-split (list-ref matched 3) ",")))])
338      `(define ,(string->symbol (string-append "jni:"
339                                  (usual-naming-transform name)
340                                  (cond
341                                   ((string=? (substring name 0 2) "Is") "?")
342                                   ((string=? (substring name 0 3) "Set") "!")
343                                   (else ""))))
344         (foreign-lambda* ,rettype (,@argtypes)
345                          ,(sprintf #<<EOF
346if(env == 0){ init_jvm(); }
347~a((*env)->~a(env~a));
348EOF
349(if (eq? rettype 'void) "" "return")
350name
351(apply string-append (map (lambda (x) (sprintf ", ~a" (cadr x)))
352                          argtypes))
353                                    ))))))
354
355(define-macro (jni-declare-all protos)
356  `(begin
357     ,@(map (lambda (x) `(jni-declare ,x))
358            (string-split
359             (string-substitute* protos
360                                 '(("/\\*([\\s\\S]*?)\\*/" . "")
361                                   (";\\s*$" . ";")))
362             ";"))))
363
364(jni-declare-all #<<EOF
365
366/* cut&paste from jni.h */
367
368  jint     (JNICALL *GetVersion)                   (JNIEnv *);
369  jclass   (JNICALL *DefineClass)                  (JNIEnv *, const char *,
370                                                    jobject, const jbyte *,
371                                                    jsize);
372  jclass   (JNICALL *FindClass)                    (JNIEnv *, const char *);
373
374  jclass   (JNICALL *GetSuperclass)                (JNIEnv *, jclass);
375  jboolean (JNICALL *IsAssignableFrom)             (JNIEnv *, jclass, jclass);
376
377  jint     (JNICALL *Throw)                        (JNIEnv *, jthrowable);
378  jint     (JNICALL *ThrowNew)                     (JNIEnv *, jclass, 
379                                                    const char *);
380  jthrowable (JNICALL *ExceptionOccurred)          (JNIEnv *);
381  void     (JNICALL *ExceptionDescribe)            (JNIEnv *);
382  void     (JNICALL *ExceptionClear)               (JNIEnv *);
383  void     (JNICALL *FatalError)                   (JNIEnv *, const char *);
384
385  jboolean (JNICALL *IsSameObject)                 (JNIEnv *, jobject, 
386                                                    jobject);
387  jclass   (JNICALL *GetObjectClass)               (JNIEnv *, jobject);
388  jboolean (JNICALL *IsInstanceOf)                 (JNIEnv *, jobject, jclass);
389  jmethodID (JNICALL *GetMethodID)                 (JNIEnv *, jclass, 
390                                                    const char *, const char *);
391  jfieldID  (JNICALL *GetFieldID)          (JNIEnv *, jclass, const char *,
392                                            const char *);
393  jobject  (JNICALL *GetObjectField)       (JNIEnv *, jobject, jfieldID);
394  jboolean (JNICALL *GetBooleanField)      (JNIEnv *, jobject, jfieldID);
395  jbyte    (JNICALL *GetByteField)         (JNIEnv *, jobject, jfieldID);
396  jchar    (JNICALL *GetCharField)         (JNIEnv *, jobject, jfieldID);
397  jshort   (JNICALL *GetShortField)        (JNIEnv *, jobject, jfieldID);
398  jint     (JNICALL *GetIntField)          (JNIEnv *, jobject, jfieldID);
399  jlong    (JNICALL *GetLongField)         (JNIEnv *, jobject, jfieldID);
400  jfloat   (JNICALL *GetFloatField)        (JNIEnv *, jobject, jfieldID);
401  jdouble  (JNICALL *GetDoubleField)       (JNIEnv *, jobject, jfieldID);
402  void  (JNICALL *SetObjectField)          (JNIEnv *, jobject,
403                                            jfieldID, jobject);
404  void  (JNICALL *SetBooleanField)         (JNIEnv *, jobject,
405                                            jfieldID, jboolean);
406  void  (JNICALL *SetByteField)            (JNIEnv *, jobject,
407                                            jfieldID, jbyte);
408  void  (JNICALL *SetCharField)            (JNIEnv *, jobject,
409                                            jfieldID, jchar);
410  void  (JNICALL *SetShortField)           (JNIEnv *, jobject,
411                                            jfieldID, jshort);
412  void  (JNICALL *SetIntField)             (JNIEnv *, jobject,
413                                            jfieldID, jint);
414  void  (JNICALL *SetLongField)            (JNIEnv *, jobject,
415                                            jfieldID, jlong);
416  void  (JNICALL *SetFloatField)           (JNIEnv *, jobject,
417                                            jfieldID, jfloat);
418  void  (JNICALL *SetDoubleField)          (JNIEnv *, jobject,
419                                            jfieldID, jdouble);
420  jmethodID (JNICALL *GetStaticMethodID)   (JNIEnv *, jclass, const char *,
421                                            const char *);
422  jfieldID (JNICALL *GetStaticFieldID)        (JNIEnv *, jclass, const char *,
423                                               const char *);
424  jobject  (JNICALL *GetStaticObjectField)    (JNIEnv *, jclass, jfieldID);
425  jboolean (JNICALL *GetStaticBooleanField)   (JNIEnv *, jclass, jfieldID);
426  jbyte    (JNICALL *GetStaticByteField)      (JNIEnv *, jclass, jfieldID);
427  jchar    (JNICALL *GetStaticCharField)      (JNIEnv *, jclass, jfieldID);
428  jshort   (JNICALL *GetStaticShortField)     (JNIEnv *, jclass, jfieldID);
429  jint     (JNICALL *GetStaticIntField)       (JNIEnv *, jclass, jfieldID);
430  jlong    (JNICALL *GetStaticLongField)      (JNIEnv *, jclass, jfieldID);
431  jfloat   (JNICALL *GetStaticFloatField)     (JNIEnv *, jclass, jfieldID);
432  jdouble  (JNICALL *GetStaticDoubleField)    (JNIEnv *, jclass, jfieldID);
433  void  (JNICALL *SetStaticObjectField)    (JNIEnv *, jclass,
434                                            jfieldID, jobject);
435  void  (JNICALL *SetStaticBooleanField)   (JNIEnv *, jclass,
436                                            jfieldID, jboolean);
437  void  (JNICALL *SetStaticByteField)      (JNIEnv *, jclass,
438                                            jfieldID, jbyte);
439  void  (JNICALL *SetStaticCharField)      (JNIEnv *, jclass,
440                                            jfieldID, jchar);
441  void  (JNICALL *SetStaticShortField)     (JNIEnv *, jclass,
442                                            jfieldID, jshort);
443  void  (JNICALL *SetStaticIntField)       (JNIEnv *, jclass,
444                                            jfieldID, jint);
445  void  (JNICALL *SetStaticLongField)      (JNIEnv *, jclass,
446                                            jfieldID, jlong);
447  void  (JNICALL *SetStaticFloatField)     (JNIEnv *, jclass,
448                                            jfieldID, jfloat);
449  void  (JNICALL *SetStaticDoubleField)    (JNIEnv *, jclass,
450                                            jfieldID, jdouble);
451
452  jstring  (JNICALL *NewString)            (JNIEnv *, const jchar *, jsize);
453  jsize    (JNICALL *GetStringLength)      (JNIEnv *, jstring);
454
455/*
456  const jchar * (JNICALL *GetStringChars)  (JNIEnv *, jstring, jboolean *);
457  void     (JNICALL *ReleaseStringChars)   (JNIEnv *, jstring, const jchar *);
458*/
459
460  jstring  (JNICALL *NewStringUTF)         (JNIEnv *, const char *);
461
462/*
463  jsize    (JNICALL *GetStringUTFLength)   (JNIEnv *, jstring);
464  const char * (JNICALL *GetStringUTFChars) (JNIEnv *, jstring, jboolean *);
465  void     (JNICALL *ReleaseStringUTFChars) (JNIEnv *, jstring, const char *);
466*/
467
468  jsize    (JNICALL *GetArrayLength)       (JNIEnv *, jarray);
469  jobjectArray (JNICALL *NewObjectArray)    (JNIEnv *, jsize, jclass, jobject);
470  jobject  (JNICALL *GetObjectArrayElement) (JNIEnv *, jobjectArray, jsize);
471  void     (JNICALL *SetObjectArrayElement) (JNIEnv *, jobjectArray, jsize,
472                                             jobject);
473  jbooleanArray (JNICALL *NewBooleanArray)         (JNIEnv *, jsize);
474  jbyteArray    (JNICALL *NewByteArray)            (JNIEnv *, jsize);
475  jcharArray    (JNICALL *NewCharArray)            (JNIEnv *, jsize);
476  jshortArray   (JNICALL *NewShortArray)           (JNIEnv *, jsize);
477  jintArray     (JNICALL *NewIntArray)             (JNIEnv *, jsize);
478  jlongArray    (JNICALL *NewLongArray)            (JNIEnv *, jsize);
479  jfloatArray   (JNICALL *NewFloatArray)           (JNIEnv *, jsize);
480  jdoubleArray  (JNICALL *NewDoubleArray)          (JNIEnv *, jsize);
481
482/*
483  jboolean *    (JNICALL *GetBooleanArrayElements) (JNIEnv *, jbooleanArray,
484                                                    jboolean *);
485  jbyte *       (JNICALL *GetByteArrayElements)    (JNIEnv *, jbyteArray,
486                                                    jboolean *);
487  jchar *       (JNICALL *GetCharArrayElements)    (JNIEnv *, jcharArray,
488                                                    jboolean *);
489  jshort *      (JNICALL *GetShortArrayElements)   (JNIEnv *, jshortArray,
490                                                    jboolean *);
491  jint *        (JNICALL *GetIntArrayElements)     (JNIEnv *, jintArray,
492                                                    jboolean *);
493  jlong *       (JNICALL *GetLongArrayElements)    (JNIEnv *, jlongArray,
494                                                    jboolean *);
495  jfloat *      (JNICALL *GetFloatArrayElements)   (JNIEnv *, jfloatArray,
496                                                    jboolean *);
497  jdouble *     (JNICALL *GetDoubleArrayElements)  (JNIEnv *, jdoubleArray,
498                                                    jboolean *);
499  void          (JNICALL *ReleaseBooleanArrayElements) (JNIEnv *, jbooleanArray,
500                                                        jboolean *, jint);
501  void          (JNICALL *ReleaseByteArrayElements)    (JNIEnv *, jbyteArray,
502                                                        jbyte *, jint);
503  void          (JNICALL *ReleaseCharArrayElements)    (JNIEnv *, jcharArray,
504                                                        jchar *, jint);
505  void          (JNICALL *ReleaseShortArrayElements)   (JNIEnv *, jshortArray,
506                                                        jshort *, jint);
507  void          (JNICALL *ReleaseIntArrayElements)     (JNIEnv *, jintArray,
508                                                        jint *, jint);
509  void          (JNICALL *ReleaseLongArrayElements)    (JNIEnv *, jlongArray,
510                                                        jlong *, jint);
511  void          (JNICALL *ReleaseFloatArrayElements)   (JNIEnv *, jfloatArray,
512                                                        jfloat *, jint);
513  void          (JNICALL *ReleaseDoubleArrayElements)  (JNIEnv *, jdoubleArray,
514                                                        jdouble *, jint);
515  void          (JNICALL *GetBooleanArrayRegion)   (JNIEnv *, jbooleanArray,
516                                                    jsize, jsize, jboolean *);
517  void          (JNICALL *GetByteArrayRegion)      (JNIEnv *, jbyteArray,
518                                                    jsize, jsize, jbyte *);
519  void          (JNICALL *GetCharArrayRegion)      (JNIEnv *, jcharArray,
520                                                    jsize, jsize, jchar *);
521  void          (JNICALL *GetShortArrayRegion)     (JNIEnv *, jshortArray,
522                                                    jsize, jsize, jshort *);
523  void          (JNICALL *GetIntArrayRegion)       (JNIEnv *, jintArray,
524                                                    jsize, jsize, jint *);
525  void          (JNICALL *GetLongArrayRegion)      (JNIEnv *, jlongArray,
526                                                    jsize, jsize, jlong *);
527  void          (JNICALL *GetFloatArrayRegion)     (JNIEnv *, jfloatArray,
528                                                    jsize, jsize, jfloat *);
529  void          (JNICALL *GetDoubleArrayRegion)    (JNIEnv *, jdoubleArray,
530                                                    jsize, jsize, jdouble *);
531  void          (JNICALL *SetBooleanArrayRegion)   (JNIEnv *, jbooleanArray,
532                                                    jsize, jsize, jboolean *);
533  void          (JNICALL *SetByteArrayRegion)      (JNIEnv *, jbyteArray,
534                                                    jsize, jsize, jbyte *);
535  void          (JNICALL *SetCharArrayRegion)      (JNIEnv *, jcharArray,
536                                                    jsize, jsize, jchar *);
537  void          (JNICALL *SetShortArrayRegion)     (JNIEnv *, jshortArray,
538                                                    jsize, jsize, jshort *);
539  void          (JNICALL *SetIntArrayRegion)       (JNIEnv *, jintArray,
540                                                    jsize, jsize, jint *);
541  void          (JNICALL *SetLongArrayRegion)      (JNIEnv *, jlongArray,
542                                                    jsize, jsize, jlong *);
543  void          (JNICALL *SetFloatArrayRegion)     (JNIEnv *, jfloatArray,
544                                                    jsize, jsize, jfloat *);
545  void          (JNICALL *SetDoubleArrayRegion)    (JNIEnv *, jdoubleArray,
546                                                    jsize, jsize, jdouble *);
547*/
548
549/*
550  jint     (JNICALL *RegisterNatives)              (JNIEnv *, jclass,
551                                                    const JNINativeMethod *, 
552                                                    jint);
553  jint     (JNICALL *UnregisterNatives)            (JNIEnv *, jclass);
554*/
555
556  jint     (JNICALL *MonitorEnter)                 (JNIEnv *, jobject);
557  jint     (JNICALL *MonitorExit)                  (JNIEnv *, jobject);
558
559/*
560  void     (JNICALL *GetStringRegion)              (JNIEnv *, jstring, jsize,
561                                                    jsize, jchar *);
562  void     (JNICALL *GetStringUTFRegion)           (JNIEnv *, jstring, jsize,
563                                                    jsize, char *);
564  void * (JNICALL *GetPrimitiveArrayCritical)      (JNIEnv *, jarray, 
565                                                    jboolean *);
566  void   (JNICALL *ReleasePrimitiveArrayCritical)  (JNIEnv *, jarray, void *, 
567                                                    jint);
568  const jchar * (JNICALL *GetStringCritical)       (JNIEnv *, jstring, 
569                                                    jboolean *);
570  void          (JNICALL *ReleaseStringCritical)   (JNIEnv *, jstring, 
571                                                    const jchar *);
572*/
573
574  jboolean      (JNICALL *ExceptionCheck)          (JNIEnv *);
575
576EOF
577)
578
579(define jni:new-string
580  (let ((old jni:new-string))
581    (lambda (str) (old str (string-length str)))))
582
583(define jni:new-string-utf
584  (let ((old jni:new-string-utf))
585    (lambda (str) (old str (string-length str)))))
586
587(define jni:find-class
588  (let ((old jni:find-class))
589    (lambda (name) (old (class-name->class-descriptor name)))))
590
591(define jni:new-global-ref
592  (foreign-lambda* c-pointer ((c-pointer object))
593    "if(env == 0){ init_jvm(); }"
594    "jobject ret = (*env)->NewGlobalRef(env, object);"
595    "return(ret);"
596    ))
597
598(define jni:delete-global-ref
599  (foreign-lambda* void ((c-pointer object))
600    "if(env == 0){ init_jvm(); }"
601    "(*env)->DeleteGlobalRef(env, object);"
602    ))
603
604(define jni:delete-local-ref
605  (foreign-lambda* void ((c-pointer object))
606    "if(env == 0){ init_jvm(); }"
607    "(*env)->DeleteLocalRef(env, object);"
608    ))
609
610
611(define (jni:type->descriptor t)
612  (case t
613    ((boolean) "Z")
614    ((int) "I")
615    ((char) "C")
616    ((long) "J")
617    ((short) "S")
618    ((byte) "B")
619    ((float) "F")
620    ((double) "D")
621    ((void) "V")
622    (else
623     (match t
624       (('array t) (string-append "[" (jni:type->descriptor t)))
625       ((or (? symbol?) (? string?)) (string-append "L" (class-name->class-descriptor t) ";"))
626       (else (error "invalid Java type specifier" t)) ) ) ) )
627
628(define (jni:type-list->signature tlist)
629  (apply string-append (map jni:type->descriptor tlist)))
630
631(define (checked-return x loc)
632  (let ((msg (foreign-value "build_errmsg" c-string)))
633    (cond (msg
634           (let ((val (foreign-value "CHICKEN_gc_root_ref(build_errval)" scheme-object)))
635             (foreign-code "CHICKEN_gc_root_set(build_errval, C_SCHEME_UNDEFINED);")
636             (error loc msg val) ) )
637          (else x))))
638
639(define-macro (checked-lambda llist . body)
640  `(lambda ,llist (checked-return (begin ,@body) name))) ; yes, `name' is captured
641
642(define-macro (emit-jni-method mtype has-inst has-class)
643  (unless (string=? mtype "") (set! mtype (string-append mtype "-")))
644  `(define (,(string->symbol (sprintf "jni:~amethod" mtype))
645            rtype class name tlist #!optional safe)
646     (let* ((md (string-append "(" (jni:type-list->signature tlist) ")" (jni:type->descriptor rtype)))
647            (mid (or (,(string->symbol (sprintf "jni:get-~amethod-id" mtype))
648                      class (->string name) md)
649                     (error ,(sprintf "jni:~amethod" mtype) "no such method" class name md)))
650            (len (length tlist)) )
651       (case rtype
652         ,@(map (lambda (x)
653                  `(,(car x)
654                    (if safe
655                        ,@(map (lambda (y)
656                                 `(checked-lambda ,(if has-inst '(inst . args) 'args) (,(string->symbol (sprintf "invoke-call-~a~a-method~a" mtype (cdr x) y)) ,@(if has-inst '(inst) '()) ,@(if has-class '(class) '()) md mid args len)))
657                               '("" "-safe")))))
658                '(((void) . void) ((boolean) . boolean) ((byte) . byte)
659                  ((char) . char) ((short) . short) ((int) . int)
660                  ((long) . long) ((float) . float) ((double) . double)
661                  (else . object)))))))
662
663(emit-jni-method "" #t #f)
664(emit-jni-method "static" #f #t)
665(emit-jni-method "nonvirtual" #t #t)
666
667
668#|
669
670(define (jni:method rtype class name tlist #!optional safe)
671  (let* ((md (string-append "(" (jni:type-list->signature tlist) ")" (jni:type->descriptor rtype)))
672         (mid (or (jni:get-method-id class (->string name) md)
673                  (error 'jni:method "no such method" class name md)))
674         (len (length tlist)) )
675    (case rtype
676      ((void)
677       (if safe
678           (checked-lambda (inst . args) (invoke-call-void-method-safe inst md mid args len))
679           (checked-lambda (inst . args) (invoke-call-void-method inst md mid args len)) ) )
680      ((boolean)
681       (if safe
682           (checked-lambda (inst . args) (invoke-call-boolean-method-safe inst md mid args len))
683           (checked-lambda (inst . args) (invoke-call-boolean-method inst md mid args len)) ) )
684      ((byte)
685       (if safe
686           (checked-lambda (inst . args) (invoke-call-byte-method-safe inst md mid args len))
687           (checked-lambda (inst . args) (invoke-call-byte-method inst md mid args len)) ) )
688      ((char)
689       (if safe
690           (checked-lambda (inst . args) (invoke-call-char-method-safe inst md mid args len))
691           (checked-lambda (inst . args) (invoke-call-char-method inst md mid args len)) ) )
692      ((short)
693       (if safe
694           (checked-lambda (inst . args) (invoke-call-short-method-safe inst md mid args len))
695           (checked-lambda (inst . args) (invoke-call-short-method inst md mid args len)) ) )
696      ((int)
697       (if safe
698           (checked-lambda (inst . args) (invoke-call-int-method-safe inst md mid args len))
699           (checked-lambda (inst . args) (invoke-call-int-method inst md mid args len)) ) )
700      ((long)
701       (if safe
702           (checked-lambda (inst . args) (invoke-call-long-method-safe inst md mid args len))
703           (checked-lambda (inst . args) (invoke-call-long-method inst md mid args len)) ) )
704      ((float)
705       (if safe
706           (checked-lambda (inst . args) (invoke-call-float-method-safe inst md mid args len))
707           (checked-lambda (inst . args) (invoke-call-float-method inst md mid args len)) ) )
708      ((double)
709       (if safe
710           (checked-lambda (inst . args) (invoke-call-double-method-safe inst md mid args len))
711           (checked-lambda (inst . args) (invoke-call-double-method inst md mid args len)) ) )
712      (else                             ; otherwise jni:type->descriptor would have failed
713       (if safe
714           (checked-lambda (inst . args) (invoke-call-object-method-safe inst md mid args len))
715           (checked-lambda (inst . args) (invoke-call-object-method inst md mid args len)) ) ) ) ) )
716
717(define (jni:static-method rtype class name tlist #!optional safe)
718  (let* ((md (string-append "(" (jni:type-list->signature tlist) ")" (jni:type->descriptor rtype)))
719         (mid (or (jni:get-static-method-id class (->string name) md)
720                  (error 'jni:static-method "no such method" class name md)))
721         (len (length tlist)) )
722    (case rtype
723      ((void)
724       (if safe
725           (checked-lambda args (invoke-call-static-void-method-safe class md mid args len))
726           (checked-lambda args (invoke-call-static-void-method class md mid args len)) ) )
727      ((boolean)
728       (if safe
729           (checked-lambda args (invoke-call-static-boolean-method-safe class md mid args len))
730           (checked-lambda args (invoke-call-static-boolean-method class md mid args len)) ) )
731      ((byte)
732       (if safe
733           (checked-lambda args (invoke-call-static-byte-method-safe class md mid args len))
734           (checked-lambda args (invoke-call-static-byte-method class md mid args len)) ) )
735      ((char)
736       (if safe
737           (checked-lambda args (invoke-call-static-char-method-safe class md mid args len))
738           (checked-lambda args (invoke-call-static-char-method class md mid args len)) ) )
739      ((short)
740       (if safe
741           (checked-lambda args (invoke-call-static-short-method-safe class md mid args len))
742           (checked-lambda args (invoke-call-static-short-method class md mid args len)) ) )
743      ((int)
744       (if safe
745           (checked-lambda args (invoke-call-static-int-method-safe class md mid args len))
746           (checked-lambda args (invoke-call-static-int-method class md mid args len)) ) )
747      ((long)
748       (if safe
749           (checked-lambda args (invoke-call-static-long-method-safe class md mid args len))
750           (checked-lambda args (invoke-call-static-long-method class md mid args len)) ) )
751      ((float)
752       (if safe
753           (checked-lambda args (invoke-call-static-float-method-safe class md mid args len))
754           (checked-lambda args (invoke-call-static-float-method class md mid args len)) ) )
755      ((double)
756       (if safe
757           (checked-lambda args (invoke-call-static-double-method-safe class md mid args len))
758           (checked-lambda args (invoke-call-static-double-method class md mid args len)) ) )
759      (else                             ; otherwise jni:type->descriptor should have failed
760       (if safe
761           (checked-lambda args (invoke-call-static-object-method-safe class md mid args len))
762           (checked-lambda args (invoke-call-static-object-method class md mid args len)) ) ) ) ) )
763
764(define (jni:nonvirtual-method rtype class name tlist #!optional safe)
765  (let* ((md (string-append "(" (jni:type-list->signature tlist) ")" (jni:type->descriptor rtype)))
766         (mid (or (jni:get-static-method-id class (->string name) md)
767                  (error 'jni:nonvirtual-method "no such method" class name md)))
768         (len (length tlist)) )
769    (case rtype
770      ((void)
771       (if safe
772           (checked-lambda (inst . args) (invoke-call-nonvirtual-void-method-safe inst class md mid args len))
773           (checked-lambda (inst . args) (invoke-call-nonvirtual-void-method inst class md mid args len)) ) )
774      ((boolean)
775       (if safe
776           (checked-lambda (inst . args) (invoke-call-nonvirtual-boolean-method-safe inst class md mid args len))
777           (checked-lambda (inst . args) (invoke-call-nonvirtual-boolean-method inst class md mid args len)) ) )
778      ((byte)
779       (if safe
780           (checked-lambda (inst . args) (invoke-call-nonvirtual-byte-method-safe inst class md mid args len))
781           (checked-lambda (inst . args) (invoke-call-nonvirtual-byte-method inst class md mid args len)) ) )
782      ((char)
783       (if safe
784           (checked-lambda (inst . args) (invoke-call-nonvirtual-char-method-safe inst class md mid args len))
785           (checked-lambda (inst . args) (invoke-call-nonvirtual-char-method inst class md mid args len)) ) )
786      ((short)
787       (if safe
788           (checked-lambda (inst . args) (invoke-call-nonvirtual-short-method-safe inst class md mid args len))
789           (checked-lambda (inst . args) (invoke-call-nonvirtual-short-method inst class md mid args len)) ) )
790      ((int)
791       (if safe
792           (checked-lambda (inst . args) (invoke-call-nonvirtual-int-method-safe inst class md mid args len))
793           (checked-lambda (inst . args) (invoke-call-nonvirtual-int-method inst class md mid args len)) ) )
794      ((long)
795       (if safe
796           (checked-lambda (inst . args) (invoke-call-nonvirtual-long-method-safe inst class md mid args len))
797           (checked-lambda (inst . args) (invoke-call-nonvirtual-long-method inst class md mid args len)) ) )
798      ((float)
799       (if safe
800           (checked-lambda (inst . args) (invoke-call-nonvirtual-float-method-safe inst class md mid args len))
801           (checked-lambda (inst . args) (invoke-call-nonvirtual-float-method inst class md mid args len)) ) )
802      ((double)
803       (if safe
804           (checked-lambda (inst . args) (invoke-call-nonvirtual-double-method-safe inst class md mid args len))
805           (checked-lambda (inst . args) (invoke-call-nonvirtual-double-method inst class md mid args len)) ) )
806      (else                             ; otherwise jni:type->descriptor should have failed
807       (if safe
808           (checked-lambda (inst . args) (invoke-call-nonvirtual-object-method-safe inst class md mid args len))
809           (checked-lambda (inst . args) (invoke-call-nonvirtual-object-method inst class md mid args len)) ) ) ) ) )
810
811|#
812
813(define (jni:constructor class tlist #!optional safe)
814  (let* ((md (string-append "(" (jni:type-list->signature tlist) ")V"))
815         (mid (jni:get-method-id class "<init>" md)) 
816         (len (length tlist)) )
817    (if safe
818        (lambda args (invoke-new-object-safe class md mid args len))
819        (lambda args (invoke-new-object class md mid args len)) ) ) )
820
821(define (jni:field class type name)
822  (let* ((cptr (unwrap-object class))
823         (fid (or (jni:get-field-id cptr (->string name) (jni:type->descriptor type))
824                  (error 'jni:field "no such field" name class) ) ))
825    (case type
826      ((void) (error 'jni:field "invalid field type" type name))
827      ((boolean) 
828       (getter-with-setter 
829        (lambda (inst) (jni:get-boolean-field inst fid))
830        (lambda (inst val) (jni:set-boolean-field! inst fid val)) ) )
831      ((byte) 
832       (getter-with-setter 
833        (lambda (inst) (jni:get-byte-field inst fid))
834        (lambda (inst val) (jni:set-byte-field! inst fid val)) ) )
835      ((int) 
836       (getter-with-setter 
837        (lambda (inst) (jni:get-int-field inst fid))
838        (lambda (inst val) (jni:set-int-field! inst fid val)) ) )
839      ((short) 
840       (getter-with-setter 
841        (lambda (inst) (jni:get-short-field inst fid))
842        (lambda (inst val) (jni:set-short-field! inst fid val)) ) )
843      ((long) 
844       (getter-with-setter 
845        (lambda (inst) (jni:get-long-field inst fid))
846        (lambda (inst val) (jni:set-long-field! inst fid val)) ) )
847      ((float) 
848       (getter-with-setter 
849        (lambda (inst) (jni:get-float-field inst fid))
850        (lambda (inst val) (jni:set-float-field! inst fid val)) ) )
851      ((char) 
852       (getter-with-setter 
853        (lambda (inst) (jni:get-char-field inst fid))
854        (lambda (inst val) (jni:set-char-field! inst fid val)) ) )
855      ((double) 
856       (getter-with-setter 
857        (lambda (inst) (jni:get-double-field inst fid))
858        (lambda (inst val) (jni:set-double-field! inst fid val)) ) )
859      (else
860       (getter-with-setter
861        (lambda (inst) (jni:get-object-field inst fid))
862        (lambda (inst val) (jni:set-object-field! inst fid val))) ) ) ) )
863
864(define (jni:static-field class type name)
865  (let* ((cptr (unwrap-object class))
866         (fid (or (jni:get-static-field-id cptr (->string name) (jni:type->descriptor type))
867                  (error 'jni:field "no such field" name class) ) ))
868    (case type
869      ((void) (error 'jni:field "invalid field type" type name))
870      ((boolean) 
871       (getter-with-setter 
872        (lambda () (jni:get-static-boolean-field class fid))
873        (lambda (val) (jni:set-static-boolean-field! class fid val)) ) )
874      ((byte) 
875       (getter-with-setter 
876        (lambda () (jni:get-static-byte-field class fid))
877        (lambda (val) (jni:set-static-byte-field! class fid val)) ) )
878      ((int) 
879       (getter-with-setter 
880        (lambda () (jni:get-static-int-field class fid))
881        (lambda (val) (jni:set-static-int-field! class fid val)) ) )
882      ((short) 
883       (getter-with-setter 
884        (lambda () (jni:get-static-short-field class fid))
885        (lambda (val) (jni:set-static-short-field! class fid val)) ) )
886      ((long) 
887       (getter-with-setter 
888        (lambda () (jni:get-static-long-field class fid))
889        (lambda (val) (jni:set-static-long-field! class fid val)) ) )
890      ((float) 
891       (getter-with-setter 
892        (lambda () (jni:get-static-float-field class fid))
893        (lambda (val) (jni:set-static-float-field! class fid val)) ) )
894      ((char) 
895       (getter-with-setter 
896        (lambda () (jni:get-static-char-field class fid))
897        (lambda (val) (jni:set-static-char-field! class fid val)) ) )
898      ((double) 
899       (getter-with-setter 
900        (lambda () (jni:get-static-double-field class fid))
901        (lambda (val) (jni:set-static-double-field! class fid val)) ) )
902      (else
903       (getter-with-setter
904        (lambda () (jni:get-static-object-field class fid))
905        (lambda (val) (jni:set-static-object-field! class fid val))) ) ) ) )
906
907;; TODO:
908;;
909;; - strings
910;; - arrays
911;; - exceptions
912;; - extended VM arguments
Note: See TracBrowser for help on using the repository browser.