From f9517baf5bb7373f8174a08abdf370d848a30b88 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 23 Feb 2025 10:35:25 +0200 Subject: [PATCH] Renaming, interface fixes --- README.md | 8 +- retropikzel/{r7rs-pffi.rkt => pffi.rkt} | 2 +- retropikzel/{r7rs-pffi.sld => pffi.sld} | 2 +- retropikzel/r7rs-pffi/main.scm | 283 ++++++++++++------------ test.scm | 14 +- 5 files changed, 155 insertions(+), 154 deletions(-) rename retropikzel/{r7rs-pffi.rkt => pffi.rkt} (56%) rename retropikzel/{r7rs-pffi.sld => pffi.sld} (99%) diff --git a/README.md b/README.md index 8a37ee6..2e80acf 100644 --- a/README.md +++ b/README.md @@ -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 .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: - additional-versions @@ -236,7 +236,11 @@ Example: (define libc-stdlib (cond-expand (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] diff --git a/retropikzel/r7rs-pffi.rkt b/retropikzel/pffi.rkt similarity index 56% rename from retropikzel/r7rs-pffi.rkt rename to retropikzel/pffi.rkt index da0f2d3..4498eda 100644 --- a/retropikzel/r7rs-pffi.rkt +++ b/retropikzel/pffi.rkt @@ -1,3 +1,3 @@ #lang r7rs (import (scheme base)) -(include "r7rs-pffi.sld") +(include "pffi.sld") diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/pffi.sld similarity index 99% rename from retropikzel/r7rs-pffi.sld rename to retropikzel/pffi.sld index 418772d..5088984 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/pffi.sld @@ -1,5 +1,5 @@ (define-library - (retropikzel r7rs-pffi) + (retropikzel pffi) (cond-expand (chibi (import (scheme base) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index aee8d4e..88a4281 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -63,151 +63,142 @@ (cond-expand (gambit (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)))) - (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 - (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) - (cond-expand - (chicken (pffi-shared-object-load headers)) - (else - (let* ((additional-paths (if (assoc 'additional-paths options) - (cadr (assoc 'additional-paths options)) - (list))) - (additional-versions (if (assoc 'additional-versions options) - (map (lambda (version) - (if (number? version) - (number->string version) - version)) - (cadr (assoc 'additional-versions options))) - (list))) - (slash (cond-expand (windows (string #\\)) (else "/"))) - (auto-load-paths - (cond-expand - (windows - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) - (list)) - (if (get-environment-variable "PWD") - (list (get-environment-variable "PWD")) - (list)))) - (else - (append - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ; NetBSD - "/usr/pkg/lib"))))) - (auto-load-versions (list "")) - (paths (append auto-load-paths additional-paths)) - (versions (append additional-versions auto-load-versions)) - (platform-lib-prefix - (cond-expand - ;(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")) - (windows ".dll") - (else ".so"))) - (shared-object #f) - (searched-paths (list))) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path - (string-append path - slash - platform-lib-prefix - object-name - (cond-expand - (windows "") - (else platform-file-extension)) - (if (string=? version "") - "" - (string-append - (cond-expand (windows "-") - (else ".")) - version)) - (cond-expand - (windows platform-file-extension) - (else "")))) - (library-path-without-suffixes (string-append path - slash - platform-lib-prefix - object-name))) - (set! searched-paths (append searched-paths (list library-path))) - (when (and (not shared-object) - (file-exists? library-path)) - (set! shared-object - (cond-expand (racket library-path-without-suffixes) - (else library-path)))))) - versions)) - paths) - (if (not shared-object) - (begin - (display "Could not load shared object: ") - (write (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (newline) - (display "Searched paths: ") - (write searched-paths) - (newline) - (exit 1)) - (pffi-shared-object-load headers - shared-object - `((additional-versions ,versions)))))))))))) + (define pffi-shared-object-auto-load + (lambda (headers object-name . options) + (cond-expand + (chicken (pffi-shared-object-load headers)) + (cyclone (pffi-shared-object-load headers)) + (else + (let* ((additional-paths (if (assoc 'additional-paths options) + (cdr (assoc 'additional-paths options)) + (list))) + (additional-versions (if (assoc 'additional-versions options) + (map (lambda (version) + (if (number? version) + (number->string version) + version)) + (cdr (assoc 'additional-versions options))) + (list))) + (slash (cond-expand (windows (string #\\)) (else "/"))) + (auto-load-paths + (cond-expand + (windows + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (if (get-environment-variable "WINEDLLDIR0") + (list (get-environment-variable "WINEDLLDIR0")) + (list)) + (if (get-environment-variable "SystemRoot") + (list (string-append + (get-environment-variable "SystemRoot") + slash + "system32")) + (list)) + (list ".") + (if (get-environment-variable "PATH") + (string-split (get-environment-variable "PATH") #\;) + (list)) + (if (get-environment-variable "PWD") + (list (get-environment-variable "PWD")) + (list)))) + (else + (append + ; Guix + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") + "") + "/run/current-system/profile/lib") + ; Debian + (if (get-environment-variable "LD_LIBRARY_PATH") + (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) + (list)) + (list + ;;; x86-64 + ; Debian + "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ;;; aarch64 + ; Debian + "/lib/aarch64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ; NetBSD + "/usr/pkg/lib"))))) + (auto-load-versions (list "")) + (paths (append auto-load-paths additional-paths)) + (versions (append additional-versions auto-load-versions)) + (platform-lib-prefix + (cond-expand + ;(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")) + (windows ".dll") + (else ".so"))) + (shared-object #f) + (searched-paths (list))) + (for-each + (lambda (path) + (for-each + (lambda (version) + (let ((library-path + (string-append path + slash + platform-lib-prefix + object-name + (cond-expand + (windows "") + (else platform-file-extension)) + (if (string=? version "") + "" + (string-append + (cond-expand (windows "-") + (else ".")) + version)) + (cond-expand + (windows platform-file-extension) + (else "")))) + (library-path-without-suffixes (string-append path + slash + platform-lib-prefix + object-name))) + (set! searched-paths (append searched-paths (list library-path))) + (when (and (not shared-object) + (file-exists? library-path)) + (set! shared-object + (cond-expand (racket library-path-without-suffixes) + (else library-path)))))) + versions)) + paths) + (if (not shared-object) + (begin + (display "Could not load shared object: ") + (write (list (cons 'object object-name) + (cons 'paths paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (newline) + (display "Searched paths: ") + (write searched-paths) + (newline) + (exit 1)) + (pffi-shared-object-load headers + shared-object + `((additional-versions ,versions))))))))))) diff --git a/test.scm b/test.scm index 384c169..e5228b0 100755 --- a/test.scm +++ b/test.scm @@ -2,7 +2,7 @@ (scheme write) (scheme char) (scheme process-context) - (retropikzel r7rs-pffi)) + (retropikzel pffi)) (define header-count 1) @@ -392,14 +392,20 @@ (define libc-stdlib (cond-expand (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) (define c-testlib (cond-expand - (windows (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths ("."))))) - (else (pffi-shared-object-auto-load (list "libtest.h") "test" '((additional-paths ("."))))))) + (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)