diff --git a/README.md b/README.md index e61085e..7a2b5c6 100644 --- a/README.md +++ b/README.md @@ -38,25 +38,25 @@ guarantees are being made just yet. ## Implementation table -| | Chibi | Chicken | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon | -| ------------------------------- | ----- | ------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- | -| pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | -| pffi-size-of | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-pointer->string | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-define | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-define-callback | | X | | | | | X | | | X | X | X | | | | | -| pffi-pointer-address | | X | | | | | X | | | | X | X | | | | | -| pffi-pointer-dereference | | | | | | | X | | | | X | X | | | | | +| | Chibi | Chicken 5 | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon | +| ------------------------------- | ----- | --------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- | +| pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | +| pffi-size-of | X | X | X | X | | | X | X | | X | X | X | | X | | | +| pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | | +| pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | | +| pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | | +| pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | | +| pffi-pointer->string | X | X | X | | | | X | X | | X | X | X | | | | | +| pffi-define | X | X | X | | | | X | X | | X | X | X | | | | | +| pffi-define-callback | | X | | | | | X | | | X | X | X | | | | | +| pffi-pointer-address | | X | | | | | X | | | | X | X | | | | | +| pffi-pointer-dereference | | | | | | | X | | | | X | X | | | | | ### Usage notes diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index da50bbf..7b81d60 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -91,9 +91,9 @@ (scheme process-context) (only (gambit) c-declare c-lambda c-define)) (export pffi-init - ;pffi-size-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index e5e8994..c999e2d 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -42,104 +42,109 @@ (define auto-load-versions (list "")) -(define-syntax pffi-shared-object-auto-load - (syntax-rules () - ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) - (cond-expand - (cyclone (pffi-shared-object-load headers)) - (chicken (pffi-shared-object-load headers)) - (gambit (pffi-shared-object-load headers)) - (else - (let* ((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 auto-load-versions additional-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)) - (for-each - (lambda (path) +(cond-expand + (gambit + (define-macro + (pffi-shared-object-auto-load headers additional-paths object-name additional-versions) + `(pffi-shared-object-load ,(car headers)))) + (else + (define-syntax pffi-shared-object-auto-load + (syntax-rules () + ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) + (cond-expand + (cyclone (pffi-shared-object-load headers)) + (chicken (pffi-shared-object-load headers)) + (else + (let* ((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 auto-load-versions additional-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)) (for-each - (lambda (version) - (let ((library-path (string-append path - slash - platform-lib-prefix - object-name - platform-file-extension - version))) - (if (file-exists? library-path) - (set! shared-object library-path)))) - versions)) - paths) - (if (not shared-object) - (error "Could not load shared object" - (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (pffi-shared-object-load headers shared-object)))))))) + (lambda (path) + (for-each + (lambda (version) + (let ((library-path (string-append path + slash + platform-lib-prefix + object-name + platform-file-extension + version))) + (if (file-exists? library-path) + (set! shared-object library-path)))) + versions)) + paths) + (if (not shared-object) + (error "Could not load shared object" + (list (cons 'object object-name) + (cons 'paths paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (pffi-shared-object-load headers shared-object)))))))))) diff --git a/test.scm b/test.scm index a9d9383..331c6af 100644 --- a/test.scm +++ b/test.scm @@ -53,7 +53,6 @@ (pffi-init) -#| ;; pffi-size-of (print-header 'pffi-size-of) @@ -203,6 +202,7 @@ (debug libc-stdlib) +#| ;; pffi-pointer-null (print-header 'pffi-pointer-null)