Add size tests for all types
This commit is contained in:
parent
2d62b68241
commit
029ae48039
2
Makefile
2
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
64
test.scm
64
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue