From e32a2f2194a3b7d9d9220a662b69cb92d6b70989 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 24 May 2024 08:30:24 +0300 Subject: [PATCH] - Added versions to auto-load - Fixed some bugs in chicken pffi-pointer-null? - Moved some tests to that test-all.sh now tests only supported implementations --- README.md | 11 ++++- guix-chicken-init.sh | 4 +- test-stklos.sh => in-progress-stklos.sh | 0 ...-cyclone.sh => in-progress-test-cyclone.sh | 0 test-gambit.sh => in-progress-test-gambit.sh | 0 test-gerbil.sh => in-progress-test-gerbil.sh | 0 retropikzel/pffi/v0-1-0/chicken.scm | 3 +- retropikzel/pffi/v0-1-0/kawa.scm | 1 + retropikzel/pffi/v0-1-0/main.scm | 40 +++++++++++++++---- retropikzel/pffi/v0-1-0/main.sld | 40 +++++++++++++++---- scripts/init-test.sh | 2 + scripts/test-runs-compilers.sh | 4 +- scripts/test-runs-dynamic.sh | 4 +- test-all.sh | 1 - test/600_pffi-define.scm | 5 ++- test/600_string-to_pointer_to_string.scm | 17 -------- 16 files changed, 92 insertions(+), 40 deletions(-) rename test-stklos.sh => in-progress-stklos.sh (100%) rename test-cyclone.sh => in-progress-test-cyclone.sh (100%) rename test-gambit.sh => in-progress-test-gambit.sh (100%) rename test-gerbil.sh => in-progress-test-gerbil.sh (100%) delete mode 100644 test/600_string-to_pointer_to_string.scm diff --git a/README.md b/README.md index ca8f5be..f98f5d7 100644 --- a/README.md +++ b/README.md @@ -20,7 +20,6 @@ Pull requests to fix bugs and add more tests are welcome. - Compiling of C code at any point - That is no stubs, no C code generated by the library and so on - For bugs you can use the [Bugs](https://codeberg.org/r7rs-pffi/pffi/projects/9101) @@ -99,10 +98,18 @@ Types are given as symbols, for example 'int8 or 'pointer. Arguments: +- headers (list (string) ...) + - C headers of the library + - For example (list "curl/curl.h") - object-name (symbol) - - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end + - The name of the dynamic library file you want to load + - Without the "lib" in front of it + - Without the ".so" or ".dll" at the end +- addition-versions (list (string)...) + - For example (list ".0" ".1") - addition-paths (list (string)...) - Any additional paths you want to search for the library + - For example (list "./mylibs") Returns: diff --git a/guix-chicken-init.sh b/guix-chicken-init.sh index f97b26a..b1d7f4c 100644 --- a/guix-chicken-init.sh +++ b/guix-chicken-init.sh @@ -1,7 +1,7 @@ #!/usr/bin/env bash export CHICKEN_INSTALL_REPOSITORY=${HOME}/eggs/lib/chicken/5 -export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/eggs/lib/chicken/5 +export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/.local/share/eggs/lib/chicken/5 -chicken-install -init ${HOME}/eggs/lib/chicken/5 +#chicken-install -init ${HOME}/eggs/lib/chicken/5 chicken-install r7rs diff --git a/test-stklos.sh b/in-progress-stklos.sh similarity index 100% rename from test-stklos.sh rename to in-progress-stklos.sh diff --git a/test-cyclone.sh b/in-progress-test-cyclone.sh similarity index 100% rename from test-cyclone.sh rename to in-progress-test-cyclone.sh diff --git a/test-gambit.sh b/in-progress-test-gambit.sh similarity index 100% rename from test-gambit.sh rename to in-progress-test-gambit.sh diff --git a/test-gerbil.sh b/in-progress-test-gerbil.sh similarity index 100% rename from test-gerbil.sh rename to in-progress-test-gerbil.sh diff --git a/retropikzel/pffi/v0-1-0/chicken.scm b/retropikzel/pffi/v0-1-0/chicken.scm index 8173e6e..b2259e7 100644 --- a/retropikzel/pffi/v0-1-0/chicken.scm +++ b/retropikzel/pffi/v0-1-0/chicken.scm @@ -159,7 +159,8 @@ (define pffi-pointer-null? (lambda (pointer) - (= (pointer->address pointer) 0))) + (and (pffi-pointer? pointer) + (= (pointer->address pointer) 0)))) (define pffi-pointer-set! (lambda (pointer type offset value) diff --git a/retropikzel/pffi/v0-1-0/kawa.scm b/retropikzel/pffi/v0-1-0/kawa.scm index 7b3f5b0..cfd4ef0 100644 --- a/retropikzel/pffi/v0-1-0/kawa.scm +++ b/retropikzel/pffi/v0-1-0/kawa.scm @@ -67,6 +67,7 @@ (symbol->string c-name)) 'orElseThrow) function-descriptor))) + (lambda vals (invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))) diff --git a/retropikzel/pffi/v0-1-0/main.scm b/retropikzel/pffi/v0-1-0/main.scm index 2935323..71eb603 100644 --- a/retropikzel/pffi/v0-1-0/main.scm +++ b/retropikzel/pffi/v0-1-0/main.scm @@ -79,6 +79,7 @@ (begin (define library-version "v0-1-0") + (define slash (cond-expand (windows (string #\\)) (else "/"))) (define platform-file-extension (cond-expand @@ -86,12 +87,6 @@ (windows ".dll") (else ".so"))) - (define platform-version-file-extension - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) - (windows ".dll") - (else ".so.0"))) - (define platform-lib-prefix (cond-expand (racket (if (equal? (system-type 'os) 'windows) "" "lib")) @@ -166,7 +161,9 @@ "/usr/lib/x86_64-linux-gnu" "/usr/local/lib")))))) - (define-syntax pffi-shared-object-auto-load + (define auto-load-versions (list "")) + + (define-syntax pffi-shared-object-auto-load-old (syntax-rules () ((pffi-shared-object-auto-load headers object-name additional-paths) (cond-expand @@ -215,6 +212,35 @@ (error "Could not load shared object" object-name) shared-object))))))) + (define-syntax pffi-shared-object-auto-load + (syntax-rules () + ((pffi-shared-object-auto-load headers object-name additional-versions additional-paths) + (cond-expand + (cyclone (pffi-shared-object-load headers)) + (chicken (pffi-shared-object-load headers)) + (gambit (pffi-shared-object-load headers)) + (else + (let* ((paths (append auto-load-paths additional-paths)) + (versions (append auto-load-versions additional-versions)) + (shared-object #f)) + (for-each + (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" object-name) + (pffi-shared-object-load headers shared-object)))))))) + (cond-expand (kawa (include "kawa.scm")) (else #t)))) diff --git a/retropikzel/pffi/v0-1-0/main.sld b/retropikzel/pffi/v0-1-0/main.sld index 2935323..71eb603 100644 --- a/retropikzel/pffi/v0-1-0/main.sld +++ b/retropikzel/pffi/v0-1-0/main.sld @@ -79,6 +79,7 @@ (begin (define library-version "v0-1-0") + (define slash (cond-expand (windows (string #\\)) (else "/"))) (define platform-file-extension (cond-expand @@ -86,12 +87,6 @@ (windows ".dll") (else ".so"))) - (define platform-version-file-extension - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) - (windows ".dll") - (else ".so.0"))) - (define platform-lib-prefix (cond-expand (racket (if (equal? (system-type 'os) 'windows) "" "lib")) @@ -166,7 +161,9 @@ "/usr/lib/x86_64-linux-gnu" "/usr/local/lib")))))) - (define-syntax pffi-shared-object-auto-load + (define auto-load-versions (list "")) + + (define-syntax pffi-shared-object-auto-load-old (syntax-rules () ((pffi-shared-object-auto-load headers object-name additional-paths) (cond-expand @@ -215,6 +212,35 @@ (error "Could not load shared object" object-name) shared-object))))))) + (define-syntax pffi-shared-object-auto-load + (syntax-rules () + ((pffi-shared-object-auto-load headers object-name additional-versions additional-paths) + (cond-expand + (cyclone (pffi-shared-object-load headers)) + (chicken (pffi-shared-object-load headers)) + (gambit (pffi-shared-object-load headers)) + (else + (let* ((paths (append auto-load-paths additional-paths)) + (versions (append auto-load-versions additional-versions)) + (shared-object #f)) + (for-each + (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" object-name) + (pffi-shared-object-load headers shared-object)))))))) + (cond-expand (kawa (include "kawa.scm")) (else #t)))) diff --git a/scripts/init-test.sh b/scripts/init-test.sh index 7617848..db38a6e 100644 --- a/scripts/init-test.sh +++ b/scripts/init-test.sh @@ -1,5 +1,7 @@ set -eu +set -o pipefail + make clean make build make tmp diff --git a/scripts/test-runs-compilers.sh b/scripts/test-runs-compilers.sh index cd64492..5256a24 100644 --- a/scripts/test-runs-compilers.sh +++ b/scripts/test-runs-compilers.sh @@ -1,7 +1,9 @@ for file in ./test/*.scm do - echo "Testing ${file}" + echo "===========================================================" + echo "Testing ${file}, with ${SCHEME}" + echo "===========================================================" ${SCHEME} ${file} ${file//.scm/} done diff --git a/scripts/test-runs-dynamic.sh b/scripts/test-runs-dynamic.sh index 70fb946..c91ce70 100644 --- a/scripts/test-runs-dynamic.sh +++ b/scripts/test-runs-dynamic.sh @@ -1,6 +1,8 @@ for file in ./test/*.scm do - echo "Testing ${file}" + echo "===========================================================" + echo "Testing ${file}, with ${SCHEME}" + echo "===========================================================" ${SCHEME} ${file} done diff --git a/test-all.sh b/test-all.sh index 8502401..729902a 100644 --- a/test-all.sh +++ b/test-all.sh @@ -1,6 +1,5 @@ #!/usr/bin/env bash - for testfile in ./test-*.sh do if [[ ! "${testfile}" = "./test-all.sh" ]]; diff --git a/test/600_pffi-define.scm b/test/600_pffi-define.scm index 01ac27e..f41f0e1 100644 --- a/test/600_pffi-define.scm +++ b/test/600_pffi-define.scm @@ -4,7 +4,10 @@ (scheme eval) (retropikzel pffi v0-1-0 main)) -(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") "curl" (list))) +(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") + "curl" + (list ".4") + (list))) (pffi-define curl-version libcurl 'curl_version 'string (list)) diff --git a/test/600_string-to_pointer_to_string.scm b/test/600_string-to_pointer_to_string.scm deleted file mode 100644 index 56fb07d..0000000 --- a/test/600_string-to_pointer_to_string.scm +++ /dev/null @@ -1,17 +0,0 @@ -(import (scheme base) - (scheme write) - (retropikzel pffi v0-1-0 main)) - -(define original "Hello world") - -(define p (pffi-string->pointer original)) -(write p) -(newline) - -(define s (pffi-pointer->string p)) -(if (not (string=? original s)) - (error (string-append "string from pointer is not " original) s)) -(write s) -(newline) - -