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

Backup

This commit is contained in:
retropikzel 2024-11-15 08:17:20 +02:00
parent 20a05a5dc0
commit bbd51e93e1
4 changed files with 128 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
README.md
View File

@ -38,25 +38,25 @@ guarantees are being made just yet.
## Implementation table ## Implementation table
| | Chibi | Chicken | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon | | | Chibi | Chicken 5 | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon |
| ------------------------------- | ----- | ------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- | | ------------------------------- | ----- | --------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- |
| pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | | pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | |
| pffi-size-of | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-size-of | X | X | X | X | | | X | X | | X | X | X | | X | | |
| pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | | | pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | | | pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | | | pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | | | pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-pointer->string | X | X | X | | | | X | X | | X | X | X | | | | | | pffi-pointer->string | X | X | X | | | | 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 | | | | |
| pffi-pointer-address | | X | | | | | X | | | | X | X | | | | | | pffi-pointer-address | | X | | | | | X | | | | X | X | | | | |
| pffi-pointer-dereference | | | | | | | X | | | | X | X | | | | | | pffi-pointer-dereference | | | | | | | X | | | | X | X | | | | |
### Usage notes ### Usage notes

6
retropikzel/r7rs-pffi.sld
View File

@ -91,9 +91,9 @@
(scheme process-context) (scheme process-context)
(only (gambit) c-declare c-lambda c-define)) (only (gambit) c-declare c-lambda c-define))
(export pffi-init (export pffi-init
;pffi-size-of pffi-size-of
;pffi-shared-object-auto-load pffi-shared-object-auto-load
;pffi-shared-object-load pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate

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

@ -42,104 +42,109 @@
(define auto-load-versions (list "")) (define auto-load-versions (list ""))
(define-syntax pffi-shared-object-auto-load (cond-expand
(syntax-rules () (gambit
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) (define-macro
(cond-expand (pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
(cyclone (pffi-shared-object-load headers)) `(pffi-shared-object-load ,(car headers))))
(chicken (pffi-shared-object-load headers)) (else
(gambit (pffi-shared-object-load headers)) (define-syntax pffi-shared-object-auto-load
(else (syntax-rules ()
(let* ((slash (cond-expand (windows (string #\\)) (else "/"))) ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
(auto-load-paths (cond-expand
(cond-expand (cyclone (pffi-shared-object-load headers))
(windows (chicken (pffi-shared-object-load headers))
(append (else
(if (get-environment-variable "SYSTEM") (let* ((slash (cond-expand (windows (string #\\)) (else "/")))
(list (get-environment-variable "SYSTEM")) (auto-load-paths
(list)) (cond-expand
(if (get-environment-variable "WINDIR") (windows
(list (get-environment-variable "WINDIR")) (append
(list)) (if (get-environment-variable "SYSTEM")
(if (get-environment-variable "WINEDLLDIR0") (list (get-environment-variable "SYSTEM"))
(list (get-environment-variable "WINEDLLDIR0")) (list))
(list)) (if (get-environment-variable "WINDIR")
(if (get-environment-variable "SystemRoot") (list (get-environment-variable "WINDIR"))
(list (string-append (list))
(get-environment-variable "SystemRoot") (if (get-environment-variable "WINEDLLDIR0")
slash (list (get-environment-variable "WINEDLLDIR0"))
"system32")) (list))
(list)) (if (get-environment-variable "SystemRoot")
(list ".") (list (string-append
(if (get-environment-variable "PATH") (get-environment-variable "SystemRoot")
(string-split (get-environment-variable "PATH") #\;) slash
(list)) "system32"))
(if (get-environment-variable "PWD") (list))
(list (get-environment-variable "PWD")) (list ".")
(list)))) (if (get-environment-variable "PATH")
(else (string-split (get-environment-variable "PATH") #\;)
(append (list))
; Guix (if (get-environment-variable "PWD")
(list (if (get-environment-variable "GUIX_ENVIRONMENT") (list (get-environment-variable "PWD"))
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") (list))))
"") (else
"/run/current-system/profile/lib") (append
; Debian ; Guix
(if (get-environment-variable "LD_LIBRARY_PATH") (list (if (get-environment-variable "GUIX_ENVIRONMENT")
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
(list)) "")
(list "/run/current-system/profile/lib")
;;; x86-64 ; Debian
; Debian (if (get-environment-variable "LD_LIBRARY_PATH")
"/lib/x86_64-linux-gnu" (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
"/usr/lib/x86_64-linux-gnu" (list))
"/usr/local/lib" (list
; Fedora/Alpine ;;; x86-64
"/usr/lib" ; Debian
"/usr/lib64" "/lib/x86_64-linux-gnu"
;;; aarch64 "/usr/lib/x86_64-linux-gnu"
; Debian "/usr/local/lib"
"/lib/aarch64-linux-gnu" ; Fedora/Alpine
"/usr/lib/aarch64-linux-gnu" "/usr/lib"
"/usr/local/lib" "/usr/lib64"
; Fedora/Alpine ;;; aarch64
"/usr/lib" ; Debian
"/usr/lib64" "/lib/aarch64-linux-gnu"
; NetBSD "/usr/lib/aarch64-linux-gnu"
"/usr/pkg/lib" "/usr/local/lib"
))))) ; Fedora/Alpine
(auto-load-versions (list)) "/usr/lib"
(paths (append auto-load-paths additional-paths)) "/usr/lib64"
(versions (append auto-load-versions additional-versions)) ; NetBSD
(platform-lib-prefix "/usr/pkg/lib"
(cond-expand )))))
(racket (if (equal? (system-type 'os) 'windows) "" "lib")) (auto-load-versions (list))
(windows "") (paths (append auto-load-paths additional-paths))
(else "lib"))) (versions (append auto-load-versions additional-versions))
(platform-file-extension (platform-lib-prefix
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(windows ".dll") (windows "")
(else ".so"))) (else "lib")))
(shared-object #f)) (platform-file-extension
(for-each (cond-expand
(lambda (path) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(windows ".dll")
(else ".so")))
(shared-object #f))
(for-each (for-each
(lambda (version) (lambda (path)
(let ((library-path (string-append path (for-each
slash (lambda (version)
platform-lib-prefix (let ((library-path (string-append path
object-name slash
platform-file-extension platform-lib-prefix
version))) object-name
(if (file-exists? library-path) platform-file-extension
(set! shared-object library-path)))) version)))
versions)) (if (file-exists? library-path)
paths) (set! shared-object library-path))))
(if (not shared-object) versions))
(error "Could not load shared object" paths)
(list (cons 'object object-name) (if (not shared-object)
(cons 'paths paths) (error "Could not load shared object"
(cons 'platform-file-extension platform-file-extension) (list (cons 'object object-name)
(cons 'versions versions))) (cons 'paths paths)
(pffi-shared-object-load headers shared-object)))))))) (cons 'platform-file-extension platform-file-extension)
(cons 'versions versions)))
(pffi-shared-object-load headers shared-object))))))))))

2
test.scm
View File

@ -53,7 +53,6 @@
(pffi-init) (pffi-init)
#|
;; pffi-size-of ;; pffi-size-of
(print-header 'pffi-size-of) (print-header 'pffi-size-of)
@ -203,6 +202,7 @@
(debug libc-stdlib) (debug libc-stdlib)
#|
;; pffi-pointer-null ;; pffi-pointer-null
(print-header 'pffi-pointer-null) (print-header 'pffi-pointer-null)