From 85bd30e87d9f728e360b2d8196fb9b07bebd8c50 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 25 Jan 2025 09:21:18 +0200 Subject: [PATCH] Improvements for Kawa --- Makefile | 17 +++++++++++++++-- retropikzel/r7rs-pffi/kawa.scm | 35 ++++++++++++++++++---------------- test.scm | 14 ++++++++------ 3 files changed, 42 insertions(+), 24 deletions(-) diff --git a/Makefile b/Makefile index 3c7bfe3..f284aed 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,11 @@ test-chicken5-podman-amd65: clean libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" +test-chicken5-docker: clean libtest.so + cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld + docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" + docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" + test-chicken5: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld @@ -47,10 +52,15 @@ test-chicken6-podman-amd65: clean libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" +test-chicken6-docker: clean libtest.so + cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld + docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" + docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" + test-chicken6: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld - ${CHICKEN5} test.scm && ./test + ${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld + ${CHICKEN6} test.scm && ./test CYCLONE=cyclone -COPT -I. -A . test-cyclone-podman-amd64: clean libtest.so @@ -97,6 +107,9 @@ KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exp test-kawa-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/kawa bash -c "cd /workdir && ${KAWA} test.scm" +test-kawa-docker: libtest.so + docker run -it -v ${PWD}:/workdir docker.io/schemers/kawa bash -c "cd /workdir && ${KAWA} test.scm" + test-kawa: libtest.so ${KAWA} test.scm diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm index b40b738..c7ca2e0 100644 --- a/retropikzel/r7rs-pffi/kawa.scm +++ b/retropikzel/r7rs-pffi/kawa.scm @@ -31,16 +31,16 @@ (define pffi-type->native-type (lambda (type) (cond - ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) - ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) + ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) + ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) ((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) ((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) ((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) ((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) ((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) ((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) - ((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) - ((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) + ((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) + ((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) ((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) ((equal? type 'unsigned-short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) ((equal? type 'int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) @@ -51,7 +51,7 @@ ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8)) ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) - ((equal? type 'callback) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) + ((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-pointer? @@ -130,7 +130,7 @@ (define pffi-pointer-allocate (lambda (size) - (invoke (invoke arena 'allocate size 1) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)))) + (invoke (invoke arena 'allocate size 1) 'reinterpret size))) (define pffi-pointer-address (lambda (pointer) @@ -146,7 +146,9 @@ (define pffi-string->pointer (lambda (string-content) - (invoke (invoke arena 'allocateFrom string-content) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)))) + (let ((size (+ (invoke string-content 'length) 1))) + (invoke (invoke arena 'allocateFrom (invoke string-content 'toString)) + 'reinterpret size)))) (define pffi-pointer->string (lambda (pointer) @@ -178,19 +180,20 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (invoke (invoke pointer - 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) + (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'set - (invoke (pffi-type->native-type type) 'withByteAlignment 1) + (pffi-type->native-type type) offset - value))) + (if (equal? type 'char) + (char->integer value) + value)))) (define pffi-pointer-get (lambda (pointer type offset) - (let ((r (invoke (invoke pointer 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) + (let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'get - (invoke (pffi-type->native-type type) 'withByteAlignment 1) + (pffi-type->native-type type) offset))) - r))) + (if (equal? type 'char) + (integer->char r) + r)))) diff --git a/test.scm b/test.scm index 8729cca..2bde937 100644 --- a/test.scm +++ b/test.scm @@ -496,6 +496,7 @@ (define string-pointer (pffi-string->pointer "Hello world")) (debug string-pointer) +(debug (pffi-pointer->string string-pointer)) (assert equal? (pffi-pointer? string-pointer) #t) (assert equal? (pffi-pointer-null? string-pointer) #f) (debug (pffi-pointer-get string-pointer 'char 0)) @@ -766,17 +767,18 @@ (write compare) (newline) -(display "Unsorted: ") -(write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) +(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) -(newline) +(debug unsorted) +(assert equal? unsorted (list 3 2 1)) + (qsort array 3 (pffi-size-of 'int) compare) -(display "Sorted: ") -(write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) +(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) -(newline) +(debug sorted) +(assert equal? sorted (list 1 2 3)) (exit 0)