From 0687b493d5c946bb981c56fa3fa583668210a929 Mon Sep 17 00:00:00 2001 From: Retropikzel Date: Wed, 6 Nov 2024 19:08:33 +0000 Subject: [PATCH] - Add pffi-init to each implementations file - Add tests without docker/podman - Migrate docker tests to podman so different arch can be used more easily - Add files (implementing not yet started) for more Scheme implementations - Start slowly adding support for Mosh --- Dockerfile | 8 -- Makefile | 102 +++++++++++++++--------- README.md | 10 +-- retropikzel/r7rs-pffi.sld | 97 ++++++++++++++++------- retropikzel/r7rs-pffi/chibi.scm | 5 ++ retropikzel/r7rs-pffi/chibi.stub | 1 + retropikzel/r7rs-pffi/cyclone.scm | 4 +- retropikzel/r7rs-pffi/gambit.scm | 20 +++-- retropikzel/r7rs-pffi/gauche.scm | 5 ++ retropikzel/r7rs-pffi/gerbil.scm | 110 +++++++++++--------------- retropikzel/r7rs-pffi/guile.scm | 3 + retropikzel/r7rs-pffi/kawa.scm | 2 + retropikzel/r7rs-pffi/main.scm | 3 - retropikzel/r7rs-pffi/mosh.scm | 37 +++++++++ retropikzel/r7rs-pffi/racket.scm | 2 + retropikzel/r7rs-pffi/sagittarius.scm | 2 + retropikzel/r7rs-pffi/skint.scm | 5 ++ retropikzel/r7rs-pffi/stklos.scm | 2 + retropikzel/r7rs-pffi/tr7.scm | 5 ++ test.scm | 2 +- 20 files changed, 267 insertions(+), 158 deletions(-) delete mode 100644 Dockerfile create mode 100644 retropikzel/r7rs-pffi/chibi.scm create mode 100644 retropikzel/r7rs-pffi/chibi.stub create mode 100644 retropikzel/r7rs-pffi/gauche.scm create mode 100644 retropikzel/r7rs-pffi/mosh.scm create mode 100644 retropikzel/r7rs-pffi/skint.scm create mode 100644 retropikzel/r7rs-pffi/tr7.scm diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index 6f730cd..0000000 --- a/Dockerfile +++ /dev/null @@ -1,8 +0,0 @@ -ARG IMPLEMENTATION -FROM schemers/$IMPLEMENTATION -ARG IMPLEMENTATION -WORKDIR /workdir -RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then apt update && apt install -y curl zip unzip && apt clean; fi -RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then bash -c "curl -s "https://get.sdkman.io" | bash && source $HOME/.sdkman/bin/sdkman-init.sh && sdk install java 22.0.2-tem"; fi -RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then apt remove -y openjdk*; fi -ENV PATH=/root/.sdkman/candidates/java/22.0.2-tem/bin:$PATH diff --git a/Makefile b/Makefile index b73bee5..d14e5c2 100644 --- a/Makefile +++ b/Makefile @@ -1,66 +1,90 @@ -TEST_PACKAGES_APT="libcurl4-openssl-dev libuv1" -DOCKER_INIT=apt update && apt install libcurl4-openssl-dev libuv1 && cd /workdir -SCHEME_RUNNER=PACKAGES=${TEST_PACKAGES_APT} ./scheme_runner -TESTFILES=$(shell ls tests/*.scm) - -test-tier1: \ - test-chicken\ - test-guile \ - test-kawa \ - test-sagittarius \ - test-racket - -test-tier2: \ - test-cyclone \ - test-gambit \ - test-stklos +test-chibi: + chibi-scheme test.scm CHICKEN=csc -X r7rs -R r7rs CHICKEN_LIB=csc -X r7rs -R r7rs -include-path ./retropikzel -s -J -test-chicken: clean - docker build . --build-arg IMPLEMENTATION=chicken -f Dockerfile --tag=r7rs-pffi-chicken +test-chicken-podman-amd65: clean cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - docker run -it -v ${PWD}:/workdir r7rs-pffi-chicken bash -c "cd /workdir && ${CHICKEN_LIB} retropikzel.r7rs-pffi.sld" - docker run -it -v ${PWD}:/workdir r7rs-pffi-chicken bash -c "cd /workdir && ${CHICKEN} test.scm && ./test" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/chicken bash -c "cd /workdir && ${CHICKEN_LIB} retropikzel.r7rs-pffi.sld" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/chicken bash -c "cd /workdir && ${CHICKEN} test.scm && ./test" + +test-chicken: clean + cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld + ${CHICKEN_LIB} retropikzel.r7rs-pffi.sld + ${CHICKEN} test.scm && ./test CYCLONE=cyclone -A . -test-cyclone: clean - docker build . --build-arg IMPLEMENTATION=cyclone -f Dockerfile --tag=r7rs-pffi-cyclone - docker run -it -v ${PWD}:/workdir r7rs-pffi-cyclone bash -c "cd /workdir && ${CYCLONE} retropikzel/r7rs-pffi.sld" - docker run -it -v ${PWD}:/workdir r7rs-pffi-cyclone bash -c "cd /workdir && ${CYCLONE} test.scm && ./test" +test-cyclone-podman-amd64: clean + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/cyclone bash -c "cd /workdir && ${CYCLONE} retropikzel/r7rs-pffi.sld" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/cyclone bash -c "cd /workdir && ${CYCLONE} test.scm && ./test" -GAMBIT_LIB=gsc . retropikzel/r7rs-pffi +test-cyclone: clean + ${CYCLONE} retropikzel/r7rs-pffi.sld + ${CYCLONE} test.scm + ./test + +GAMBIT_LIB=gsc -dynamic GAMBIT_CC=gsc -exe . -nopreload +test-gambit-podman-amd64: clean + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?" + podman run --arch=amd64 run -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ./test -:search=.; echo $$?" + test-gambit: clean - docker build . --build-arg IMPLEMENTATION=gambit -f Dockerfile --tag=r7rs-pffi-gambit - docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?" - docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?" - docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ./test -:search=.; echo $$?" + ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$? + ${GAMBIT_CC} test.scm; echo $$? + ./test -:search=.; echo $$? + +test-gauche: + gosh -r7 -A . test.scm GUILE=guile --r7rs --fresh-auto-compile -L . +test-guile-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/guile bash -c "cd /workdir && ${GUILE} test.scm" + test-guile: - docker build . --build-arg IMPLEMENTATION=guile -f Dockerfile --tag=r7rs-pffi-guile - docker run -it -v ${PWD}:/workdir r7rs-pffi-guile bash -c "cd /workdir && ${GUILE} test.scm" + ${GUILE} test.scm KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=.:*.sld +test-kawa-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/kawa bash -c "cd /workdir && ${KAWA} test.scm" + test-kawa: - docker build . --build-arg IMPLEMENTATION=kawa -f Dockerfile --tag=r7rs-pffi-kawa - docker run -it -v ${PWD}:/workdir r7rs-pffi-kawa bash -c "cd /workdir && ${KAWA} test.scm" + ${KAWA} test.scm + +MOSH=mosh --loadpath=. +test-mosh-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/mosh:0 bash -c "cd /workdir && ${MOSH} test.scm" + +test-mosh: + ${MOSH} test.scm SASH=sash -r7 -L . -L ./schubert +test-sagittarius-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/sagittarius bash -c "cd /workdir && ${SASH} test.scm" + test-sagittarius: - docker build . --build-arg IMPLEMENTATION=sagittarius -f Dockerfile --tag=r7rs-pffi-sagittarius - docker run -it -v ${PWD}:/workdir r7rs-pffi-sagittarius bash -c "cd /workdir && ${SASH} test.scm" + ${SASH} test.scm RACKET=racket -I r7rs -S . -S ./schubert --script +test-racket-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/racket bash -c "cd /workdir && ${RACKET} test.scm" + test-racket: - docker build . --build-arg IMPLEMENTATION=racket -f Dockerfile --tag=r7rs-pffi-racket - docker run -it -v ${PWD}:/workdir r7rs-pffi-racket bash -c "cd /workdir && ${RACKET} test.scm" + ${RACKET} test.scm + +test-skint: + skint test.scm STKLOS=stklos -A . -f +test-stklos-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/stklos bash -c "cd /workdir && ${STKLOS} test.scm" + test-stklos: - docker build . --build-arg IMPLEMENTATION=stklos -f Dockerfile --tag=r7rs-pffi-stklos - docker run -it -v ${PWD}:/workdir r7rs-pffi-stklos bash -c "cd /workdir && ${STKLOS} test.scm" + ${STKLOS} test.scm + +test-tr7: + tr7i test.scm documentation: cat README.md > docs/index.md diff --git a/README.md b/README.md index 688fd45..6afb6e0 100644 --- a/README.md +++ b/README.md @@ -28,8 +28,9 @@ For status of what tests pass on which implementations see ## Non goals - To have every possible FFI feature -- Compiling of C code at any point +- Compiling of used library C code at any point - That is no stubs, no C code generated by the library and so on + - The pffi library itself may require compilation on installation ## Known issues that are worked on @@ -66,6 +67,7 @@ guarantees are being made just yet. - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED - --enable-native-access=ALL-UNNAMED - [Gambit](https://gambitscheme.org) +- [Mosh](https://mosh.monaos.org) - [STKlos](https://stklos.net/) ### Design/exploration @@ -77,20 +79,14 @@ guarantees are being made just yet. - Will work on nodejs by using some Javascript FFI - Javascript side needs design - [Chibi](https://synthcode.com/scheme/chibi) - - FFI requires C code - [MIT-Scheme](https://www.gnu.org/software/mit-scheme/) - - FFI requires C code - [tr7](https://gitlab.com/jobol/tr7) - - FFI requires C code - [Gauche](https://practical-scheme.net/gauche/) - - FFI requires C code - [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html) - - FFI requires C code - [Gerbil](https://cons.io/) - Should be possible as built on gambit, but makes sense to make gambit support first - [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/) - [Larceny](https://larcenists.org/) -- [Mosh](https://mosh.monaos.org) - [Skint](https://github.com/false-schemers/skint) - [Airship](https://gitlab.com/mbabich/airship-scheme) - [Other gambit targets](https://gambitscheme.org/) diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index b94f992..36af13c 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -1,6 +1,12 @@ (define-library (retropikzel r7rs-pffi) (cond-expand + (chibi + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context))) (chicken (import (scheme base) (scheme write) @@ -26,6 +32,18 @@ (scheme char) (scheme file) (scheme process-context))) + (gauche + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context))) + (gerbil + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context))) (guile (import (scheme base) (scheme write) @@ -41,6 +59,13 @@ (scheme char) (scheme file) (scheme process-context))) + (mosh + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (mosh ffi))) (racket (import (scheme base) (scheme write) @@ -60,6 +85,12 @@ (scheme process-context) (sagittarius ffi) (sagittarius))) + (skint + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context))) (stklos (import (scheme base) (scheme write) @@ -67,36 +98,48 @@ (scheme file) (scheme process-context) (stklos))) + (tr7 + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context))) (else (error "Unsupported implementation"))) (export pffi-init + pffi-size-of pffi-shared-object-auto-load pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-address - pffi-pointer-dereference pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get) - (begin - (cond-expand - (chicken (include "r7rs-pffi/chicken.scm")) - (cyclone (include "retropikzel/r7rs-pffi/cyclone.scm")) - (gambit (include "r7rs-pffi/gambit.scm")) - (guile (include "r7rs-pffi/guile.scm")) - (kawa (include "r7rs-pffi/kawa.scm")) - (racket (include "r7rs-pffi/racket.scm")) - (sagittarius (include "r7rs-pffi/sagittarius.scm")) - (stklos (include "retropikzel/r7rs-pffi/stklos.scm")) - (else #t)) - (cond-expand - (cyclone (include "retropikzel/r7rs-pffi/main.scm")) - (stklos (include "retropikzel/r7rs-pffi/main.scm")) - (else (include "r7rs-pffi/main.scm"))))) + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-allocate + ;pffi-pointer-address + ;pffi-pointer-dereference + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-pointer-free + ;pffi-pointer? + ;pffi-pointer-set! + ;pffi-pointer-get + ) + (cond-expand + (chibi (include "r7rs-pffi/chibi.scm")) + (chicken (include "r7rs-pffi/chicken.scm")) + (cyclone (include "retropikzel/r7rs-pffi/cyclone.scm")) + (gambit (include "r7rs-pffi/gambit.scm")) + (gauche (include "r7rs-pffi/gauche.scm")) + (gerbil (include "r7rs-pffi/gerbil.scm")) + (guile (include "r7rs-pffi/guile.scm")) + (kawa (include "r7rs-pffi/kawa.scm")) + (mosh (include "r7rs-pffi/mosh.scm")) + (racket (include "r7rs-pffi/racket.scm")) + (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")) + (else #t)) + (cond-expand + (cyclone (include "retropikzel/r7rs-pffi/main.scm")) + (stklos (include "retropikzel/r7rs-pffi/main.scm")) + (else (include "r7rs-pffi/main.scm")))) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm new file mode 100644 index 0000000..ec960ad --- /dev/null +++ b/retropikzel/r7rs-pffi/chibi.scm @@ -0,0 +1,5 @@ +(define pffi-init (lambda () #t)) + +(define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/chibi.stub b/retropikzel/r7rs-pffi/chibi.stub new file mode 100644 index 0000000..8551f88 --- /dev/null +++ b/retropikzel/r7rs-pffi/chibi.stub @@ -0,0 +1 @@ +(c-system-include "stdint.h") diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/r7rs-pffi/cyclone.scm index b3c01e1..8fb5951 100644 --- a/retropikzel/r7rs-pffi/cyclone.scm +++ b/retropikzel/r7rs-pffi/cyclone.scm @@ -1,3 +1,5 @@ +(define pffi-init (lambda () #t)) + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) int) @@ -232,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/gambit.scm b/retropikzel/r7rs-pffi/gambit.scm index 7dba5bf..1eb808c 100644 --- a/retropikzel/r7rs-pffi/gambit.scm +++ b/retropikzel/r7rs-pffi/gambit.scm @@ -1,6 +1,8 @@ - (c-declare "#include ") +(define pffi-init (lambda () #t)) + +#| (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) int8) @@ -30,7 +32,7 @@ (lambda (object) (error "Not defined"))) -(define-syntax pffi-define +#;(define-syntax pffi-define (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name @@ -43,22 +45,25 @@ (lambda (scheme-name shared-object c-name return-type argument-types) (error "Not defined"))) -(c-declare "int size_of_int8() { return sizeof(int8_t);}") +;(c-declare "int size_of_int8() { return sizeof(int8_t);}") ;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));")) ;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));"))) ;(define int8-size (c-lambda () int "__return(1);")) +|# (define pffi-size-of (lambda (type) - (cond ((equal? type 'int8) 1) + (cond ((equal? type 'int8) (c-lambda () int "___return(sizeof(int8_t));")) (else (error "pffi-size-of -- No such pffi type" type))))) -(define-syntax pffi-pointer-allocate + +#| +#;(define-syntax pffi-pointer-allocate (syntax-rules ((pffi-pointer-allocate size) (c-declare (string-append "malloc(" (number->string size) ")"))))) -(define-syntax pffi-pointer-null +#;(define-syntax pffi-pointer-null (syntax-rules ((pffi-pointer-null) (c-declare "NULL")))) @@ -71,7 +76,7 @@ (lambda (pointer) pointer)) -(define-syntax pffi-shared-object-load +#;(define-syntax pffi-shared-object-load (syntax-rules () ((pffi-shared-object-load headers) (c-declare (apply string-append @@ -98,3 +103,4 @@ (define pffi-pointer-deref (lambda (pointer) (error "Not defined"))) +|# diff --git a/retropikzel/r7rs-pffi/gauche.scm b/retropikzel/r7rs-pffi/gauche.scm new file mode 100644 index 0000000..ec960ad --- /dev/null +++ b/retropikzel/r7rs-pffi/gauche.scm @@ -0,0 +1,5 @@ +(define pffi-init (lambda () #t)) + +(define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/gerbil.scm b/retropikzel/r7rs-pffi/gerbil.scm index 8e454d7..3494b4b 100644 --- a/retropikzel/r7rs-pffi/gerbil.scm +++ b/retropikzel/r7rs-pffi/gerbil.scm @@ -1,79 +1,59 @@ -(define-library - (retropikzel r7rs-pffi version gerbil) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context)) - (export pffi-shared-object-load - pffi-define - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin +(define pffi-init (lambda () #t)) - (define pffi-type->native-type - (lambda (type) - (error "Not defined"))) +(define pffi-type->native-type + (lambda (type) + (error "Not defined"))) - (define pffi-pointer? - (lambda (object) - (error "Not defined"))) +(define pffi-pointer? + (lambda (object) + (error "Not defined"))) - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (error "Not defined")))) +(define-syntax pffi-define + (syntax-rules () + ((pffi-define scheme-name shared-object c-name return-type argument-types) + (error "Not defined")))) +(define pffi-size-of + (lambda (type) + (error "Not defined"))) - (define pffi-size-of - (lambda (type) - (error "Not defined"))) +(define pffi-pointer-allocate + (lambda (size) + (error "Not defined"))) - (define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) +(define pffi-pointer-null + (lambda () + (error "Not defined"))) - (define pffi-pointer-null - (lambda () - (error "Not defined"))) +(define pffi-string->pointer + (lambda (string-content) + (error "Not defined"))) - (define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) +(define pffi-pointer->string + (lambda (pointer) + pointer)) - (define pffi-pointer->string - (lambda (pointer) - pointer)) +(define pffi-shared-object-load + (lambda (header path) + (error "Not defined"))) - (define pffi-shared-object-load - (lambda (header path) - (error "Not defined"))) +(define pffi-pointer-free + (lambda (pointer) + (error "Not defined"))) - (define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) +(define pffi-pointer-null? + (lambda (pointer) + (error "Not defined"))) - (define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) +(define pffi-pointer-set! + (lambda (pointer type offset value) + (let ((p pointer)) + (error "Not defined")))) - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) +(define pffi-pointer-get + (lambda (pointer type offset) + (error "Not defined"))) - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))))) +(define pffi-pointer-deref + (lambda (pointer) + (error "Not defined"))) diff --git a/retropikzel/r7rs-pffi/guile.scm b/retropikzel/r7rs-pffi/guile.scm index 4995190..849a4d1 100644 --- a/retropikzel/r7rs-pffi/guile.scm +++ b/retropikzel/r7rs-pffi/guile.scm @@ -1,3 +1,6 @@ +(define pffi-init (lambda () #t)) + + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) int8) diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm index b8d3777..c655e97 100644 --- a/retropikzel/r7rs-pffi/kawa.scm +++ b/retropikzel/r7rs-pffi/kawa.scm @@ -2,6 +2,8 @@ (define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup)) (define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) +(define pffi-init (lambda () #t)) + (define value->object (lambda (value type) (cond ((equal? type 'byte) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index 605d804..e5e8994 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -1,6 +1,3 @@ -(cond-expand - (chicken #t) - (else (define pffi-init (lambda () #t)))) (define pffi-types '(int8 diff --git a/retropikzel/r7rs-pffi/mosh.scm b/retropikzel/r7rs-pffi/mosh.scm new file mode 100644 index 0000000..11918a6 --- /dev/null +++ b/retropikzel/r7rs-pffi/mosh.scm @@ -0,0 +1,37 @@ +(define pffi-init (lambda () #t)) + +(define pffi-size-of + (lambda (type) + (cond ((eq? type 'int8) 1) ; FIXME + ((eq? type 'uint8) 1) ; FIXME + ((eq? type 'int16) 2) ; FIXME + ((eq? type 'uint16) 2) ;FIXME + ((eq? type 'int32) 4) ; FIXME + ((eq? type 'uint32) 4) ; FIXME + ((eq? type 'int64) 8) ; FIXME + ((eq? type 'uint64) 8) ; FIXME + ((eq? type 'char) size-of-bool) + ((eq? type 'unsigned-char) size-of-bool) + ((eq? type 'short) size-of-short) + ((eq? type 'unsigned-short) size-of-unsigned-short) + ((eq? type 'int) size-of-int) + ((eq? type 'unsigned-int) size-of-unsigned-int) + ((eq? type 'long) size-of-long) + ((eq? type 'unsigned-long) size-of-unsigned-long) + ((eq? type 'float) size-of-float) + ((eq? type 'double) size-of-double) + ((eq? type 'pointer) size-of-pointer) + (else (error "Can not get size of unknown type" type))))) + +(define pffi-shared-object-load + (lambda (header path) + (open-shared-library path))) + +(define pffi-pointer-null + (lambda () + #f)) ; TODO + +(define pffi-pointer-null? + (lambda (pointer) + (if (equal? pointer #f) #t #f))) ; TODO + diff --git a/retropikzel/r7rs-pffi/racket.scm b/retropikzel/r7rs-pffi/racket.scm index e90d6a8..deedf7c 100644 --- a/retropikzel/r7rs-pffi/racket.scm +++ b/retropikzel/r7rs-pffi/racket.scm @@ -1,3 +1,5 @@ +(define pffi-init (lambda () #t)) + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) _int8) diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/r7rs-pffi/sagittarius.scm index e2f686a..c8c21a8 100644 --- a/retropikzel/r7rs-pffi/sagittarius.scm +++ b/retropikzel/r7rs-pffi/sagittarius.scm @@ -1,3 +1,5 @@ +(define pffi-init (lambda () #t)) + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) diff --git a/retropikzel/r7rs-pffi/skint.scm b/retropikzel/r7rs-pffi/skint.scm new file mode 100644 index 0000000..ec960ad --- /dev/null +++ b/retropikzel/r7rs-pffi/skint.scm @@ -0,0 +1,5 @@ +(define pffi-init (lambda () #t)) + +(define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/r7rs-pffi/stklos.scm index 50d67ab..4b55178 100644 --- a/retropikzel/r7rs-pffi/stklos.scm +++ b/retropikzel/r7rs-pffi/stklos.scm @@ -1,3 +1,5 @@ +(define pffi-init (lambda () #t)) + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) :int) diff --git a/retropikzel/r7rs-pffi/tr7.scm b/retropikzel/r7rs-pffi/tr7.scm new file mode 100644 index 0000000..ec960ad --- /dev/null +++ b/retropikzel/r7rs-pffi/tr7.scm @@ -0,0 +1,5 @@ +(define pffi-init (lambda () #t)) + +(define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) 1)))) diff --git a/test.scm b/test.scm index 1ecd9ba..94ef558 100644 --- a/test.scm +++ b/test.scm @@ -187,6 +187,7 @@ (debug null-pointer) (assert equal? (pffi-pointer-null? null-pointer) #t) +#| ;; pffi-pointer-null? (print-header 'pffi-pointer-null?) @@ -346,7 +347,6 @@ (pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) (assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") -#| ;; pffi-define (print-header 'pffi-define)