From a8d09439abee7d1826a7d96da2fdb7bb24beaf75 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 25 Jan 2025 06:50:51 +0200 Subject: [PATCH] Update readme --- README.md | 2 +- retropikzel/r7rs-pffi.sld | 2 +- retropikzel/r7rs-pffi/chibi.scm | 6 ++---- retropikzel/r7rs-pffi/kawa.scm | 7 ++----- retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub | 10 ++++------ test.scm | 9 ++++++--- 6 files changed, 16 insertions(+), 20 deletions(-) diff --git a/README.md b/README.md index e371a51..536ade5 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Portable Foreign Function Interface for R8RS schemes +# Portable Foreign Function Interface for R7RS schemes Foreign function interface that is supported on multiple R7RS Sceheme implementations. diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 4af42e8..87d4f1c 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -31,7 +31,7 @@ pffi-struct-get pffi-struct-set! pffi-define - ;pffi-define-callback + pffi-define-callback ;pffi-pointer-address ;pffi-pointer-dereference ) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm index 403b6cf..e8d5694 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/retropikzel/r7rs-pffi/chibi.scm @@ -194,9 +194,7 @@ (map argument->pointer arguments argument-types)) - (cond ((equal? return-type 'pointer) - return-value) - ((not (equal? return-type 'void)) + (cond ((not (equal? return-type 'void)) (pffi-pointer-get return-value return-type 0))))))) (define-syntax pffi-define @@ -211,7 +209,7 @@ (define make-c-callback (lambda (return-type argument-types procedure) - procedure)) + (scheme-procedure-to-pointer procedure))) (define-syntax pffi-define-callback (syntax-rules () diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm index 3a1c6c7..b40b738 100644 --- a/retropikzel/r7rs-pffi/kawa.scm +++ b/retropikzel/r7rs-pffi/kawa.scm @@ -28,7 +28,6 @@ (java.lang.Char value)) (else value)))) - (define pffi-type->native-type (lambda (type) (cond @@ -90,8 +89,6 @@ (looper (+ count 1) (append result (list count))))))) (looper from (list))))) - - (define-syntax pffi-define-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) @@ -185,7 +182,7 @@ 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'set - (invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type)) + (invoke (pffi-type->native-type type) 'withByteAlignment 1) offset value))) @@ -194,6 +191,6 @@ (let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'get - (invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type)) + (invoke (pffi-type->native-type type) 'withByteAlignment 1) offset))) r))) diff --git a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub b/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub index bde16cd..8010bab 100644 --- a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub +++ b/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub @@ -240,8 +240,6 @@ (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 @@ -254,11 +252,11 @@ (array void*))) (c-declare - "void* scheme_procedure_to_pointer(void* proc) { - /*if(sexp_procedurep(proc) == 1) { + "void* scheme_procedure_to_pointer(sexp proc) { + if(sexp_procedurep(proc) == 1) { puts(\"ITS A PROCEDURE\"); - }*/ - return proc; + } + return proc->var; }") (define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/test.scm b/test.scm index 56c34b9..3c71e89 100644 --- a/test.scm +++ b/test.scm @@ -403,7 +403,7 @@ (print-header "pffi-pointer-set! and pffi-pointer-get 1/2") (define set-pointer (pffi-pointer-allocate 256)) -(define offset 0) +(define offset 64) (define value 1) (debug set-pointer) (debug offset) @@ -691,6 +691,7 @@ (print-header "pffi-struct-make with pointer") (pffi-define c-test-new c-testlib 'test_new 'pointer (list)) +(define struct-test2-pointer (c-test-new)) (define struct-test2 (pffi-struct-make 'test '((int8 . a) (char . b) @@ -706,11 +707,13 @@ (int . l) (double . m) (float . n)) - (c-test-new))) + struct-test2-pointer)) (debug struct-test2) +(debug (pffi-pointer-get struct-test2-pointer 'int8 0)) (debug (pffi-struct-get struct-test2 'a)) (assert = (pffi-struct-get struct-test2 'a) 1) +(debug (pffi-pointer-get struct-test2-pointer 'char 1)) (debug (pffi-struct-get struct-test2 'b)) (assert char=? (pffi-struct-get struct-test2 'b) #\b) (debug (pffi-struct-get struct-test2 'c)) @@ -768,7 +771,7 @@ (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) (newline) -(qsort array 3 (pffi-size-of 'int) compare) +;(qsort array 3 (pffi-size-of 'int) compare) (display "Sorted: ") (write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))