diff --git a/IMPLEMENTATION_NOTES.md b/IMPLEMENTATION_NOTES.md new file mode 100644 index 0000000..a152fe8 --- /dev/null +++ b/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. diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm index 4ac89f1..3fc9740 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/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))))) diff --git a/retropikzel/r7rs-pffi/chibi.stub b/retropikzel/r7rs-pffi/chibi.stub index e01019f..d1a4bbb 100644 --- a/retropikzel/r7rs-pffi/chibi.stub +++ b/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*))) diff --git a/test.scm b/test.scm index fa462f4..0094d09 100644 --- a/test.scm +++ b/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)