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

Some chicken and gambit fixes

This commit is contained in:
retropikzel 2025-03-01 19:02:53 +02:00
parent 91b1cff7f6
commit d82616ef8a
2 changed files with 140 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -30,9 +30,11 @@ test-script-docker:
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . test.scm" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . test.scm"
test-compile: libtest.so libtest.a test-compile-library: libtest.so libtest.a
SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld
SCHEME=${SCHEME} compile-r7rs -I . test.scm && ./test
test-compile: test-compile-library
SCHEME=${SCHEME} CFLAGS="-I." LDFLAGS="-ltest" compile-r7rs -I . test.scm && ./test
test-compile-docker: libtest.so libtest.a test-compile-docker: libtest.so libtest.a
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}

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

@ -63,142 +63,144 @@
(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))))
((or chicken cyclone)
(define-syntax pffi-shared-object-auto-load
(syntax-rules ()
((_ headers object-name . options)
(pffi-shared-object-load headers)))))
(else (else
(define pffi-shared-object-auto-load (define pffi-shared-object-auto-load
(lambda (headers object-name . options) (lambda (headers object-name . options)
(cond-expand (let* ((additional-paths (if (assoc 'additional-paths options)
(chicken (pffi-shared-object-load headers)) (cdr (assoc 'additional-paths options))
(cyclone (pffi-shared-object-load headers)) (list)))
(else (additional-versions (if (assoc 'additional-versions options)
(let* ((additional-paths (if (assoc 'additional-paths options) (map (lambda (version)
(cdr (assoc 'additional-paths options)) (if (number? version)
(list))) (number->string version)
(additional-versions (if (assoc 'additional-versions options) version))
(map (lambda (version) (cdr (assoc 'additional-versions options)))
(if (number? version) (list)))
(number->string version) (slash (cond-expand (windows (string #\\)) (else "/")))
version)) (auto-load-paths
(cdr (assoc 'additional-versions options))) (cond-expand
(list))) (windows
(slash (cond-expand (windows (string #\\)) (else "/"))) (append
(auto-load-paths (if (get-environment-variable "SYSTEM")
(cond-expand (list (get-environment-variable "SYSTEM"))
(windows (list))
(append (if (get-environment-variable "WINDIR")
(if (get-environment-variable "SYSTEM") (list (get-environment-variable "WINDIR"))
(list (get-environment-variable "SYSTEM")) (list))
(list)) (if (get-environment-variable "WINEDLLDIR0")
(if (get-environment-variable "WINDIR") (list (get-environment-variable "WINEDLLDIR0"))
(list (get-environment-variable "WINDIR")) (list))
(list)) (if (get-environment-variable "SystemRoot")
(if (get-environment-variable "WINEDLLDIR0") (list (string-append
(list (get-environment-variable "WINEDLLDIR0")) (get-environment-variable "SystemRoot")
(list)) slash
(if (get-environment-variable "SystemRoot") "system32"))
(list (string-append (list))
(get-environment-variable "SystemRoot") (list ".")
slash (if (get-environment-variable "PATH")
"system32")) (string-split (get-environment-variable "PATH") #\;)
(list)) (list))
(list ".") (if (get-environment-variable "PWD")
(if (get-environment-variable "PATH") (list (get-environment-variable "PWD"))
(string-split (get-environment-variable "PATH") #\;) (list))))
(list)) (else
(if (get-environment-variable "PWD") (append
(list (get-environment-variable "PWD")) ; Guix
(list)))) (list (if (get-environment-variable "GUIX_ENVIRONMENT")
(else (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
(append "")
; Guix "/run/current-system/profile/lib")
(list (if (get-environment-variable "GUIX_ENVIRONMENT") ; Debian
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") (if (get-environment-variable "LD_LIBRARY_PATH")
"") (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
"/run/current-system/profile/lib") (list))
; Debian (list
(if (get-environment-variable "LD_LIBRARY_PATH") ;;; x86-64
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) ; Debian
(list)) "/lib/x86_64-linux-gnu"
(list "/usr/lib/x86_64-linux-gnu"
;;; x86-64 "/usr/local/lib"
; Debian ; Fedora/Alpine
"/lib/x86_64-linux-gnu" "/usr/lib"
"/usr/lib/x86_64-linux-gnu" "/usr/lib64"
"/usr/local/lib" ;;; aarch64
; Fedora/Alpine ; Debian
"/usr/lib" "/lib/aarch64-linux-gnu"
"/usr/lib64" "/usr/lib/aarch64-linux-gnu"
;;; aarch64 "/usr/local/lib"
; Debian ; Fedora/Alpine
"/lib/aarch64-linux-gnu" "/usr/lib"
"/usr/lib/aarch64-linux-gnu" "/usr/lib64"
"/usr/local/lib" ; NetBSD
; Fedora/Alpine "/usr/pkg/lib")))))
"/usr/lib" (auto-load-versions (list ""))
"/usr/lib64" (paths (append auto-load-paths additional-paths))
; NetBSD (versions (append additional-versions auto-load-versions))
"/usr/pkg/lib"))))) (platform-lib-prefix
(auto-load-versions (list "")) (cond-expand
(paths (append auto-load-paths additional-paths)) ;(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(versions (append additional-versions auto-load-versions)) (windows "")
(platform-lib-prefix (else "lib")))
(cond-expand (platform-file-extension
;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) (cond-expand
(windows "") ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(else "lib"))) (windows ".dll")
(platform-file-extension (else ".so")))
(cond-expand (shared-object #f)
;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (searched-paths (list)))
(windows ".dll") (for-each
(else ".so"))) (lambda (path)
(shared-object #f)
(searched-paths (list)))
(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)))))))))))