Some Chibi file renaming

Makefile

@@ -5,8 +5,8 @@ test-chibi-podman-amd64:
 	podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/chicken bash -c "cd /workdir && ${CHIBI} test.scm"
 
 test-chibi:
-	chibi-ffi retropikzel/r7rs-pffi/chibi.stub
+	chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub
-	${CC} -o retropikzel/r7rs-pffi/chibi.so -fPIC -shared retropikzel/r7rs-pffi/chibi.c -lchibi-scheme -lffi
+	${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi
 	${CHIBI} test.scm
 
 CHICKEN=csc -X r7rs -R r7rs

retropikzel/r7rs-pffi.sld

@@ -9,7 +9,7 @@
               (scheme process-context)
               (chibi ast)
               (chibi))
-      (include-shared "r7rs-pffi/chibi"))
+      (include-shared "r7rs-pffi/r7rs-pffi-chibi"))
     (chicken
       (import (scheme base)
               (scheme write)

retropikzel/r7rs-pffi/chibi.scm

@@ -1,6 +1,6 @@
 (define pffi-init (lambda () #t))
 
-;(write (get-ffi-type-int))
+;(write (scheme-procedure-to-pointer (lambda () (display "Hello"))))
 ;(newline)
 ;(exit)
 
@@ -162,12 +162,25 @@
       ((equal? type 'callback) (get-ffi-type-pointer))
       )))
 
+(define argument->pointer
+  (lambda (value type)
+    (cond ((pffi-pointer? value)
+           value)
+          ((procedure? value)
+           (scheme-procedure-to-pointer value))
+          (else (let ((pointer (pffi-pointer-allocate (pffi-size-of type))))
+                  (pffi-pointer-set! pointer type 0 value)
+                  pointer)))))
+
 (define make-c-function
   (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))))
+          (return-value (pffi-pointer-allocate
+                          (if (equal? return-type 'void)
+                            0
+                            (pffi-size-of return-type)))))
       (when (not (pffi-pointer-null? maybe-dlerror))
         (error (pffi-pointer->string maybe-dlerror)))
       (lambda (argument-1 . arguments)
@@ -176,8 +189,13 @@
                            (map pffi-type->libffi-type argument-types)
                            func
                            return-value
-                           (append (list argument-1) arguments))
+                           (map argument->pointer
-        (pffi-pointer-get return-value return-type 0)))))
+                                (append (list argument-1) arguments)
+                                argument-types))
+        (cond ((equal? return-type 'pointer)
+               return-value)
+              ((not (equal? return-type 'void))
+               (pffi-pointer-get return-value return-type 0)))))))
 
 (define-syntax pffi-define
   (syntax-rules ()
@@ -187,3 +205,14 @@
                         return-type
                         (symbol->string c-name)
                         argument-types)))))
+
+
+(define make-c-callback
+  (lambda (return-type argument-types procedure)
+    procedure))
+
+(define-syntax pffi-define-callback
+  (syntax-rules ()
+    ((pffi-define scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (make-c-callback return-type argument-types procedure)))))

retropikzel/r7rs-pffi/chibi.stub

@@ -253,5 +253,12 @@
             (pointer void*)
             (array void*)))
 
+(c-declare
+  "void* scheme_procedure_to_pointer(void* proc) {
+    if(sexp_procedurep(proc) == 1) {
+      puts(\"ITS A PROCEDURE\");
+    }
+    return proc;
+  }")
 
-
+(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))

retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub

@@ -0,0 +1,264 @@
+; vim: ft=scheme
+
+(c-system-include "stdint.h")
+(c-system-include "dlfcn.h")
+(c-system-include "ffi.h")
+
+;; pffi-size-of
+(c-declare "
+    int size_of_int8_t() { return sizeof(int8_t); }
+    int size_of_uint8_t() { return sizeof(uint8_t); }
+    int size_of_int16_t() { return sizeof(int16_t); }
+    int size_of_uint16_t() { return sizeof(uint16_t); }
+    int size_of_int32_t() { return sizeof(int32_t); }
+    int size_of_uint32_t() { return sizeof(uint32_t); }
+    int size_of_int64_t() { return sizeof(int64_t); }
+    int size_of_uint64_t() { return sizeof(uint64_t); }
+    int size_of_char() { return sizeof(char); }
+    int size_of_unsigned_char() { return sizeof(unsigned char); }
+    int size_of_short() { return sizeof(short); }
+    int size_of_unsigned_short() { return sizeof(unsigned short); }
+    int size_of_int() { return sizeof(int); }
+    int size_of_unsigned_int() { return sizeof(unsigned int); }
+    int size_of_long() { return sizeof(long); }
+    int size_of_unsigned_long() { return sizeof(unsigned long); }
+    int size_of_float() { return sizeof(float); }
+    int size_of_double() { return sizeof(double); }
+    int size_of_pointer() { return sizeof(void*); }
+")
+
+(define-c int (size-of-int8_t size_of_int8_t) ())
+(define-c int (size-of-uint8_t size_of_uint8_t) ())
+(define-c int (size-of-int16_t size_of_int16_t) ())
+(define-c int (size-of-uint16_t size_of_uint16_t) ())
+(define-c int (size-of-int32_t size_of_int32_t) ())
+(define-c int (size-of-uint32_t size_of_uint32_t) ())
+(define-c int (size-of-int64_t size_of_int64_t) ())
+(define-c int (size-of-uint64_t size_of_uint64_t) ())
+(define-c int (size-of-char size_of_char) ())
+(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
+(define-c int (size-of-short size_of_short) ())
+(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
+(define-c int (size-of-int size_of_int) ())
+(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
+(define-c int (size-of-long size_of_long) ())
+(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
+(define-c int (size-of-float size_of_float) ())
+(define-c int (size-of-double size_of_double) ())
+(define-c int (size-of-pointer size_of_pointer) ())
+
+;; 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) ())
+
+(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }")
+(define-c bool (is-pointer-null is_pointer_null) ((maybe-null void*)))
+
+(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
+(define-c (maybe-null void*) (pointer-allocate pointer_allocate) (int))
+
+(c-declare "void pointer_free(void* pointer) { free(pointer); }")
+(define-c void (pointer-free pointer_free) ((maybe-null void*)))
+
+;; pffi-pointer-set!
+(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { int8_t* p = (int8_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
+(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { uint8_t* p = (uint8_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t))
+
+(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { int16_t* p = (int16_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t))
+(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { uint16_t* p = (uint16_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t))
+
+(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { int32_t* p = (int32_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t))
+(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { uint32_t* p = (uint32_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t))
+
+(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { int64_t* p = (int64_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t))
+(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { uint64_t* p = (uint64_t*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
+
+(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { char* p = (char*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char))
+(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { unsigned char* p = (unsigned char*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
+
+(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { short* p = (short*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short))
+(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { short* p = (unsigned short*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short))
+
+(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { int* p = (int*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int))
+(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { int* p = (unsigned int*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int))
+
+(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { long* p = (long*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long))
+(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { long* p = (unsigned long*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long))
+
+(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { float* p = (float*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float))
+
+(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { double* p = (double*)pointer; p[offset] = value; }")
+(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double))
+
+(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { void* p = &pointer + offset; p = value; }")
+(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null void*)))
+
+;; pffi-pointer-get
+(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { int8_t* p = (int8_t*)pointer; return p[offset]; }")
+(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
+(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { uint8_t* p = (uint8_t*)pointer; return p[offset]; }")
+(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int))
+
+(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { int16_t* p = (int16_t*)pointer; return p[offset]; }")
+(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int))
+(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { uint16_t* p = (uint16_t*)pointer; return p[offset]; }")
+(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int))
+
+(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { int32_t* p = (int32_t*)pointer; return p[offset]; }")
+(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int))
+(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { uint32_t* p = (uint32_t*)pointer; return p[offset]; }")
+(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int))
+
+(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { int64_t* p = (int64_t*)pointer; return p[offset]; }")
+(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int))
+(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { uint64_t* p = (uint64_t*)pointer; return p[offset]; }")
+(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
+
+(c-declare "char pointer_ref_c_char(void* pointer, int offset) { char* p = (char*)pointer; return p[offset]; }")
+(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
+(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { unsigned char* p = (unsigned char*)pointer; return p[offset]; }")
+(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
+
+(c-declare "short pointer_ref_c_short(void* pointer, int offset) { short* p = (short*)pointer; return p[offset]; }")
+(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int))
+(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { unsigned short* p = (unsigned short*)pointer; return p[offset]; }")
+(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int))
+
+(c-declare "int pointer_ref_c_int(void* pointer, int offset) { int* p = (int*)pointer; return p[offset]; }")
+(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int))
+(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { unsigned int* p = (unsigned int*)pointer; return p[offset]; }")
+(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int))
+
+(c-declare "long pointer_ref_c_long(void* pointer, int offset) { long* p = (long*)pointer; return p[offset]; }")
+(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long))
+(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { unsigned long* p = (unsigned long*)pointer; return p[offset]; }")
+(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int))
+
+(c-declare "float pointer_ref_c_float(void* pointer, int offset) { float* p = (float*)pointer; return p[offset]; }")
+(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int))
+
+(c-declare "double pointer_ref_c_double(void* pointer, int offset) { double* p = (double*)pointer; return p[offset]; }")
+(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int))
+
+(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { void* p = &pointer + offset; return p;}")
+(define-c (maybe-null void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
+
+;; pffi-string->pointer
+(c-declare "void* string_to_pointer(char* string) { return (void*)string; }")
+(define-c (maybe-null void*) (string-to-pointer string_to_pointer) (string))
+
+;; pffi-pointer->string
+(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
+(define-c string (pointer-to-string pointer_to_string) ((maybe-null void*)))
+
+;; pffi-define
+
+(c-declare "ffi_cif cif;")
+(define-c (pointer void*) dlsym ((maybe-null void*) string))
+
+(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }")
+(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ())
+(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }")
+(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ())
+
+(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }")
+(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ())
+(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }")
+(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ())
+
+(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }")
+(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ())
+(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }")
+(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ())
+
+(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }")
+(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ())
+(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }")
+(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ())
+
+(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }")
+(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ())
+(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }")
+(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ())
+
+(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }")
+(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ())
+(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }")
+(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ())
+
+(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }")
+(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ())
+(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }")
+(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ())
+
+(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }")
+(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ())
+
+(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }")
+(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ())
+
+(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }")
+(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ())
+
+(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }")
+(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ())
+
+(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }")
+(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ())
+
+(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[]) {
+    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*)))
+
+(c-declare
+  "void* scheme_procedure_to_pointer(void* proc) {
+    /*if(sexp_procedurep(proc) == 1) {
+      puts(\"ITS A PROCEDURE\");
+    }*/
+    return proc;
+  }")
+
+(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))