Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added most of Kawa support

This commit is contained in:
retropikzel 2024-05-06 20:45:31 +03:00
parent 5234dd78f4
commit 2ac8de5f42
5 changed files with 163 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
Makefile
View File

@ -38,5 +38,29 @@ test-racket-sdl2: build-rkt
test-stklos-hello:
stklos -A . test/hello.scm
test-racket-sdl2:
stklos -A . test/sdl2.scm
test-kawa-size-of-int:
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-int.scm
test-kawa-sdl2:
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/sdl2.scm

BIN
kawa.jar Normal file
View File

Binary file not shown.

4
manifest.scm
View File

@ -5,7 +5,9 @@
(specifications->manifest
(list "guile"
"racket-minimal"
"openjdk"
"sdl2"
"sdl2-image"
"sdl2-ttf"
"sdl2-mixer"))
"sdl2-mixer"
"zig"))

172
retropikzel/pffi/v0.1.0/main.scm
View File

@ -31,6 +31,11 @@
(scheme file)
(scheme process-context)
(stklos)))
(kawa
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)))
(else (error "Implementation not supported by r7rs-pffi")))
(export pffi-call
pffi-types
@ -52,6 +57,33 @@
(define library-version "v0.1.0")
(cond-expand
(sagittarius #t)
(guile #t)
(racket #t)
(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)
(java.lang.Byte value))
((equal? type 'short)
(java.lang.Short value))
((equal? type 'int)
(java.lang.Integer value))
((equal? type 'long)
(java.lang.Long value))
((equal? type 'float)
(java.lang.Float value))
((equal? type 'double)
(java.lang.Double value))
((equal? type 'char)
(java.lang.Char value))
(else value))))))
(define platform-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
@ -93,23 +125,6 @@
double
pointer))
(define string-split
(lambda (str mark)
(let* ((str-l (string->list str))
(res (list))
(last-index 0)
(index 0)
(splitter (lambda (c)
(cond ((char=? c mark)
(begin
(set! res (append res (list (string-copy str last-index index))))
(set! last-index (+ index 1))))
((equal? (length str-l) (+ index 1))
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
(set! index (+ index 1)))))
(for-each splitter str-l)
res)))
(define auto-load-paths
(append
(cond-expand
@ -135,16 +150,6 @@
"/usr/lib/x86_64-linux-gnu"
"/usr/local/lib"))))))
(define memorysession #f)
(define linker #f)
(define symbol-lookup #f)
(define kebab-case->snake-case
(lambda (str) (string-map (lambda (c) (if (char=? c #\-) #\_ c)) str)))
(define pffi-type->native-type
(lambda (type)
(cond-expand
@ -248,6 +253,28 @@
((equal? type 'pointer) :pointer)
((equal? type 'string) :string)
((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)))))))
(define pffi-pointer?
@ -256,7 +283,11 @@
(sagittarius (pointer? object))
(guile (pointer? object))
(racket (cpointer? object))
(stklos (cpointer? object)))))
(stklos (cpointer? object))
(kawa (display "pffi-pointer? called with: ") ; TODO FIX
(write object)
(newline)
#f))))
;> ### pffi-call
;>
@ -317,7 +348,22 @@
types
native-type
shared-object)
vals)))))))
vals)))
(kawa
(let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
(of (class-methods java.lang.foreign.FunctionDescriptor 'of))
(function-descriptor (if (equal? type 'void)
(apply of-void types)
(apply of (append (list native-type) types))))
(method-handle (invoke linker
'downcallHandle
(invoke (invoke lookup
'find
(symbol->string name))
'orElseThrow)
function-descriptor))
(values-objects (map value->object vals (map car arguments))))
(invoke method-handle 'invokeWithArguments values-objects)))))))
(define pffi-size-of
(lambda (type)
@ -347,8 +393,8 @@
(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) ; FIX
)))
(stklos 4) ; TODO FIX
(kawa (invoke (pffi-type->native-type type) 'byteSize)))))
(define pffi-pointer-allocate
(lambda (size)
@ -356,43 +402,65 @@
(sagittarius (allocate-pointer size))
(guile (bytevector->pointer (make-bytevector size 0)))
(racket (malloc size))
(stklos (allocate-bytes size)))))
(stklos (allocate-bytes size))
(kawa (invoke arena 'allocate size 1)))))
(define pffi-pointer-null
(lambda ()
(cond-expand
(sagittarius (integer->pointer 0))
(guile (make-pointer 0))
(racket #f)
(stklos (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))))
(racket #f) ; In rackter #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)))))
(define pffi-string->pointer
(lambda (string-content)
(cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
(guile (string->pointer string-content))
(racket (cast string-content _string _pointer))
(stklos string-content))))
(stklos string-content)
(kawa (invoke arena 'allocateUtf8String string-content)))))
(define pffi-pointer->string
(lambda (pointer)
(cond-expand (sagittarius (pointer->string pointer))
(guile (pointer->string pointer))
(racket (cast pointer _pointer _string))
(cpointer->string pointer))))
(cpointer->string pointer)
(kawa (invoke pointer 'getString)))))
(define pffi-pointer->bytevector
(lambda (pointer size)
(cond-expand (sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size))
(racket (cast pointer _pointer _bytes))
(stklos (error "STKlos does not support pffi-pointer->bytevector")))))
(stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX
(kawa (invoke pointer 'toArray)))))
(define pffi-shared-object-load
(lambda (path)
(cond-expand (sagittarius (open-shared-library path))
(guile (load-foreign-library path #:lazy? #f))
(racket (ffi-lib path))
(stklos path))))
(stklos path)
(kawa
(let* ((library-file (make java.io.File path))
(file-name (invoke library-file 'getName))
(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
'libraryLookup
absolute-path
(invoke-static java.lang.foreign.Arena 'ofAuto)
))
;(invoke-static java.lang.System 'load absolute-path)
#t))
)))
(define pffi-shared-object-auto-load
(lambda (object-name additional-paths)
@ -442,15 +510,16 @@
(cond-expand (sagittarius (c-free pointer))
(guile #t)
(racket (free pointer))
(stklos (free-bytes pointer)))))
(stklos (free-bytes pointer))
(kawa (invoke pointer 'unload)))))
(define pffi-pointer-null?
(lambda (pointer)
(cond-expand (sagittarius (null-pointer? pointer))
(guile (null-pointer? pointer))
; #f is the null pointer on racket
(racket (not pointer))
(stklos (cpointer-null? pointer)))))
(racket (not pointer)) ; #f is the null pointer on racket
(stklos (cpointer-null? pointer))
(kawa (invoke pointer 'equals (pffi-pointer-null))))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
@ -501,8 +570,11 @@
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-set! pointer type offset value))
(stklos ())
)))
(stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
(kawa (invoke pointer
'set
(pffi-type->native-type type)
offset)))))
(define pffi-pointer-get
(lambda (pointer type offset)
@ -554,10 +626,18 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-ref pointer type offset)))))
(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)))))
(define pffi-pointer-deref
(lambda (pointer)
(cond-expand (sagittarius (deref pointer 0))
(guile (dereference-pointer pointer))
(racket #t))))))
(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
)))))

8
test/size-of-int.scm Normal file
View File

@ -0,0 +1,8 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(write (pffi-size-of 'int))
(newline)