diff --git a/Makefile b/Makefile index 0ccd4d3..ed4516d 100644 --- a/Makefile +++ b/Makefile @@ -59,7 +59,7 @@ test-compile-library: tests/libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld 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 test-compiler-compliance: test-compiler-compliance-compile diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index bf677f1..c334a81 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -13,7 +13,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -49,7 +49,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -82,7 +82,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -111,7 +111,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -171,7 +171,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -200,7 +200,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -231,7 +231,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -259,7 +259,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -294,7 +294,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -323,7 +323,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -356,7 +356,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -386,7 +386,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -414,7 +414,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -443,7 +443,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -472,7 +472,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-shared-object-load ;pffi-pointer-null ;pffi-pointer-null? @@ -501,7 +501,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index e4c837d..8f6b6ed 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -79,9 +79,11 @@ (string-copy (cast pointer _pointer _string)))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (header path options) + (write options) + (newline) (if (and (not (null? options)) - (assoc 'additional-versions (car options))) + (assoc 'additional-versions options)) (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions (car options))) (list #f)))) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index cd35e9c..de726ac 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -32,7 +32,7 @@ (define-syntax pffi-define (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 (make-c-function shared-object (pffi-type->native-type return-type) @@ -102,7 +102,7 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (headers path . options) + (lambda (headers path options) (open-shared-library path))) (define pffi-pointer-free diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 00f772d..2729f35 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -91,138 +91,149 @@ ((or chicken cyclone) (define-syntax pffi-define-library (syntax-rules () - ((_ headers object-name . options) - (pffi-shared-object-load headers))))) + ((_ scheme-name headers object-name . options) + (begin + (define scheme-name #t) + (pffi-shared-object-load headers)))))) (else - (define pffi-define-library - (lambda (headers object-name . options) - (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))) + (define-syntax pffi-define-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name #t)))) + #;(define-syntax pffi-define-library-old + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name + (let* ((additional-paths (if (assoc 'additional-paths options) + (cdr (assoc 'additional-paths 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))))))))) + (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))) + (display "HERE: ") + (write additional-versions) + (newline) + (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/tests/compliance.scm b/tests/compliance.scm index 6e3cdac..a7575ec 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -406,20 +406,20 @@ (pffi-define-library libc-stdlib (list "stdlib.h") (cond-expand (windows "ucrtbase") (else "c")) - '(additional-versions . ("0" "6"))) + '((additional-versions . ("0" "6")))) (debug libc-stdlib) (pffi-define-library libc-stdio (list "stdio.h") (cond-expand (windows "ucrtbase") (else "c")) - '(additional-versions . ("0" "6"))) + '((additional-versions . ("0" "6")))) (debug libc-stdio) (pffi-define-library c-testlib (list "libtest.h") "test" - '(additional-paths . ("."))) + '((additional-paths . (".")))) (debug c-testlib)