From 029ae48039963b648651035a34c4c7c953ab887b Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 15 Sep 2024 12:40:51 +0300 Subject: [PATCH] Add size tests for all types --- Makefile | 2 +- retropikzel/r7rs-pffi/version/kawa.scm | 72 ++++++++++++++++++++++---- test.scm | 64 +++++++++++++++++++++-- 3 files changed, 124 insertions(+), 14 deletions(-) diff --git a/Makefile b/Makefile index 3084a97..223afaf 100644 --- a/Makefile +++ b/Makefile @@ -61,7 +61,7 @@ test-guile: build 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=.:./schubert test-kawa: build - ${SCHEME_RUNNER} kawa "${KAWA} test.scm" + echo "${SCHEME_RUNNER} kawa \"${KAWA} test.scm\"" SASH=sash -L . -L ./schubert test-sagittarius: build diff --git a/retropikzel/r7rs-pffi/version/kawa.scm b/retropikzel/r7rs-pffi/version/kawa.scm index d9ea767..9936d59 100644 --- a/retropikzel/r7rs-pffi/version/kawa.scm +++ b/retropikzel/r7rs-pffi/version/kawa.scm @@ -31,6 +31,32 @@ ((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 '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)) + ((equal? type 'unsigned-int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) + ((equal? type 'unsigned-long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) + ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4)) + ((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 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) + ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + +(define pffi-type->native-type-old + (lambda (type) + (cond + ((equal? type 'int8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR)) ((equal? type 'unsigned-char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR)) ((equal? type 'short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT)) @@ -44,7 +70,7 @@ ((equal? type 'pointer) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) ((equal? type 'string) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) ((equal? type 'void) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) - (else (error "pffi-type->native-type -- No such pffi type" type))))) + (else (error "pffi-type->function-argument-type -- No such pffi type" type))))) (define pffi-pointer? (lambda (object) @@ -63,8 +89,11 @@ (symbol->string c-name)) 'orElseThrow) (if (equal? return-type 'void) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) (map pffi-type->native-type argument-types)) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) (cons (pffi-type->native-type return-type) (map pffi-type->native-type argument-types))))) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) + (map pffi-type->native-type argument-types)) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) + (pffi-type->native-type return-type) + (map pffi-type->native-type argument-types)))) 'invokeWithArguments (map value->object vals argument-types))))))) @@ -76,7 +105,7 @@ (define pffi-pointer-allocate (lambda (size) - (invoke arena 'allocate size 1))) + (invoke (invoke arena 'allocate size 1) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)))) (define pffi-pointer-null (lambda () @@ -84,7 +113,7 @@ (define pffi-string->pointer (lambda (string-content) - (invoke arena 'allocateFrom string-content))) + (invoke (invoke arena 'allocateFrom string-content) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)))) (define pffi-pointer->string (lambda (pointer) @@ -98,8 +127,6 @@ (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) "/" file-name)) - ;(set! arena (invoke-static java.lang.foreign.Arena 'ofConfined)) - (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) (lookup (invoke-static java.lang.foreign.SymbolLookup 'libraryLookup @@ -118,15 +145,40 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (invoke pointer 'set (pffi-type->native-type type) offset value))) + (cond ((equal? type 'string) + (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'setString + offset + value)) + (else + (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'set + (invoke (pffi-type->native-type type) 'withByteAlignment 1) + offset + value))))) (define pffi-pointer-get (lambda (pointer type offset) - (invoke pointer 'get (pffi-type->native-type type) offset))) + (cond ((equal? type 'string) + (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'getString + offset)) + (else (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'get + (invoke (pffi-type->native-type type) 'withByteAlignment 1) + offset))))) (define pffi-pointer-deref (lambda (pointer) - (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0))) + (invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0))) (define pffi-define-callback (lambda (scheme-name return-type argument-types procedure) diff --git a/test.scm b/test.scm index f55d55a..106a889 100644 --- a/test.scm +++ b/test.scm @@ -98,61 +98,117 @@ (define size-uint8 (pffi-size-of 'uint8)) (debug size-uint8) +(assert equal? (number? size-uint8) #t) +(assert = size-uint8 1) + (assert equal? (number? (pffi-size-of 'uint8)) #t) (define size-int16 (pffi-size-of 'int16)) (debug size-int16) +(assert equal? (number? size-int16) #t) +(assert = size-int16 2) + (assert equal? (number? (pffi-size-of 'int16)) #t) (define size-uint16 (pffi-size-of 'uint16)) (debug size-uint16) +(assert equal? (number? size-uint16) #t) +(assert = size-uint16 2) + (assert equal? (number? (pffi-size-of 'uint16)) #t) (define size-int32 (pffi-size-of 'int32)) (debug size-int32) +(assert equal? (number? size-int32) #t) +(assert = size-int32 4) + (assert equal? (number? (pffi-size-of 'int32)) #t) (define size-uint32 (pffi-size-of 'uint32)) (debug size-uint32) +(assert equal? (number? size-uint32) #t) +(assert = size-uint32 4) + (assert equal? (number? (pffi-size-of 'uint32)) #t) (define size-int64 (pffi-size-of 'int64)) (debug size-int64) +(assert equal? (number? size-int64) #t) +(assert = size-int64 8) + (assert equal? (number? (pffi-size-of 'int64)) #t) (define size-uint64 (pffi-size-of 'uint64)) (debug size-uint64) +(assert equal? (number? size-uint64) #t) +(assert = size-uint64 8) + (assert equal? (number? (pffi-size-of 'uint64)) #t) (define size-char (pffi-size-of 'char)) (debug size-char) +(assert equal? (number? size-char) #t) +(assert = size-char 1) + (assert equal? (number? (pffi-size-of 'char)) #t) (define size-unsigned-char (pffi-size-of 'unsigned-char)) (debug size-unsigned-char) +(assert equal? (number? size-unsigned-char) #t) +(assert = size-unsigned-char 1) + (assert equal? (number? (pffi-size-of 'unsigned-char)) #t) (define size-short (pffi-size-of 'short)) (debug size-short) +(assert equal? (number? size-short) #t) +(assert = size-short 2) + (assert equal? (number? (pffi-size-of 'short)) #t) (define size-unsigned-short (pffi-size-of 'unsigned-short)) (debug size-unsigned-short) +(assert equal? (number? size-unsigned-short) #t) +(assert = size-unsigned-short 2) + (assert equal? (number? (pffi-size-of 'unsigned-short)) #t) (define size-int (pffi-size-of 'int)) (debug size-int) +(assert equal? (number? size-int) #t) +(assert = size-int 4) + (assert equal? (number? (pffi-size-of 'int)) #t) (define size-unsigned-int (pffi-size-of 'unsigned-int)) (debug size-unsigned-int) +(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) + (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) (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) (define size-double (pffi-size-of 'double)) (debug size-double) +(assert equal? (number? size-double) #t) +(assert = size-double 8) + (assert equal? (number? (pffi-size-of 'double)) #t) (define size-string (pffi-size-of 'string)) (debug size-string) +(assert equal? (number? size-string) #t) +(assert = size-string 8) + (assert equal? (number? (pffi-size-of 'string)) #t) (define size-pointer (pffi-size-of 'pointer)) (debug size-pointer) -(assert equal? (number? (pffi-size-of 'pointer)) #t) +(assert equal? (number? size-pointer) #t) +(assert = size-pointer 8) + ;; pffi-pointer-allocate @@ -285,8 +341,10 @@ (print-header 'pffi-define) -(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) -(assert = (atoi (pffi-string->pointer "100")) 100) +(pffi-define atoi-pointer libc-stdlib 'atoi 'int (list 'pointer)) +(assert = (atoi-pointer (pffi-string->pointer "100")) 100) +(pffi-define atoi-string libc-stdlib 'atoi 'int (list 'string)) +(assert = (atoi-string (pffi-string->pointer "100")) 100) (exit) ;; pffi-define-callback