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

Backup

This commit is contained in:
retropikzel 2024-05-08 18:06:54 +03:00
parent 0252836baf
commit 670041401f
5 changed files with 235 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
Makefile
View File

@ -1,103 +1,51 @@
VERSION=v0.1.0 VERSION=v0.1.0
RACKETEXE=${HOME}/.wine/drive_c/Program Files/Racket/racket.exe SASH=sash -r7 -L .
GUILE=guile --r7rs -L .
RACKET=racket -I r7rs --make -S $(shell pwd) --script
STKLOS=stklos -A .
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=".."
build: build-rkt documentation
build-rkt:
echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt
documentation: documentation:
schubert document schubert document
VERSION=${VERSION} bash doc/generate.sh > documentation.md VERSION=${VERSION} bash doc/generate.sh > documentation.md
test-size-of: test/import.scm: build
@echo "Sagittarius" ${SASH} $@
sash -r7 -L . test/size-of.scm ${GUILE} $@
@echo "Guile" #${RACKET} $@
guile --r7rs -L . test/size-of.scm #${STKLOS} $@
#@echo "Racket" ${KAWA} $@
#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: test/size-of.scm: build
sash -r7 -L . test/pointer-set-get.scm ${SASH} $@
java \ ${GUILE} $@
--add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ #${RACKET} $@
--add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ #${STKLOS} $@
--add-exports java.base/jdk.internal.foreign=ALL-UNNAMED \ ${KAWA} $@
--enable-native-access=ALL-UNNAMED \
--enable-preview \
-jar kawa.jar \
--r7rs \
--full-tailcalls \
-Dkawa.import.path=".." \
test/pointer-set-get.scm
test-sagittatius-sdl2: test/pointer-set-get.scm: build
sash -r7 -L . test/sdl2.scm ${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test-guile-hello: test/string-to-pointer-to-string.scm: build
guile --debug --r7rs -L . test/hello.scm ${SASH} $@
${GUILE} $@
test-guile-sdl2: #${RACKET} $@
guile --debug --r7rs -L . test/sdl2.scm #${STKLOS} $@
${KAWA} $@
build-rkt:
echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt
echo "#lang r7rs" > test/sdl2.rkt
cat test/sdl2.scm >> test/sdl2.rkt
test-racket-load: build-rkt
racket -I r7rs retropikzel/pffi/${VERSION}/main.rkt
test-racket-load-wine: build-rkt
wine64 ${RACKETEXE} -I r7rs retropikzel/pffi/${VERSION}/main.rkt
test-racket-hello: build-rkt
racket -S $(shell pwd) -I r7rs test/hello.scm
test-racket-hello-wine: build-rkt
wine64 ${RACKETEXE} -I r7rs -S $(shell pwd) -f test/hello.scm
test-racket-sdl2: build-rkt
racket -S $(shell pwd) test/sdl2.rkt
test-stklos-hello:
stklos -A . test/hello.scm
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 \
--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/string-to-pointer-to-string.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
test/sdl2.scm: build
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@

257
retropikzel/pffi/v0.1.0/main.rkt
View File

@ -22,12 +22,20 @@
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(only (racket base) (only (racket base) system-type)
system-type)
(compatibility mlist) (compatibility mlist)
(ffi unsafe)) (ffi unsafe)))
(stklos ) (stklos
) (import (scheme base)
(scheme write)
(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"))) (else (error "Implementation not supported by r7rs-pffi")))
(export pffi-call (export pffi-call
pffi-types pffi-types
@ -49,6 +57,31 @@
(define library-version "v0.1.0") (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 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 (define platform-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
@ -90,46 +123,9 @@
double double
pointer)) 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 (define auto-load-paths
(append (append
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows)
(append
(if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM"))
(list))
(if (get-environment-variable "WINDIR")
(list (get-environment-variable "WINDIR"))
(list))
(list ".")
(string-split (get-environment-variable "PATH") #\;))
(append
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
""))
(if (get-environment-variable "LD_LOAD_PATH")
(list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:)
(list))
(list "/lib/x86_64-linux-gnu"
"/usr/lib/x86_64-linux-gnu"
"/usr/local/lib"))))
(windows (windows
(append (append
(if (get-environment-variable "SYSTEM") (if (get-environment-variable "SYSTEM")
@ -152,16 +148,6 @@
"/usr/lib/x86_64-linux-gnu" "/usr/lib/x86_64-linux-gnu"
"/usr/local/lib")))))) "/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 (define pffi-type->native-type
(lambda (type) (lambda (type)
(cond-expand (cond-expand
@ -187,6 +173,7 @@
((equal? type 'float) 'float) ((equal? type 'float) 'float)
((equal? type 'double) 'double) ((equal? type 'double) 'double)
((equal? type 'pointer) 'void*) ((equal? type 'pointer) 'void*)
((equal? type 'string) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) (else (error "pffi-type->native-type -- No such pffi type" type))))
(guile (guile
@ -198,12 +185,9 @@
((equal? type 'uint32) uint32) ((equal? type 'uint32) uint32)
((equal? type 'int64) int64) ((equal? type 'int64) int64)
((equal? type 'uint64) uint64) ((equal? type 'uint64) uint64)
;((equal? type 'intptr) intptr)
;((equal? type 'uintptr) uintptr)
;((equal? type 'char) char) ;((equal? type 'char) char)
((equal? type 'char) int) ((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 'short) short)
((equal? type 'unsigned-short) unsigned-short) ((equal? type 'unsigned-short) unsigned-short)
((equal? type 'int) int) ((equal? type 'int) int)
@ -213,6 +197,7 @@
((equal? type 'float) float) ((equal? type 'float) float)
((equal? type 'double) double) ((equal? type 'double) double)
((equal? type 'pointer) '*) ((equal? type 'pointer) '*)
((equal? type 'string) '*)
((equal? type 'void) void) ((equal? type 'void) void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) (else (error "pffi-type->native-type -- No such pffi type" type))))
(racket (racket
@ -224,8 +209,6 @@
((equal? type 'uint32) _uint32) ((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64) ((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64) ((equal? type 'uint64) _uint64)
;((equal? type 'intptr) intptr)
;((equal? type 'uintptr) uintptr)
;((equal? type 'char) _int32) ;((equal? type 'char) _int32)
((equal? type 'char) _int) ((equal? type 'char) _int)
((equal? type 'unsigned-char) _int) ((equal? type 'unsigned-char) _int)
@ -238,7 +221,63 @@
((equal? type 'float) _float) ((equal? type 'float) _float)
((equal? type 'double) _double) ((equal? type 'double) _double)
((equal? type 'pointer) _pointer) ((equal? type 'pointer) _pointer)
((equal? type 'string) _pointer)
((equal? type 'void) _void) ((equal? type 'void) _void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(sktlos
(cond ((equal? type 'int8) :int)
((equal? type 'uint8) :uint)
((equal? type 'int16) :int)
((equal? type 'uint16) :uint)
((equal? type 'int32) :int)
((equal? type 'uint32) :uint)
((equal? type 'int64) :int)
((equal? type 'uint64) :uint)
((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar)
((equal? type 'short) :short)
((equal? type 'unsigned-short) :ushort)
((equal? type 'int) :int)
((equal? type 'unsigned-int) :uint)
((equal? type 'long) :long)
((equal? type 'unsigned-long) :ulong)
((equal? type 'float) :float)
((equal? type 'double) :double)
((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) (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))))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))))
(define pffi-pointer? (define pffi-pointer?
@ -246,7 +285,10 @@
(cond-expand (cond-expand
(sagittarius (pointer? object)) (sagittarius (pointer? object))
(guile (pointer? object)) (guile (pointer? object))
(racket (cpointer? object))))) (racket (cpointer? object))
(stklos (cpointer? object))
(kawa (string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))))
;> ### pffi-call ;> ### pffi-call
;> ;>
@ -279,7 +321,8 @@
(define pffi-call (define pffi-call
(lambda (shared-object name type arguments) (lambda (shared-object name type arguments)
(let ((types (map pffi-type->native-type (map car arguments))) (let ((types (map pffi-type->native-type (map car arguments)))
(vals (map cdr arguments))) (vals (map cdr arguments))
(native-type (pffi-type->native-type type)))
(cond-expand (cond-expand
(sagittarius (sagittarius
(apply (make-c-function shared-object (apply (make-c-function shared-object
@ -299,7 +342,29 @@
shared-object shared-object
(_cprocedure (mlist->list types) (_cprocedure (mlist->list types)
(pffi-type->native-type type))) (pffi-type->native-type type)))
vals)))))) vals))
(stklos
(stklos (apply (make-external-function
(symbol->string name)
types
native-type
shared-object)
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 (cdr (assoc 'linker shared-object))
'downcallHandle
(invoke (invoke (cdr (assoc 'lookup shared-object))
'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 (define pffi-size-of
(lambda (type) (lambda (type)
@ -313,8 +378,6 @@
((eq? type 'uint32) size-of-uint32_t) ((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t) ((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_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 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char) ((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short) ((eq? type 'short) size-of-short)
@ -325,48 +388,81 @@
((eq? type 'unsigned-long) size-of-unsigned-long) ((eq? type 'unsigned-long) size-of-unsigned-long)
((eq? type 'float) size-of-float) ((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double) ((eq? type 'double) size-of-double)
((eq? type 'string) size-of-void*)
((eq? type 'pointer) size-of-void*) ((eq? type 'pointer) size-of-void*)
(else (error "Can not get size of unknown type" type)))) (else (error "Can not get size of unknown type" type))))
(guile (sizeof (pffi-type->native-type type))) (guile (sizeof (pffi-type->native-type type)))
(racket (ctype-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) 'byteAlignment)))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)
(cond-expand (cond-expand
(sagittarius (allocate-pointer size)) (sagittarius (allocate-pointer size))
(guile (bytevector->pointer (make-bytevector size 0))) (guile (bytevector->pointer (make-bytevector size 0)))
(racket (malloc size))))) (racket (malloc size))
(stklos (allocate-bytes size))
(kawa (invoke arena 'allocate size 1)))))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(cond-expand (cond-expand
(sagittarius (integer->pointer 0)) (sagittarius (integer->pointer 0))
(guile (make-pointer 0)) (guile (make-pointer 0))
(racket #f)))) (racket #f) ; In racket #f is null pointer
(stklos (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p))
(kawa (static-field java.lang.foreign.MemorySegment 'NULL)))))
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content)))) (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
(guile (string->pointer string-content)) (guile (string->pointer string-content))
(racket (cast string-content _string _pointer))))) (racket (cast string-content _string _pointer))
(stklos string-content)
(kawa (invoke arena 'allocateUtf8String string-content)))))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (pointer->string pointer)) (cond-expand (sagittarius (pointer->string pointer))
(guile (pointer->string pointer)) (guile (pointer->string pointer))
(racket (cast pointer _pointer _string))))) (racket (cast pointer _pointer _string))
(stklos (cpointer->string pointer))
(kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))))
(define pffi-pointer->bytevector (define pffi-pointer->bytevector
(lambda (pointer size) (lambda (pointer size)
(cond-expand (sagittarius (pointer->bytevector pointer size)) (cond-expand (sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size)) (guile (pointer->bytevector pointer size))
(racket (cast pointer _pointer _bytes))))) (racket (cast pointer _pointer _bytes))
(stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX
(kawa (invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (path) (lambda (path)
(cond-expand (sagittarius (open-shared-library path)) (cond-expand (sagittarius (open-shared-library path))
(guile (load-foreign-library path #:lazy? #f)) (guile (load-foreign-library path #:lazy? #f))
(racket (ffi-lib path))))) (racket (ffi-lib 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))
(linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
(lookup (invoke-static java.lang.foreign.SymbolLookup
'libraryLookup
absolute-path
arena)))
(list (cons 'linker linker)
(cons 'lookup lookup)))))))
(define pffi-shared-object-auto-load (define pffi-shared-object-auto-load
(lambda (object-name additional-paths) (lambda (object-name additional-paths)
@ -415,14 +511,17 @@
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (c-free pointer)) (cond-expand (sagittarius (c-free pointer))
(guile #t) (guile #t)
(racket (free pointer))))) (racket (free pointer))
(stklos (free-bytes pointer))
(kawa (invoke pointer 'unload)))))
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (null-pointer? pointer)) (cond-expand (sagittarius (null-pointer? pointer))
(guile (null-pointer? pointer)) (guile (null-pointer? pointer))
(racket (not pointer) ; #f is the null pointer on racket (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! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
@ -472,7 +571,9 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset))
))) )))
(racket (ptr-set! pointer type offset value))))) (racket (ptr-set! pointer type offset 'abs value))
(stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -524,10 +625,14 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset))
))) )))
(racket (ptr-ref pointer type offset))))) (racket (ptr-ref pointer type 'abs 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 (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (deref pointer 0)) (cond-expand (sagittarius (deref pointer 0))
(guile (dereference-pointer pointer)) (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 (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))

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

@ -21,8 +21,7 @@
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(only (racket base) (only (racket base) system-type)
system-type)
(compatibility mlist) (compatibility mlist)
(ffi unsafe))) (ffi unsafe)))
(stklos (stklos
@ -427,7 +426,7 @@
(cond-expand (sagittarius (pointer->string pointer)) (cond-expand (sagittarius (pointer->string pointer))
(guile (pointer->string pointer)) (guile (pointer->string pointer))
(racket (cast pointer _pointer _string)) (racket (cast pointer _pointer _string))
(cpointer->string pointer) (stklos (cpointer->string pointer))
(kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0))))) (kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))))
(define pffi-pointer->bytevector (define pffi-pointer->bytevector
@ -571,7 +570,7 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset))
))) )))
(racket (ptr-set! pointer type offset value)) (racket (ptr-set! pointer type offset 'abs value))
(stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value))))) (kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
@ -625,7 +624,7 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset))
))) )))
(racket (ptr-ref pointer type offset)) (racket (ptr-ref pointer type 'abs offset))
(stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX (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)))))

8
test/import.scm Normal file
View File

@ -0,0 +1,8 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(display "Hello")
(newline)

33
test/sdl2.rkt
View File

@ -1,33 +0,0 @@
#lang r7rs
(import (scheme base)
(scheme write)
(scheme read)
(retropikzel pffi v0.1.0 main))
(define sdl2 (pffi-shared-object-auto-load "SDL2" (list)))
(pffi-call sdl2 'SDL_Init 'int '((int . 32)))
(define window (pffi-call sdl2
'SDL_CreateWindow
'pointer
(list (cons 'pointer (pffi-string->pointer "Testing pffi"))
(cons 'int 1)
(cons 'int 1)
(cons 'int 400)
(cons 'int 400)
(cons 'int 4))))
(define renderer (pffi-call sdl2
'SDL_CreateRenderer
'pointer
(list (cons 'pointer window)
(cons 'int -1)
(cons 'int 2))))
(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer)))
(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer)))
(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000))))