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

Move chicken to pffi-define-library

This commit is contained in:
retropikzel 2025-03-22 17:39:54 +02:00
parent 27cc998f35
commit 993588e286
6 changed files with 170 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -59,7 +59,7 @@ test-compile-library: tests/libtest.so libtest.a libtest.o
SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld
test-compiler-compliance-compile: test-compile-library test-compiler-compliance-compile: test-compile-library
SCHEME=${SCHEME} CFLAGS="-I../include -L.." LDFLAGS="-ltest" compile-r7rs -I . tests/compliance.scm SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest -L." compile-r7rs -I . tests/compliance.scm
./tests/compliance ./tests/compliance
test-compiler-compliance: test-compiler-compliance-compile test-compiler-compliance: test-compiler-compliance-compile

32
retropikzel/pffi.sld
View File

@ -13,7 +13,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -49,7 +49,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -82,7 +82,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -111,7 +111,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -171,7 +171,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -200,7 +200,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-load ;pffi-define-library
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -231,7 +231,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -259,7 +259,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -294,7 +294,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-load ;pffi-define-library
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -323,7 +323,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -356,7 +356,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -386,7 +386,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -414,7 +414,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-load ;pffi-define-library
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -443,7 +443,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-load pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -472,7 +472,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-load ;pffi-define-library
;pffi-shared-object-load ;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
@ -501,7 +501,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-load ;pffi-define-library
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate

6
retropikzel/pffi/racket.scm
View File

@ -79,9 +79,11 @@
(string-copy (cast pointer _pointer _string)))) (string-copy (cast pointer _pointer _string))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (header path . options) (lambda (header path options)
(write options)
(newline)
(if (and (not (null? options)) (if (and (not (null? options))
(assoc 'additional-versions (car options))) (assoc 'additional-versions options))
(ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
(car options))) (car options)))
(list #f)))) (list #f))))

4
retropikzel/pffi/sagittarius.scm
View File

@ -32,7 +32,7 @@
(define-syntax pffi-define (define-syntax pffi-define
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(pffi-type->native-type return-type) (pffi-type->native-type return-type)
@ -102,7 +102,7 @@
(pointer->string pointer))) (pointer->string pointer)))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (headers path . options) (lambda (headers path options)
(open-shared-library path))) (open-shared-library path)))
(define pffi-pointer-free (define pffi-pointer-free

277
retropikzel/pffi/shared/main.scm
View File

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

6
tests/compliance.scm
View File

@ -406,20 +406,20 @@
(pffi-define-library libc-stdlib (pffi-define-library libc-stdlib
(list "stdlib.h") (list "stdlib.h")
(cond-expand (windows "ucrtbase") (else "c")) (cond-expand (windows "ucrtbase") (else "c"))
'(additional-versions . ("0" "6"))) '((additional-versions . ("0" "6"))))
(debug libc-stdlib) (debug libc-stdlib)
(pffi-define-library libc-stdio (pffi-define-library libc-stdio
(list "stdio.h") (list "stdio.h")
(cond-expand (windows "ucrtbase") (else "c")) (cond-expand (windows "ucrtbase") (else "c"))
'(additional-versions . ("0" "6"))) '((additional-versions . ("0" "6"))))
(debug libc-stdio) (debug libc-stdio)
(pffi-define-library c-testlib (pffi-define-library c-testlib
(list "libtest.h") (list "libtest.h")
"test" "test"
'(additional-paths . ("."))) '((additional-paths . ("."))))
(debug c-testlib) (debug c-testlib)