diff --git a/Makefile b/Makefile index b64f96c..88cdc1d 100644 --- a/Makefile +++ b/Makefile @@ -5,6 +5,42 @@ documentation: schubert document VERSION=${VERSION} bash doc/generate.sh > documentation.md +test-size-of: + @echo "Sagittarius" + sash -r7 -L . test/size-of.scm + @echo "Guile" + guile --r7rs -L . test/size-of.scm + #@echo "Racket" + #racket -I r7rs test/size-of.scm + #@echo "STKlos" + #stklos -A . test/hello.scm + @echo "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=".." \ + test/size-of.scm + +test-pointer-set-get: + sash -r7 -L . test/pointer-set-get.scm + 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=".." \ + test/pointer-set-get.scm + test-sagittatius-sdl2: sash -r7 -L . test/sdl2.scm @@ -38,7 +74,8 @@ test-racket-sdl2: build-rkt test-stklos-hello: stklos -A . test/hello.scm -test-kawa-size-of-int: + +test-kawa-string-to-pointer-to-string: java \ --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ @@ -49,7 +86,7 @@ test-kawa-size-of-int: --r7rs \ --full-tailcalls \ -Dkawa.import.path=".." \ - test/size-of-int.scm + test/string-to-pointer-to-string.scm test-kawa-sdl2: java \ diff --git a/retropikzel/pffi/v0.1.0/main.scm b/retropikzel/pffi/v0.1.0/main.scm index 373fb03..e2c595b 100644 --- a/retropikzel/pffi/v0.1.0/main.scm +++ b/retropikzel/pffi/v0.1.0/main.scm @@ -64,8 +64,6 @@ (stklos #t) (kawa (define arena (invoke-static java.lang.foreign.Arena 'global)) - (define linker #f) - (define lookup #f) (define value->object (lambda (value type) (cond ((equal? type 'byte) @@ -187,12 +185,9 @@ ((equal? type 'uint32) uint32) ((equal? type 'int64) int64) ((equal? type 'uint64) uint64) - ;((equal? type 'intptr) intptr) - ;((equal? type 'uintptr) uintptr) ;((equal? type 'char) char) ((equal? type 'char) int) - ;((equal? type 'unsigned-char) char) - ;((equal? type 'unsigned-char) int) + ((equal? type 'unsigned-char) int) ((equal? type 'short) short) ((equal? type 'unsigned-short) unsigned-short) ((equal? type 'int) int) @@ -214,8 +209,6 @@ ((equal? type 'uint32) _uint32) ((equal? type 'int64) _int64) ((equal? type 'uint64) _uint64) - ;((equal? type 'intptr) intptr) - ;((equal? type 'uintptr) uintptr) ;((equal? type 'char) _int32) ((equal? type 'char) _int) ((equal? type 'unsigned-char) _int) @@ -255,27 +248,37 @@ ((equal? type 'void) :void) (else (error "pffi-type->native-type -- No such pffi type" type)))) (kawa - (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)) - ((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT)) - ((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) - ((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) - ((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) - ((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) - ((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT)) - ((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE)) - ((equal? type 'pointer) (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))))))) + (cond + ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) + ;((equal? type 'int8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) + ;((equal? type 'uint8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ;((equal? type 'int16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ;((equal? type 'uint16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ;((equal? type 'int32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ;((equal? type 'uint32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ;((equal? type 'int64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ;((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)) + ((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT)) + ((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) + ((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) + ((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) + ((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT)) + ((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE)) + ((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))))))) (define pffi-pointer? (lambda (object) @@ -284,10 +287,8 @@ (guile (pointer? object)) (racket (cpointer? object)) (stklos (cpointer? object)) - (kawa (display "pffi-pointer? called with: ") ; TODO FIX - (write object) - (newline) - #f)))) + (kawa (error "Not yet implemented: pffi-pointer?") ; TODO FIX + )))) ;> ### pffi-call ;> @@ -355,9 +356,9 @@ (function-descriptor (if (equal? type 'void) (apply of-void types) (apply of (append (list native-type) types)))) - (method-handle (invoke linker + (method-handle (invoke (cdr (assoc 'linker shared-object)) 'downcallHandle - (invoke (invoke lookup + (invoke (invoke (cdr (assoc 'lookup shared-object)) 'find (symbol->string name)) 'orElseThrow) @@ -377,8 +378,6 @@ ((eq? type 'uint32) size-of-uint32_t) ((eq? type 'int64) size-of-int64_t) ((eq? type 'uint64) size-of-uint64_t) - ((eq? type 'intptr) size-of-intptr_t) - ((eq? type 'uintptr) size-of-uintptr_t) ((eq? type 'char) size-of-char) ((eq? type 'unsigned-char) size-of-char) ((eq? type 'short) size-of-short) @@ -389,12 +388,13 @@ ((eq? type 'unsigned-long) size-of-unsigned-long) ((eq? type 'float) size-of-float) ((eq? type 'double) size-of-double) + ((eq? type 'string) size-of-void*) ((eq? type 'pointer) size-of-void*) (else (error "Can not get size of unknown type" type)))) (guile (sizeof (pffi-type->native-type type))) (racket (ctype-sizeof (pffi-type->native-type type))) (stklos 4) ; TODO FIX - (kawa (invoke (pffi-type->native-type type) 'byteSize))))) + (kawa (invoke (pffi-type->native-type type) 'byteAlignment))))) (define pffi-pointer-allocate (lambda (size) @@ -410,9 +410,9 @@ (cond-expand (sagittarius (integer->pointer 0)) (guile (make-pointer 0)) - (racket #f) ; In rackter #f is null pointer + (racket #f) ; In racket #f is null pointer (stklos (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)) - (kawa (invoke-static java.lang.foreign.MemorySegment 'ofAddress 0))))) + (kawa (static-field java.lang.foreign.MemorySegment 'NULL))))) (define pffi-string->pointer (lambda (string-content) @@ -428,7 +428,7 @@ (guile (pointer->string pointer)) (racket (cast pointer _pointer _string)) (cpointer->string pointer) - (kawa (invoke pointer 'getString))))) + (kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0))))) (define pffi-pointer->bytevector (lambda (pointer size) @@ -436,7 +436,10 @@ (guile (pointer->bytevector pointer size)) (racket (cast pointer _pointer _bytes)) (stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX - (kawa (invoke pointer 'toArray))))) + (kawa (invoke (invoke pointer 'reinterpret size) + 'toArray + (static-field java.lang.foreign.ValueLayout + 'JAVA_BYTE)))))) (define pffi-shared-object-load (lambda (path) @@ -450,17 +453,16 @@ (library-parent-folder (make java.io.File (invoke library-file 'getParent))) (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) "/" - file-name))) - (set! arena (invoke-static java.lang.foreign.Arena 'ofConfined)) - (set! linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) - (set! lookup (invoke-static java.lang.foreign.SymbolLookup + 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 absolute-path - (invoke-static java.lang.foreign.Arena 'ofAuto) - )) - ;(invoke-static java.lang.System 'load absolute-path) - #t)) - ))) + arena))) + (list (cons 'linker linker) + (cons 'lookup lookup))))))) (define pffi-shared-object-auto-load (lambda (object-name additional-paths) @@ -571,10 +573,7 @@ ))) (racket (ptr-set! pointer type offset value)) (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX - (kawa (invoke pointer - 'set - (pffi-type->native-type type) - offset))))) + (kawa (invoke pointer 'set (pffi-type->native-type type) offset value))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -628,10 +627,7 @@ ))) (racket (ptr-ref pointer type offset)) (stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX - (kawa (invoke pointer - 'get - (pffi-type->native-type type) - offset))))) + (kawa (invoke pointer 'get (pffi-type->native-type type) offset))))) (define pffi-pointer-deref (lambda (pointer) @@ -639,5 +635,4 @@ (guile (dereference-pointer pointer)) (racket (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX (stklos (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX - (kawa (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX - ))))) + (kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0))))))) diff --git a/test/pointer-set-get.scm b/test/pointer-set-get.scm new file mode 100644 index 0000000..1ada250 --- /dev/null +++ b/test/pointer-set-get.scm @@ -0,0 +1,28 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0.1.0 main)) + +(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3) + (* (pffi-size-of 'uint8) 4) + (pffi-size-of 'int)))) + +(write p) +(newline) + +(pffi-pointer-set! p + 'uint8 + (+ (* (pffi-size-of 'uint32)) + (* (pffi-size-of 'uint8) 2)) + 42) + +(write p) +(newline) + +(write (pffi-pointer-get p + 'uint8 + (+ (* (pffi-size-of 'uint32)) + (* (pffi-size-of 'uint8) 2)) + )) +(newline) + + diff --git a/test/size-of-int.scm b/test/size-of-int.scm deleted file mode 100644 index 5cfe9f3..0000000 --- a/test/size-of-int.scm +++ /dev/null @@ -1,8 +0,0 @@ -(import (scheme base) - (scheme write) - (retropikzel pffi v0.1.0 main)) - -(write (pffi-size-of 'int)) -(newline) - - diff --git a/test/size-of.scm b/test/size-of.scm new file mode 100644 index 0000000..36d978f --- /dev/null +++ b/test/size-of.scm @@ -0,0 +1,80 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0.1.0 main)) + +(display 'int8) +(display " ") +(display (pffi-size-of 'int8)) +(newline) +(display 'uint8) +(display " ") +(display (pffi-size-of 'uint8)) +(newline) +(display 'int16) +(display " ") +(display (pffi-size-of 'int16)) +(newline) +(display 'uint16) +(display " ") +(display (pffi-size-of 'uint16)) +(newline) +(display 'int32) +(display " ") +(display (pffi-size-of 'int32)) +(newline) +(display 'uint32) +(display " ") +(display (pffi-size-of 'uint32)) +(newline) +(display 'int64) +(display " ") +(display (pffi-size-of 'int64)) +(newline) +(display 'uint64) +(display " ") +(display (pffi-size-of 'uint64)) +(newline) +(display 'char) +(display " ") +(display (pffi-size-of 'char)) +(newline) +(display 'unsigned-char) +(display " ") +(display (pffi-size-of 'unsigned-char)) +(newline) +(display 'short) +(display " ") +(display (pffi-size-of 'short)) +(newline) +(display 'unsigned-short) +(display " ") +(display (pffi-size-of 'unsigned-short)) +(newline) +(display 'int) +(display " ") +(display (pffi-size-of 'int)) +(newline) +(display 'unsigned-int) +(display " ") +(display (pffi-size-of 'unsigned-int)) +(newline) +(display 'long) +(display " ") +(display (pffi-size-of 'long)) +(newline) +(display 'unsigned-long) +(display " ") +(display (pffi-size-of 'unsigned-long)) +(newline) +(display 'float) +(display " ") +(display (pffi-size-of 'float)) +(newline) +(display 'double) +(display " ") +(display (pffi-size-of 'double)) +(newline) +(display 'pointer) +(display " ") +(display (pffi-size-of 'pointer)) +(newline) diff --git a/test/string-to-pointer-to-string.scm b/test/string-to-pointer-to-string.scm new file mode 100644 index 0000000..e6fc2da --- /dev/null +++ b/test/string-to-pointer-to-string.scm @@ -0,0 +1,14 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0.1.0 main)) + + +(define p (pffi-string->pointer "Hello world")) +(write p) +(newline) + +(define s (pffi-pointer->string p)) +(write s) +(newline) + +