diff --git a/lab/test-ffi.ss b/lab/test-ffi.ss index f2bf42d..0ebcabf 100644 --- a/lab/test-ffi.ss +++ b/lab/test-ffi.ss @@ -1,43 +1,107 @@ (import (ikarus) (ikarus system $foreign)) +(define-syntax check + (syntax-rules () + [(_ pred expr expected) + (begin + (line) + (printf "TESTING ~s\n" 'expr) + (let ([v0 expr] [v1 expected]) + (unless (pred v0 v1) + (error 'pred "failed" v0 v1))) + (printf "OK\n"))])) + +(define (line) + (printf "=========================================================\n")) + + (define self (dlopen #f)) (define hosym (dlsym self "ho")) (define ho ((make-ffi 'sint32 '(pointer sint32)) hosym)) -(define foradd1 +(define traced-foradd1 ((make-callback 'sint32 '(sint32)) (trace-lambda add1 (n) - (printf "collecting ...\n") (collect) - (printf "collecting done\n") (add1 n)))) -(define foradd1^ +(define foradd1 ((make-callback 'sint32 '(sint32)) (lambda (n) - (printf "collecting ...\n") (collect) - (printf "collecting done\n") (add1 n)))) -(define-syntax assert^ - (syntax-rules () - [(_ expr) - (begin - (line) - (printf "TESTING ~s\n" 'expr) - (assert expr) - (printf "OK\n"))])) +(define foradd1-by-foreign-call + ((make-callback 'sint32 '(sint32)) + (trace-lambda foradd1-by-foreign-call (n) + (/ (ho traced-foradd1 n) 2)))) + +(check = (ho (dlsym self "cadd1") 17) (+ 18 18)) +(check = (ho foradd1 17) (+ 18 18)) +(check = (ho traced-foradd1 17) (+ 18 18)) +(check = (ho foradd1-by-foreign-call 17) (+ 18 18)) + + +(define test_I_I + ((make-ffi 'sint32 '(pointer sint32)) (dlsym self "test_I_I"))) +(define test_I_II + ((make-ffi 'sint32 '(pointer sint32 sint32)) (dlsym self "test_I_II"))) +(define test_I_III + ((make-ffi 'sint32 '(pointer sint32 sint32 sint32)) (dlsym self "test_I_III"))) + +(define C_add_I_I (dlsym self "add_I_I")) +(define C_add_I_II (dlsym self "add_I_II")) +(define C_add_I_III (dlsym self "add_I_III")) + +(check = (test_I_I C_add_I_I 12) (+ 12)) +(check = (test_I_II C_add_I_II 12 13) (+ 12 13)) +(check = (test_I_III C_add_I_III 12 13 14) (+ 12 13 14)) + +(define S_add_I_I ((make-callback 'sint32 '(sint32)) +)) +(define S_add_I_II ((make-callback 'sint32 '(sint32 sint32)) +)) +(define S_add_I_III ((make-callback 'sint32 '(sint32 sint32 sint32)) +)) + +(check = (test_I_I S_add_I_I 12) (+ 12)) +(check = (test_I_II S_add_I_II 12 13) (+ 12 13)) +(check = (test_I_III S_add_I_III 12 13 14) (+ 12 13 14)) + + +(define test_D_D + ((make-ffi 'double '(pointer double)) (dlsym self "test_D_D"))) +(define test_D_DD + ((make-ffi 'double '(pointer double double)) (dlsym self "test_D_DD"))) +(define test_D_DDD + ((make-ffi 'double '(pointer double double double)) (dlsym self "test_D_DDD"))) + +(define C_add_D_D (dlsym self "add_D_D")) +(define C_add_D_DD (dlsym self "add_D_DD")) +(define C_add_D_DDD (dlsym self "add_D_DDD")) + +(check = (test_D_D C_add_D_D 12.0) (+ 12.0)) +(check = (test_D_DD C_add_D_DD 12.0 13.0) (+ 12.0 13.0)) +(check = (test_D_DDD C_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0)) + +(define S_add_D_D ((make-callback 'double '(double)) +)) +(define S_add_D_DD ((make-callback 'double '(double double)) +)) +(define S_add_D_DDD ((make-callback 'double '(double double double)) +)) + +(check = (test_D_D S_add_D_D 12.0) (+ 12.0)) +(check = (test_D_DD S_add_D_DD 12.0 13.0) (+ 12.0 13.0)) +(check = (test_D_DDD S_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0)) + + + + + + + + + -(define (line) - (printf "=========================================================\n")) -(assert^ (= (ho (dlsym self "cadd1") 17) (+ 18 18))) -(assert^ (= (ho foradd1^ 17) (+ 18 18))) -(assert^ (= (ho foradd1 17) (+ 18 18))) (line) (printf "Happy Happy Joy Joy\n") diff --git a/scheme/last-revision b/scheme/last-revision index a5e7f96..f1c7d2b 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1604 +1605 diff --git a/src/ikarus-ffi.c b/src/ikarus-ffi.c index d5d486d..26dab76 100644 --- a/src/ikarus-ffi.c +++ b/src/ikarus-ffi.c @@ -49,29 +49,28 @@ alloc_room_for_type(int n){ extern long extract_num(ikptr x); -static void* -scheme_to_ffi_value_cast(int n, ikptr p) { - void* r = alloc_room_for_type(n); +static void +scheme_to_ffi_value_cast(int n, ikptr p, void* r) { switch (n & 0xF) { - case 1: { free(r); return NULL; } + case 1: { return; } case 2: // ffi_type_uint8; case 3: - { *((char*)r) = extract_num(p); return r; } + { *((char*)r) = extract_num(p); return; } case 4: // ffi_type_uint16; case 5: - { *((short*)r) = extract_num(p); return r; } + { *((short*)r) = extract_num(p); return; } case 6: // ffi_type_uint32; case 7: - { *((int*)r) = extract_num(p); return r; } + { *((int*)r) = extract_num(p); return; } case 8: // ffi_type_uint64; case 9: - { *((long*)r) = extract_num(p); return r; } + { *((long*)r) = extract_num(p); return; } case 10: //return &ffi_type_float; - { *((float*)r) = flonum_data(p); return r; } + { *((float*)r) = flonum_data(p); return; } case 11: //return &ffi_type_double; - { *((double*)r) = flonum_data(p); return r; } + { *((double*)r) = flonum_data(p); return; } case 12: //return &ffi_type_pointer; - { *((void**)r) = (void*)ref(p, off_pointer_data); return r; } + { *((void**)r) = (void*)ref(p, off_pointer_data); return; } default: fprintf(stderr, "INVALID ARG %d", n); exit(-1); @@ -269,10 +268,12 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) { for(i=0; iframe_pointer = pcb->frame_base; - ref(pcb->frame_pointer, -2*wordsize) = fix(*((int*)args[0])); - ikptr rv = ik_exec_code(pcb, code_ptr, fix(-1), proc); + int i; + for(i = 0; i < n; i++){ + ikptr argt = ref(argtypes_conv, off_vector_data + i*wordsize); + void* argp = args[i]; + ref(pcb->frame_pointer, -2*wordsize - i*wordsize) = + ffi_to_scheme_value_cast(unfix(argt), argp, pcb); + } + ikptr rv = ik_exec_code(pcb, code_ptr, fix(-n), proc); #ifdef DEBUG_FFI fprintf(stderr, "and back with rv=0x%016lx!\n", rv); #endif - *((ikptr*)ret) = unfix(rv); + scheme_to_ffi_value_cast(unfix(rtype_conv), rv, ret); return; } @@ -400,6 +408,55 @@ int ho2 (ikptr fptr, ikptr nptr) { } +int test_I_I (int(*f)(int), int n0) { + return f(n0); +} + +int test_I_II (int(*f)(int,int), int n0, int n1) { + return f(n0,n1); +} + +int test_I_III (int(*f)(int,int,int), int n0, int n1, int n2) { + return f(n0,n1,n2); +} + +int add_I_I(int n0) { + return n0; +} +int add_I_II(int n0, int n1) { + return n0+n1; +} +int add_I_III(int n0, int n1, int n2) { + return n0+n1+n2; +} + + + + +double test_D_D (double(*f)(double), double n0) { + return f(n0); +} + +double test_D_DD (double(*f)(double,double), double n0, double n1) { + return f(n0,n1); +} + +double test_D_DDD (double(*f)(double,double,double), double n0, double n1, double n2) { + return f(n0,n1,n2); +} + +double add_D_D(double n0) { + return n0; +} +double add_D_DD(double n0, double n1) { + return n0+n1; +} +double add_D_DDD(double n0, double n1, double n2) { + return n0+n1+n2; +} + + + int cadd1 (int n) {