Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix auto-load versions and paths handling

This commit is contained in:
retropikzel 2025-01-31 18:23:57 +02:00
parent 27c2d17fd1
commit 5df5638f6b
7 changed files with 62 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
README.md
View File

@ -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-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-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-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 | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-define-callback | | 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 - Will work on nodejs by using some C FFI library from npm
- Javascript side needs design - Javascript side needs design
- [MIT-Scheme](https://www.gnu.org/software/mit-scheme/) - [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) - [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html)
- Propably does not need FFI?
- [Airship](https://gitlab.com/mbabich/airship-scheme) - [Airship](https://gitlab.com/mbabich/airship-scheme)
- Need to study the implementation more
- [Other gambit targets](https://gambitscheme.org/) - [Other gambit targets](https://gambitscheme.org/)
- Gambit compiles to different targets other than C too, for example Javascript. It would be cool - 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 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 - When LIPS and Biwascheme Javascript side is done then Gambit should be done too
- [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs) - [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs)
- Need to study the implementation more
- [prescheme](https://codeberg.org/prescheme/prescheme) - [prescheme](https://codeberg.org/prescheme/prescheme)
- Need to study the implementation more
- [Loko](https://scheme.fail/) - [Loko](https://scheme.fail/)
- Desires no C interop, I can respect that - Desires no C interop, I can respect that
@ -142,7 +147,7 @@ Usage recommended.
### Usage notes ### Usage notes
- Chibi - Chibi
- Install libffi-dev libc-dev - Install libffi-dev
- Build with: - Build with:
- chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub - 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 - ${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. 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 Always call this first, on most implementation it does nothing but some implementations might need
initialisation run. initialisation run.
Options:
- debug?
- If set to true library will output debug logs
##### **pffi-size-of** type -> number ##### **pffi-size-of** type -> number
Returns the size of the type. Returns the size of the type.

3
retropikzel/r7rs-pffi.sld
View File

@ -64,6 +64,7 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-struct-dereference
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(chicken6 (chicken6
@ -247,6 +248,7 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-struct-dereference
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(kawa (kawa
@ -341,6 +343,7 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-struct-dereference
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(racket (racket

8
retropikzel/r7rs-pffi/chicken5.scm
View File

@ -145,10 +145,6 @@
(lambda (pointer) (lambda (pointer)
(pointer->address pointer))) (pointer->address pointer)))
(define pffi-pointer-dereference
(lambda (pointer)
(pointer->address pointer)))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(address->pointer 0))) (address->pointer 0)))
@ -248,3 +244,7 @@
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
((equal? type 'pointer) (address->pointer (pointer-u64-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)))

9
retropikzel/r7rs-pffi/guile.scm
View File

@ -21,6 +21,7 @@
((equal? type 'pointer) '*) ((equal? type 'pointer) '*)
((equal? type 'void) void) ((equal? type 'void) void)
((equal? type 'callback) '*) ((equal? type 'callback) '*)
((equal? type 'struct) '*)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer? (define pffi-pointer?
@ -56,10 +57,6 @@
(lambda (pointer) (lambda (pointer)
(pointer-address pointer))) (pointer-address pointer)))
(define pffi-pointer-dereference
(lambda (pointer)
(dereference-pointer pointer)))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(make-pointer 0))) (make-pointer 0)))
@ -130,3 +127,7 @@
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) ((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 '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))))))))) ((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))))

80
retropikzel/r7rs-pffi/main.scm
View File

@ -1,26 +1,13 @@
(define debug? #f)
(define (debug msg value)
(display "[R7RS-PFFI DEBUG] ")
(display msg)
(display ": ")
(write value)
(newline))
(cond-expand (cond-expand
((or chicken5 chicken6) ((or chicken5 chicken6)
(define-syntax pffi-init (define-syntax pffi-init
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
'(import (chicken foreign) '(import (chicken foreign)
(chicken memory)))))) (chicken memory))))))
(else (else
(define (pffi-init . options) (define pffi-init
(when (and (assoc 'debug? (car options)) (lambda () (+ 1 1)))))
(cdr (assoc 'debug? (car options))))
(set! debug? #t))
#t)))
;(when (not debug?) (set! debug (lambda (msg value) #t)))
(define pffi-types (define pffi-types
'(int8 '(int8
@ -62,9 +49,6 @@
(for-each splitter str-l) (for-each splitter str-l)
res))) res)))
(define auto-load-versions (list ""))
(cond-expand (cond-expand
(gambit (gambit
(define-macro (define-macro
@ -86,7 +70,6 @@
(cond-expand (cond-expand
(chicken (pffi-shared-object-load headers)) (chicken (pffi-shared-object-load headers))
(else (else
(debug "Options given" options)
(let* ((additional-paths (if (assoc 'additional-paths options) (let* ((additional-paths (if (assoc 'additional-paths options)
(cadr (assoc 'additional-paths options)) (cadr (assoc 'additional-paths options))
(list))) (list)))
@ -149,45 +132,48 @@
"/usr/lib" "/usr/lib"
"/usr/lib64" "/usr/lib64"
; NetBSD ; NetBSD
"/usr/pkg/lib" "/usr/pkg/lib")))))
))))) (auto-load-versions (list ""))
(auto-load-versions (list))
(paths (append auto-load-paths additional-paths)) (paths (append auto-load-paths additional-paths))
(versions (append auto-load-versions additional-versions)) (versions (append auto-load-versions additional-versions))
(platform-lib-prefix (platform-lib-prefix
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) "" "lib")) ;(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(windows "") (windows "")
(else "lib"))) (else "lib")))
(platform-file-extension (platform-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(windows ".dll") (windows ".dll")
(else ".so"))) (else ".so")))
(shared-object #f)) (shared-object #f))
(debug "Auto load paths" paths)
(debug "Auto load versions" versions)
(for-each (for-each
(lambda (path) (lambda (path)
(debug "Checking path" path)
(for-each (for-each
(lambda (version) (lambda (version)
(let ((library-path (string-append path (let ((library-path
slash (string-append path
platform-lib-prefix slash
object-name platform-lib-prefix
platform-file-extension object-name
version)) platform-file-extension
(library-path-without-suffixes (string-append path (if (string=? version "")
slash ""
platform-lib-prefix (string-append
object-name))) (cond-expand (windows ".") ; FIXME
(debug "Checking if library exists in" library-path) (else "."))
version))))
(library-path-without-suffixes (string-append path
slash
platform-lib-prefix
object-name)))
(when (file-exists? library-path) (when (file-exists? library-path)
(debug "Library exists, setting to be loaded" library-path) (set! shared-object
(cond-expand (cond-expand (racket library-path-without-suffixes)
(racket (set! shared-object library-path-without-suffixes)) (else library-path)))
(else (set! shared-object library-path)))))) (display "Shared object is now: ")
(display shared-object)
(newline))))
versions)) versions))
paths) paths)
(if (not shared-object) (if (not shared-object)

5
retropikzel/r7rs-pffi/mosh.scm
View File

@ -129,6 +129,7 @@
((equal? type 'string) 'char*) ((equal? type 'string) 'char*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'void*) ((equal? type 'callback) 'void*)
((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-syntax pffi-define (define-syntax pffi-define
@ -147,3 +148,7 @@
(make-c-callback (pffi-type->native-type return-type) (make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types) (map pffi-type->native-type argument-types)
procedure))))) procedure)))))
(define pffi-struct-dereference
(lambda (struct)
(pffi-struct-pointer struct)))

8
test.scm
View File

@ -340,15 +340,15 @@
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))) (else (pffi-shared-object-auto-load (list "stdlib.h") "c" '((additional-versions ("0" "6")))))))
(debug libc-stdlib) (debug libc-stdlib)
(define c-testlib (define c-testlib
(cond-expand (cond-expand
(windows (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") (list ".") "test" (list ""))))) (else (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths (".")))))))
(debug c-testlib) (debug c-testlib)