Improvements for Kawa
This commit is contained in:
parent
9240a5a11e
commit
85bd30e87d
17
Makefile
17
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
14
test.scm
14
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue