- argument conversion for callbacks now work.

- added more tests in lab/test-ffi.ss

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^
+(define foradd1-by-foreign-call
-  (syntax-rules ()
+  ((make-callback 'sint32 '(sint32))
-    [(_ expr)
+     (trace-lambda foradd1-by-foreign-call (n) 
-     (begin 
+       (/ (ho traced-foradd1 n) 2))))
-       (line)
+
-       (printf "TESTING ~s\n" 'expr)
+(check = (ho (dlsym self "cadd1") 17) (+ 18 18))
-       (assert expr)
+(check = (ho foradd1 17) (+ 18 18))
-       (printf "OK\n"))]))
+(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")

scheme/last-revision

@@ -1 +1 @@
-1604
+1605

src/ikarus-ffi.c

@@ -49,29 +49,28 @@ alloc_room_for_type(int n){
 
 extern long extract_num(ikptr x);
 
-static void*
+static void
-scheme_to_ffi_value_cast(int n, ikptr p) {
+scheme_to_ffi_value_cast(int n, ikptr p, void* r) {
-  void* r = alloc_room_for_type(n);
   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; i<n; i++){
     ikptr t = ref(typevec, off_vector_data + i * wordsize);
     ikptr v = ref(argsvec, off_vector_data + i * wordsize);
-    avalues[i] = scheme_to_ffi_value_cast(unfix(t), v);
+    void* p = alloc_room_for_type(unfix(t));
+    avalues[i] = p;
+    scheme_to_ffi_value_cast(unfix(t), v, p);
   }
   avalues[n] = NULL;
-  void* rvalue = alloc_room_for_type(unfix(rtype));;
+  void* rvalue = alloc_room_for_type(unfix(rtype));
   ffi_call(cif, fn, rvalue, avalues);
   ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
   for(i=0; i<n; i++){
@@ -332,18 +333,25 @@ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
   ikptr proc   = ref(data, off_vector_data + 1 * wordsize);
   ikptr argtypes_conv = ref(data, off_vector_data + 2 * wordsize);
   ikptr rtype_conv = ref(data, off_vector_data + 3 * wordsize);
+  ikptr n = unfix(ref(argtypes_conv, off_vector_length));
 
   ikpcb* pcb = the_pcb;
   ikptr code_entry = ref(proc, off_closure_code);
   ikptr code_ptr = code_entry - off_code_data;
 
   pcb->frame_pointer = pcb->frame_base;
-  ref(pcb->frame_pointer, -2*wordsize) = fix(*((int*)args[0]));
+  int i;
-  ikptr rv = ik_exec_code(pcb, code_ptr, fix(-1), proc); 
+  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) {