Added pffi-define support for Chibi

IMPLEMENTATION_NOTES.md

@@ -0,0 +1,6 @@
+## Error early
+
+Always load with RTLD_NOW if possible so loading happens at start of program.
+
+Always to to find the function when pffi-define is run, not when the function itself is run so
+any errors will happen on the program start.

retropikzel/r7rs-pffi/chibi.scm

@@ -29,7 +29,11 @@
 
 (define pffi-shared-object-load
   (lambda (headers path)
-    (dlopen path RTLD-NOW)))
+    (let ((shared-object (dlopen path RTLD-NOW))
+          (maybe-error (dlerror)))
+      (when (not (pffi-pointer-null? maybe-error))
+        (error (pffi-pointer->string maybe-error)))
+      shared-object)))
 
 (define pffi-pointer-null
   (lambda ()
@@ -145,7 +149,7 @@
       ;((equal? type 'bool) ffi_type_sint8)
       ;((equal? type 'short) ffi_type_sint16)
       ;((equal? type 'unsigned-short) ffi_type_uint16)
-      ((equal? type 'int) (get-ffi-type-int))
+      ((equal? type 'int) (get-ffi-type-sint))
       ;((equal? type 'unsigned-int) ffi_type_uint32)
       ;((equal? type 'long) ffi_type_long)
       ;((equal? type 'unsigned-long) ffi_type_uint32)
@@ -157,35 +161,28 @@
       )))
 
 (define make-c-function
-  (lambda (shared-object return-type c-name args)
-    (let ((func (dlsym shared-object c-name)))
-      (display "HERE: ")
-      (write args)
-      (newline)
-      (write (length args))
-      (newline)
-      (write (pffi-type->libffi-type return-type))
-      (newline)
-      (write (map
-               (lambda (item)
-                 (display "ITEM: ")
-                 (write item)
-                 (newline))
-                 args))
-      (newline)
-      (internal-ffi-prep-cif (length args)
-                    return-type
-                    args
-                    )
-      func
-
-    )))
+  (lambda (shared-object return-type c-name argument-types)
+    (dlerror) ;; Clean all previous errors
+    (let ((func (dlsym shared-object c-name))
+          (maybe-dlerror (dlerror))
+          (return-value (pffi-pointer-allocate (pffi-size-of return-type))))
+      (when (not (pffi-pointer-null? maybe-dlerror))
+        (error (pffi-pointer->string maybe-dlerror)))
+      (lambda (argument-1 . arguments)
+        (cond ((equal? return-type 'int)
+                 (internal-ffi-call (length argument-types)
+                                    (pffi-type->libffi-type return-type)
+                                    (map pffi-type->libffi-type argument-types)
+                                    func
+                                    return-value
+                                    (append (list argument-1) arguments))
+               (pffi-pointer-get return-value 'int 0)))))))
 
 (define-syntax pffi-define
   (syntax-rules ()
     ((pffi-define scheme-name shared-object c-name return-type argument-types)
      (define scheme-name
        (make-c-function shared-object
-                        (pffi-type->libffi-type return-type)
+                        return-type
                         (symbol->string c-name)
-                        (map pffi-type->libffi-type argument-types))))))
+                        argument-types)))))

retropikzel/r7rs-pffi/chibi.stub

@@ -50,6 +50,7 @@
 ;; pffi-shape-object-load
 (define-c-const int (RTLD-NOW "RTLD_NOW"))
 (define-c (maybe-null void*) dlopen (string int))
+(define-c (maybe-null void*) dlerror ())
 
 (c-declare "void* pointer_null() { return NULL; }")
 (define-c (maybe-null void*) (pointer-null pointer_null) ())
@@ -174,7 +175,8 @@
 ;; pffi-define
 
 (c-declare "ffi_cif cif;")
-(define-c (maybe-null void*) dlsym ((maybe-null void*) string))
+(define-c (pointer void*) dlsym ((maybe-null void*) string))
+
 
 
 ;(define-c-type ffi_status)
@@ -184,17 +186,34 @@
 
 ;(c-declare "ffi_type* test1() { ffi_type* p = malloc(sizeof(ffi_type_sint32)); p->size = &ffi_type_sint32->size; return p; }")
 ;(define-c ffi_type test1 ())
-(c-declare "ffi_type* get_ffi_type_int() { ffi_type* p = malloc(sizeof(ffi_type)); return p; }")
-(define-c void* (get-ffi-type-int get_ffi_type_int) ())
+(c-declare "void* get_ffi_type_sint() { return &ffi_type_sint; }")
+(define-c (pointer void*) (get-ffi-type-sint get_ffi_type_sint) ())
 
-(c-declare "ffi_type* get_ffi_type_pointer() { ffi_type* p = malloc(sizeof(ffi_type)); return p; }")
-(define-c void* (get-ffi-type-pointer get_ffi_type_pointer) ())
+(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }")
+(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
 
+(define-c-const int (FFI-OK "FFI_OK"))
 (c-declare
-  "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void** atypes) {
+  "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
+    printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
     return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
   }")
 (define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
+(c-declare
+  "void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, void* avalues) {
+    ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
+    char* s = \"MORO\";
+    void* values[] = {&s};
+    ffi_call(&cif, FFI_FN(fn), rvalue, &avalues);
+  }")
+(define-c void
+          (internal-ffi-call internal_ffi_call)
+          (unsigned-int
+            (pointer void*)
+            (array void*)
+            (pointer void*)
+            (pointer void*)
+            (array void*)))
 
 
 

test.scm

@@ -354,10 +354,15 @@
 
 (print-header 'pffi-define)
 
+(pffi-define puts libc-stdlib 'puts 'int (list 'pointer))
+(display "HERE: ")
+(write (puts (pffi-string->pointer "Hello from testing, I am C function puts")))
+(newline)
+
+#|
 (pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
 (assert = (atoi (pffi-string->pointer "100")) 100)
 
-#|
 ;; pffi-define-callback
 
 (print-header 'pffi-define-callback)