Improvements for Kawa

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
+	${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld
-	${CHICKEN5} test.scm && ./test
+	${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
 

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 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
-      ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) '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 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
-      ((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) '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
+    (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
-                    '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
+    (let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
-                             (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))))

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: ")
+(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
-(write (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: ")
+(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
-(write (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)