From 6bb46c09c04e9e56f823638df171658e2738a1b6 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Thu, 14 Nov 2024 19:50:18 +0200 Subject: [PATCH] Updated the support table. Added cond-expand to export side in .sld file. --- .gitignore | 1 + HACKING.md | 7 + Makefile | 4 +- README.md | 45 ++-- retropikzel/r7rs-pffi.sld | 342 +++++++++++++++++++++++++++--- retropikzel/r7rs-pffi/cyclone.scm | 2 +- retropikzel/r7rs-pffi/larceny.scm | 26 +++ test.scm | 57 +++-- 8 files changed, 409 insertions(+), 75 deletions(-) create mode 100644 HACKING.md diff --git a/.gitignore b/.gitignore index 37cfaf7..26696b8 100644 --- a/.gitignore +++ b/.gitignore @@ -21,6 +21,7 @@ pffi-define test/pffi-define size-of test/* +test !test/*.scm retropikzel/pffi/*/*.c retropikzel/pffi/*/*.o* diff --git a/HACKING.md b/HACKING.md new file mode 100644 index 0000000..4033ae5 --- /dev/null +++ b/HACKING.md @@ -0,0 +1,7 @@ + +To run tests on different architecture than you are using, install podman and add the docker +registry to it's configuration. Add the line + + unqualified-search-registries = ["docker.io"] + +to file: /etc/containers/registries.conf diff --git a/Makefile b/Makefile index 7c9be76..6d0b76a 100644 --- a/Makefile +++ b/Makefile @@ -69,7 +69,7 @@ test-kawa-podman-amd64: test-kawa: ${KAWA} test.scm -LARCENY=larceny -r7 -I . +LARCENY=larceny -r7 -I . test-larceny-podman-amd64: podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm" @@ -115,7 +115,7 @@ test-ypsilon-podman-amd64: podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/ypsilon bash -c "cd /workdir && ${YPSILON} test.scm" test-ypsilon: - tr7i test.scm + ${YPSILON} test.scm documentation: cat README.md > docs/index.md diff --git a/README.md b/README.md index 67c27a8..e61085e 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 | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | -| ------------------------------- | ----- | ------- | ------- | ------- | ------ | ------ | ----- | ---- | ---- | ------ | ----------- | ----- | ------ | --- | -| pffi-init | 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 | 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 | | | | | ### Usage notes @@ -74,6 +74,10 @@ guarantees are being made just yet. - --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED - --enable-native-access=ALL-UNNAMED +- Larceny + - Runs on 32 bit mode +- Mosh + - FFI only works on x86_64 - Racket - Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs) @@ -87,12 +91,11 @@ guarantees are being made just yet. - Javascript side needs design - [MIT-Scheme](https://www.gnu.org/software/mit-scheme/) - [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html) -- [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/) -- [Larceny](https://larcenists.org/) - [Airship](https://gitlab.com/mbabich/airship-scheme) - [Other gambit targets](https://gambitscheme.org/) - Gambit compiles to different targets other than C too, for example Javascript. It would be cool and interesting to see if this FFI could also support some of those + - When LIPS and Biwascheme Javascript side is done then Gambit should be done too - [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs) - [prescheme](https://codeberg.org/prescheme/prescheme) diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index b06036c..01ebb2d 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -9,6 +9,24 @@ (scheme process-context) (chibi ast) (chibi)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + ) (include-shared "r7rs-pffi/r7rs-pffi-chibi")) (chicken (import (scheme base) @@ -20,7 +38,25 @@ (chicken locative) (chicken syntax) (chicken memory) - (chicken random))) + (chicken random)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + pffi-define-callback + pffi-pointer-address + ;pffi-pointer-dereference + )) (cyclone (import (scheme base) (scheme write) @@ -28,26 +64,98 @@ (scheme file) (scheme process-context) (cyclone foreign) - (scheme cyclone primitives))) + (scheme cyclone primitives)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (gambit (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (only (gambit) c-declare c-lambda c-define))) + (only (gambit) c-declare c-lambda c-define)) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (gauche (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (gerbil (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (guile (import (scheme base) (scheme write) @@ -56,26 +164,104 @@ (scheme process-context) (rnrs bytevectors) (system foreign) - (system foreign-library))) + (system foreign-library)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + pffi-define-callback + pffi-pointer-address + pffi-pointer-dereference)) (kawa (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (larceny (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (rename (primitives r5rs:require) (r5rs:require require)) + (primitives std-ffi) + (primitives foreign-procedure) + (primitives foreign-file) + (primitives foreign-stdlib) + ) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + ) + ) (mosh (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (mosh ffi))) + (mosh ffi)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (racket (import (scheme base) (scheme write) @@ -86,7 +272,24 @@ (ffi winapi) (compatibility mlist) (ffi unsafe) - (ffi vector))) + (ffi vector)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + pffi-define-callback + pffi-pointer-address + pffi-pointer-dereference)) (sagittarius (import (scheme base) (scheme write) @@ -94,51 +297,122 @@ (scheme file) (scheme process-context) (sagittarius ffi) - (sagittarius))) + (sagittarius)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string + pffi-define + pffi-define-callback + pffi-pointer-address + pffi-pointer-dereference)) (skint (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (stklos (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (stklos))) + (stklos)) + (export pffi-init + pffi-size-of + pffi-shared-object-auto-load + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (tr7 (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (ypsilon (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context)) + (export ;pffi-init + ;pffi-size-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference + )) (else (error "Unsupported implementation"))) - (export pffi-init - pffi-size-of - pffi-shared-object-auto-load - pffi-shared-object-load - pffi-pointer-null - pffi-pointer-null? - pffi-pointer-allocate - pffi-pointer? - pffi-pointer-free - pffi-pointer-set! - pffi-pointer-get - pffi-string->pointer - pffi-pointer->string - pffi-define - ;pffi-define-callback - ;pffi-pointer-address - pffi-pointer-dereference - ) (cond-expand (chibi (include "r7rs-pffi/chibi.scm")) (chicken (include "r7rs-pffi/chicken.scm")) @@ -154,7 +428,7 @@ (sagittarius (include "r7rs-pffi/sagittarius.scm")) (skint (include "r7rs-pffi/skint.scm")) (stklos (include "retropikzel/r7rs-pffi/stklos.scm")) - (tr7 (include "retropikzel/r7rs-pffi/tr7.scm")) + (tr7 (include "r7rs-pffi/tr7.scm")) (ypsilon (include "r7rs-pffi/ypsilon.scm")) (else #t)) (cond-expand diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/r7rs-pffi/cyclone.scm index 8fb5951..3ce8579 100644 --- a/retropikzel/r7rs-pffi/cyclone.scm +++ b/retropikzel/r7rs-pffi/cyclone.scm @@ -234,7 +234,7 @@ *p = double_value(value); return_closcall1(data, k, make_boolean(boolean_t));") -#;(define-c pffi-pointer-pointer-set! +(define-c pffi-pointer-pointer-set! "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "char* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = &opaque_ptr(value); diff --git a/retropikzel/r7rs-pffi/larceny.scm b/retropikzel/r7rs-pffi/larceny.scm index 3041685..683e0c0 100644 --- a/retropikzel/r7rs-pffi/larceny.scm +++ b/retropikzel/r7rs-pffi/larceny.scm @@ -1 +1,27 @@ +(require 'std-ffi) + (define pffi-init (lambda () #t)) + +;; FIXME +(define pffi-size-of + (lambda (type) + (cond ((eq? type 'int8) 1) + ((eq? type 'uint8) 1) + ((eq? type 'int16) 2) + ((eq? type 'uint16) 2) + ((eq? type 'int32) 4) + ((eq? type 'uint32) 4) + ((eq? type 'int64) 8) + ((eq? type 'uint64) 8) + ((eq? type 'char) 1) + ((eq? type 'unsigned-char) 1) + ((eq? type 'short) 2) + ((eq? type 'unsigned-short) 2) + ((eq? type 'int) 4) + ((eq? type 'unsigned-int) 4) + ((eq? type 'long) 4) + ((eq? type 'unsigned-long) 4) + ((eq? type 'float) 4) + ((eq? type 'double) 8) + ((eq? type 'pointer) 4) + (else (error "Can not get size of unknown type" type))))) diff --git a/test.scm b/test.scm index 8621411..a9d9383 100644 --- a/test.scm +++ b/test.scm @@ -53,6 +53,7 @@ (pffi-init) +#| ;; pffi-size-of (print-header 'pffi-size-of) @@ -139,34 +140,57 @@ (assert equal? (number? size-unsigned-int) #t) (assert = size-unsigned-int 4) -(assert equal? (number? (pffi-size-of 'unsigned-int)) #t) -(define size-long (pffi-size-of 'long)) -(debug size-long) -(assert equal? (number? size-long) #t) -(assert = size-long 8) +(cond-expand + (larceny ;; Works on 32 bit mode + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 8))) -(assert equal? (number? (pffi-size-of 'long)) #t) -(define size-unsigned-long (pffi-size-of 'unsigned-long)) -(debug size-unsigned-long) -(assert equal? (number? size-unsigned-long) #t) -(assert = size-unsigned-long 8) +(cond-expand + (larceny ;; Works on 32 bit mode + (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 8))) -(assert equal? (number? (pffi-size-of 'unsigned-long)) #t) +(assert equal? (number? (pffi-size-of 'float)) #t) (define size-float (pffi-size-of 'float)) (debug size-float) (assert equal? (number? size-float) #t) (assert = size-float 4) -(assert equal? (number? (pffi-size-of 'float)) #t) +(assert equal? (number? (pffi-size-of 'double)) #t) (define size-double (pffi-size-of 'double)) (debug size-double) (assert equal? (number? size-double) #t) (assert = size-double 8) -(define size-pointer (pffi-size-of 'pointer)) -(debug size-pointer) -(assert equal? (number? size-pointer) #t) -(assert = size-pointer 8) +(cond-expand + (larceny ;; Works on 32 bit mode + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 4)) + (else + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 8))) ;; pffi-shared-object-auto-load @@ -179,7 +203,6 @@ (debug libc-stdlib) -#| ;; pffi-pointer-null (print-header 'pffi-pointer-null)