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

Renaming, interface fixes

This commit is contained in:
retropikzel 2025-02-23 10:35:25 +02:00
parent 815e49906f
commit f9517baf5b
5 changed files with 155 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
README.md
View File

@ -221,7 +221,7 @@ Takes as argument a list of C headers, these are for the compiler ones. And an s
used by the dynamic FFI's. The name of the shared object should not contain suffix like .so or used by the dynamic FFI's. The name of the shared object should not contain suffix like .so or
.dll. Nor should it contain any prefix like "lib". .dll. Nor should it contain any prefix like "lib".
Additional options argument can be provided, which should be a list of lists starting with a Additional options argument can be provided, theys should be a pair with a
keyword. The options are: keyword. The options are:
- additional-versions - additional-versions
@ -236,7 +236,11 @@ Example:
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h") "c" '((additional-versions ("6"))))))) (else (pffi-shared-object-auto-load (list "stdlib.h")
"c"
'(additional-versions . ("6"))
'(additional-search-paths . ("."))))))
##### **pffi-shared-object-load** headers path [options] ##### **pffi-shared-object-load** headers path [options]

2
retropikzel/r7rs-pffi.rkt → retropikzel/pffi.rkt
View File

@ -1,3 +1,3 @@
#lang r7rs #lang r7rs
(import (scheme base)) (import (scheme base))
(include "r7rs-pffi.sld") (include "pffi.sld")

2
retropikzel/r7rs-pffi.sld → retropikzel/pffi.sld
View File

@ -1,5 +1,5 @@
(define-library (define-library
(retropikzel r7rs-pffi) (retropikzel pffi)
(cond-expand (cond-expand
(chibi (chibi
(import (scheme base) (import (scheme base)

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

@ -63,151 +63,142 @@
(cond-expand (cond-expand
(gambit (gambit
(define-macro (define-macro
(pffi-shared-object-auto-load headers object-name options) (pffi-shared-object-auto-load headers object-name . options)
`(pffi-shared-object-load ,(car headers)))) `(pffi-shared-object-load ,(car headers))))
(cyclone
(define-syntax pffi-shared-object-auto-load
(syntax-rules ()
((pffi-shared-object-auto-load headers object-name)
(pffi-shared-object-auto-load headers object-name (list)))
((pffi-shared-object-auto-load headers object-name options)
(pffi-shared-object-load headers)))))
(else (else
(define-syntax pffi-shared-object-auto-load (define pffi-shared-object-auto-load
(syntax-rules () (lambda (headers object-name . options)
((pffi-shared-object-auto-load headers object-name) (cond-expand
(pffi-shared-object-auto-load headers object-name (list))) (chicken (pffi-shared-object-load headers))
((pffi-shared-object-auto-load headers object-name options) (cyclone (pffi-shared-object-load headers))
(cond-expand (else
(chicken (pffi-shared-object-load headers)) (let* ((additional-paths (if (assoc 'additional-paths options)
(else (cdr (assoc 'additional-paths options))
(let* ((additional-paths (if (assoc 'additional-paths options) (list)))
(cadr (assoc 'additional-paths options)) (additional-versions (if (assoc 'additional-versions options)
(list))) (map (lambda (version)
(additional-versions (if (assoc 'additional-versions options) (if (number? version)
(map (lambda (version) (number->string version)
(if (number? version) version))
(number->string version) (cdr (assoc 'additional-versions options)))
version)) (list)))
(cadr (assoc 'additional-versions options))) (slash (cond-expand (windows (string #\\)) (else "/")))
(list))) (auto-load-paths
(slash (cond-expand (windows (string #\\)) (else "/"))) (cond-expand
(auto-load-paths (windows
(cond-expand (append
(windows (if (get-environment-variable "SYSTEM")
(append (list (get-environment-variable "SYSTEM"))
(if (get-environment-variable "SYSTEM") (list))
(list (get-environment-variable "SYSTEM")) (if (get-environment-variable "WINDIR")
(list)) (list (get-environment-variable "WINDIR"))
(if (get-environment-variable "WINDIR") (list))
(list (get-environment-variable "WINDIR")) (if (get-environment-variable "WINEDLLDIR0")
(list)) (list (get-environment-variable "WINEDLLDIR0"))
(if (get-environment-variable "WINEDLLDIR0") (list))
(list (get-environment-variable "WINEDLLDIR0")) (if (get-environment-variable "SystemRoot")
(list)) (list (string-append
(if (get-environment-variable "SystemRoot") (get-environment-variable "SystemRoot")
(list (string-append slash
(get-environment-variable "SystemRoot") "system32"))
slash (list))
"system32")) (list ".")
(list)) (if (get-environment-variable "PATH")
(list ".") (string-split (get-environment-variable "PATH") #\;)
(if (get-environment-variable "PATH") (list))
(string-split (get-environment-variable "PATH") #\;) (if (get-environment-variable "PWD")
(list)) (list (get-environment-variable "PWD"))
(if (get-environment-variable "PWD") (list))))
(list (get-environment-variable "PWD")) (else
(list)))) (append
(else ; Guix
(append (list (if (get-environment-variable "GUIX_ENVIRONMENT")
; Guix (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
(list (if (get-environment-variable "GUIX_ENVIRONMENT") "")
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") "/run/current-system/profile/lib")
"") ; Debian
"/run/current-system/profile/lib") (if (get-environment-variable "LD_LIBRARY_PATH")
; Debian (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(if (get-environment-variable "LD_LIBRARY_PATH") (list))
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) (list
(list)) ;;; x86-64
(list ; Debian
;;; x86-64 "/lib/x86_64-linux-gnu"
; Debian "/usr/lib/x86_64-linux-gnu"
"/lib/x86_64-linux-gnu" "/usr/local/lib"
"/usr/lib/x86_64-linux-gnu" ; Fedora/Alpine
"/usr/local/lib" "/usr/lib"
; Fedora/Alpine "/usr/lib64"
"/usr/lib" ;;; aarch64
"/usr/lib64" ; Debian
;;; aarch64 "/lib/aarch64-linux-gnu"
; Debian "/usr/lib/aarch64-linux-gnu"
"/lib/aarch64-linux-gnu" "/usr/local/lib"
"/usr/lib/aarch64-linux-gnu" ; Fedora/Alpine
"/usr/local/lib" "/usr/lib"
; Fedora/Alpine "/usr/lib64"
"/usr/lib" ; NetBSD
"/usr/lib64" "/usr/pkg/lib")))))
; NetBSD (auto-load-versions (list ""))
"/usr/pkg/lib"))))) (paths (append auto-load-paths additional-paths))
(auto-load-versions (list "")) (versions (append additional-versions auto-load-versions))
(paths (append auto-load-paths additional-paths)) (platform-lib-prefix
(versions (append additional-versions auto-load-versions)) (cond-expand
(platform-lib-prefix ;(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(cond-expand (windows "")
;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) (else "lib")))
(windows "") (platform-file-extension
(else "lib"))) (cond-expand
(platform-file-extension ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(cond-expand (windows ".dll")
;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (else ".so")))
(windows ".dll") (shared-object #f)
(else ".so"))) (searched-paths (list)))
(shared-object #f) (for-each
(searched-paths (list))) (lambda (path)
(for-each (for-each
(lambda (path) (lambda (version)
(for-each (let ((library-path
(lambda (version) (string-append path
(let ((library-path slash
(string-append path platform-lib-prefix
slash object-name
platform-lib-prefix (cond-expand
object-name (windows "")
(cond-expand (else platform-file-extension))
(windows "") (if (string=? version "")
(else platform-file-extension)) ""
(if (string=? version "") (string-append
"" (cond-expand (windows "-")
(string-append (else "."))
(cond-expand (windows "-") version))
(else ".")) (cond-expand
version)) (windows platform-file-extension)
(cond-expand (else ""))))
(windows platform-file-extension) (library-path-without-suffixes (string-append path
(else "")))) slash
(library-path-without-suffixes (string-append path platform-lib-prefix
slash object-name)))
platform-lib-prefix (set! searched-paths (append searched-paths (list library-path)))
object-name))) (when (and (not shared-object)
(set! searched-paths (append searched-paths (list library-path))) (file-exists? library-path))
(when (and (not shared-object) (set! shared-object
(file-exists? library-path)) (cond-expand (racket library-path-without-suffixes)
(set! shared-object (else library-path))))))
(cond-expand (racket library-path-without-suffixes) versions))
(else library-path)))))) paths)
versions)) (if (not shared-object)
paths) (begin
(if (not shared-object) (display "Could not load shared object: ")
(begin (write (list (cons 'object object-name)
(display "Could not load shared object: ") (cons 'paths paths)
(write (list (cons 'object object-name) (cons 'platform-file-extension platform-file-extension)
(cons 'paths paths) (cons 'versions versions)))
(cons 'platform-file-extension platform-file-extension) (newline)
(cons 'versions versions))) (display "Searched paths: ")
(newline) (write searched-paths)
(display "Searched paths: ") (newline)
(write searched-paths) (exit 1))
(newline) (pffi-shared-object-load headers
(exit 1)) shared-object
(pffi-shared-object-load headers `((additional-versions ,versions)))))))))))
shared-object
`((additional-versions ,versions))))))))))))

14
test.scm
View File

@ -2,7 +2,7 @@
(scheme write) (scheme write)
(scheme char) (scheme char)
(scheme process-context) (scheme process-context)
(retropikzel r7rs-pffi)) (retropikzel pffi))
(define header-count 1) (define header-count 1)
@ -392,14 +392,20 @@
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h") "c" '((additional-versions ("0" "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") "test" '((additional-paths ("."))))) (windows (pffi-shared-object-auto-load (list "libtest.h")
(else (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths ("."))))))) "test"
'(additional-paths . ("."))))
(else (pffi-shared-object-auto-load (list "libtest.h")
"test"
'(additional-paths . ("."))))))
(debug c-testlib) (debug c-testlib)