diff --git a/Makefile b/Makefile index 837dc3b..c191936 100644 --- a/Makefile +++ b/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 - ${CC} -o retropikzel/r7rs-pffi/chibi.so -fPIC -shared retropikzel/r7rs-pffi/chibi.c -lchibi-scheme -lffi + chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub + ${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 diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 43d00bb..3efa784 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/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) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm index 2bd4d32..7c15d3a 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/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)) - (pffi-pointer-get return-value return-type 0))))) + (map argument->pointer + (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))))) diff --git a/retropikzel/r7rs-pffi/chibi.stub b/retropikzel/r7rs-pffi/chibi.stub index 0791b36..e0781dc 100644 --- a/retropikzel/r7rs-pffi/chibi.stub +++ b/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)) diff --git a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub b/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub new file mode 100644 index 0000000..0d44b4c --- /dev/null +++ b/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))