From 5df5638f6b0f58995487f5477f5e6e69038af9a1 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 31 Jan 2025 18:23:57 +0200 Subject: [PATCH] Fix auto-load versions and paths handling --- README.md | 16 +++--- retropikzel/r7rs-pffi.sld | 3 ++ retropikzel/r7rs-pffi/chicken5.scm | 8 +-- retropikzel/r7rs-pffi/guile.scm | 9 ++-- retropikzel/r7rs-pffi/main.scm | 80 ++++++++++++------------------ retropikzel/r7rs-pffi/mosh.scm | 5 ++ test.scm | 8 +-- 7 files changed, 62 insertions(+), 67 deletions(-) diff --git a/README.md b/README.md index 4ca013b..1adf4e5 100644 --- a/README.md +++ b/README.md @@ -113,7 +113,7 @@ Usage recommended. | pffi-struct-offset-get | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | pffi-struct-get | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | pffi-struct-set! | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-dereference | | | | | | | | | | | | X | | | | | +| pffi-struct-dereference | | X | | | | | X | | | X | X | X | | | | | | pffi-define | X | X | X | | | | X | X | | X | X | X | | | | | | pffi-define-callback | | X | | | | | X | | | X | X | X | | | | | @@ -126,14 +126,19 @@ Usage recommended. - Will work on nodejs by using some C FFI library from npm - Javascript side needs design - [MIT-Scheme](https://www.gnu.org/software/mit-scheme/) + - Need to study the implementation more - [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html) + - Propably does not need FFI? - [Airship](https://gitlab.com/mbabich/airship-scheme) + - Need to study the implementation more - [Other gambit targets](https://gambitscheme.org/) - Gambit compiles to different targets other than C too, for example Javascript. It would be cool and interesting to see if this FFI could also support some of those - When LIPS and Biwascheme Javascript side is done then Gambit should be done too - [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs) + - Need to study the implementation more - [prescheme](https://codeberg.org/prescheme/prescheme) + - Need to study the implementation more - [Loko](https://scheme.fail/) - Desires no C interop, I can respect that @@ -142,7 +147,7 @@ Usage recommended. ### Usage notes - Chibi - - Install libffi-dev libc-dev + - Install libffi-dev - Build with: - 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 @@ -190,16 +195,11 @@ Types are given as symbols, for example 'int8 or 'pointer. Some of these are procedures and some macros, it might also change implementation to implementation. -##### **pffi-init** [options] +##### **pffi-init** Always call this first, on most implementation it does nothing but some implementations might need initialisation run. -Options: - -- debug? - - If set to true library will output debug logs - ##### **pffi-size-of** type -> number Returns the size of the type. diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 9c18e55..e4fa951 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -64,6 +64,7 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! + pffi-struct-dereference pffi-define pffi-define-callback)) (chicken6 @@ -247,6 +248,7 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! + pffi-struct-dereference pffi-define pffi-define-callback)) (kawa @@ -341,6 +343,7 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! + pffi-struct-dereference pffi-define pffi-define-callback)) (racket diff --git a/retropikzel/r7rs-pffi/chicken5.scm b/retropikzel/r7rs-pffi/chicken5.scm index 5c8f9e8..aff207e 100644 --- a/retropikzel/r7rs-pffi/chicken5.scm +++ b/retropikzel/r7rs-pffi/chicken5.scm @@ -145,10 +145,6 @@ (lambda (pointer) (pointer->address pointer))) -(define pffi-pointer-dereference - (lambda (pointer) - (pointer->address pointer))) - (define pffi-pointer-null (lambda () (address->pointer 0))) @@ -248,3 +244,7 @@ ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) +(define pffi-struct-dereference + (lambda (struct) + (pffi-struct-pointer struct))) + diff --git a/retropikzel/r7rs-pffi/guile.scm b/retropikzel/r7rs-pffi/guile.scm index 4995190..511ac98 100644 --- a/retropikzel/r7rs-pffi/guile.scm +++ b/retropikzel/r7rs-pffi/guile.scm @@ -21,6 +21,7 @@ ((equal? type 'pointer) '*) ((equal? type 'void) void) ((equal? type 'callback) '*) + ((equal? type 'struct) '*) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-pointer? @@ -56,10 +57,6 @@ (lambda (pointer) (pointer-address pointer))) -(define pffi-pointer-dereference - (lambda (pointer) - (dereference-pointer pointer))) - (define pffi-pointer-null (lambda () (make-pointer 0))) @@ -130,3 +127,7 @@ ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))) ((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))))))) + +(define pffi-struct-dereference + (lambda (struct) + (dereference-pointer (pffi-struct-pointer struct)))) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index a2f93bf..740b4cb 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -1,26 +1,13 @@ -(define debug? #f) -(define (debug msg value) - (display "[R7RS-PFFI DEBUG] ") - (display msg) - (display ": ") - (write value) - (newline)) - (cond-expand ((or chicken5 chicken6) - (define-syntax pffi-init - (er-macro-transformer - (lambda (expr rename compare) - '(import (chicken foreign) - (chicken memory)))))) + (define-syntax pffi-init + (er-macro-transformer + (lambda (expr rename compare) + '(import (chicken foreign) + (chicken memory)))))) (else - (define (pffi-init . options) - (when (and (assoc 'debug? (car options)) - (cdr (assoc 'debug? (car options)))) - (set! debug? #t)) - #t))) - -;(when (not debug?) (set! debug (lambda (msg value) #t))) + (define pffi-init + (lambda () (+ 1 1))))) (define pffi-types '(int8 @@ -62,9 +49,6 @@ (for-each splitter str-l) res))) - -(define auto-load-versions (list "")) - (cond-expand (gambit (define-macro @@ -86,7 +70,6 @@ (cond-expand (chicken (pffi-shared-object-load headers)) (else - (debug "Options given" options) (let* ((additional-paths (if (assoc 'additional-paths options) (cadr (assoc 'additional-paths options)) (list))) @@ -149,45 +132,48 @@ "/usr/lib" "/usr/lib64" ; NetBSD - "/usr/pkg/lib" - ))))) - (auto-load-versions (list)) + "/usr/pkg/lib"))))) + (auto-load-versions (list "")) (paths (append auto-load-paths additional-paths)) (versions (append auto-load-versions additional-versions)) (platform-lib-prefix (cond-expand - (racket (if (equal? (system-type 'os) 'windows) "" "lib")) + ;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) (windows "") (else "lib"))) (platform-file-extension (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) + ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (windows ".dll") (else ".so"))) (shared-object #f)) - (debug "Auto load paths" paths) - (debug "Auto load versions" versions) (for-each (lambda (path) - (debug "Checking path" path) (for-each (lambda (version) - (let ((library-path (string-append path - slash - platform-lib-prefix - object-name - platform-file-extension - version)) - (library-path-without-suffixes (string-append path - slash - platform-lib-prefix - object-name))) - (debug "Checking if library exists in" library-path) + (let ((library-path + (string-append path + slash + platform-lib-prefix + object-name + platform-file-extension + (if (string=? version "") + "" + (string-append + (cond-expand (windows ".") ; FIXME + (else ".")) + version)))) + (library-path-without-suffixes (string-append path + slash + platform-lib-prefix + object-name))) (when (file-exists? library-path) - (debug "Library exists, setting to be loaded" library-path) - (cond-expand - (racket (set! shared-object library-path-without-suffixes)) - (else (set! shared-object library-path)))))) + (set! shared-object + (cond-expand (racket library-path-without-suffixes) + (else library-path))) + (display "Shared object is now: ") + (display shared-object) + (newline)))) versions)) paths) (if (not shared-object) diff --git a/retropikzel/r7rs-pffi/mosh.scm b/retropikzel/r7rs-pffi/mosh.scm index 6055136..c29eead 100644 --- a/retropikzel/r7rs-pffi/mosh.scm +++ b/retropikzel/r7rs-pffi/mosh.scm @@ -129,6 +129,7 @@ ((equal? type 'string) 'char*) ((equal? type 'void) 'void) ((equal? type 'callback) 'void*) + ((equal? type 'struct) 'void*) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define-syntax pffi-define @@ -147,3 +148,7 @@ (make-c-callback (pffi-type->native-type return-type) (map pffi-type->native-type argument-types) procedure))))) + +(define pffi-struct-dereference + (lambda (struct) + (pffi-struct-pointer struct))) diff --git a/test.scm b/test.scm index 2bde937..72f3c14 100644 --- a/test.scm +++ b/test.scm @@ -340,15 +340,15 @@ (define libc-stdlib (cond-expand - (windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) - (else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))) + (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) + (else (pffi-shared-object-auto-load (list "stdlib.h") "c" '((additional-versions ("0" "6"))))))) (debug libc-stdlib) (define c-testlib (cond-expand - (windows (pffi-shared-object-auto-load (list "libtest.h") (list ".") "test" (list ""))) - (else (pffi-shared-object-auto-load (list "libtest.h") (list ".") "test" (list ""))))) + (windows (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths ("."))))) + (else (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths ("."))))))) (debug c-testlib)