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

Added pffi-lambda

This commit is contained in:
retropikzel 2024-05-15 19:48:36 +03:00
parent e5cf7c23ca
commit 6138e053ee
11 changed files with 324 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Makefile
View File

@ -2,7 +2,7 @@ VERSION=v0.1.0
SASH=sash -r7 -L .
GUILE=guile --r7rs -L .
RACKET=racket -I r7rs --make -S $(shell pwd) --script
STKLOS=stklos -A .
STKLOS=stklos -A . -f
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
@ -51,6 +51,13 @@ test/string-to-pointer-to-string.scm: build
#${STKLOS} $@
${KAWA} $@
test/pffi-lambda.scm: build
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/sdl2.scm: build
${SASH} $@
${GUILE} $@

27
documentation.md
View File

@ -2,6 +2,12 @@
## Procedures
# pffi
## Procedures
### pffi-call
Arguments:
@ -32,3 +38,24 @@ Example:
(cons 'int 4))
### pffi-shared-object-load
Arguments:
- path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
Returns:
### pffi-shared-object-auto-load
Arguments:
- object-name (symbol)
- The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
- addition-paths (list (string)...)
- Any additional paths you want to search for the library
Returns:
- (object) Shared object, the type depends on the implementation

1
manifest.scm
View File

@ -6,6 +6,7 @@
(list "guile"
"racket-minimal"
"openjdk"
"curl"
"sdl2"
"sdl2-image"
"sdl2-ttf"

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

@ -1,4 +1,5 @@
#lang r7rs
;> # pffi
(define-library
(retropikzel pffi v0.1.0 main)
(cond-expand
@ -37,8 +38,10 @@
(scheme file)
(scheme process-context)))
(else (error "Implementation not supported by r7rs-pffi")))
(export pffi-call
pffi-types
(export pffi-shared-object-auto-load
pffi-shared-object-load
pffi-call
pffi-lambda
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
@ -48,8 +51,6 @@
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-shared-object-load
pffi-shared-object-auto-load
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
@ -82,21 +83,26 @@
(java.lang.Char value))
(else value))))))
;> ## Procedures
(define platform-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(stklos ".so")
(windows ".dll")
(else ".so")))
(define platform-version-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
(stklos ".so")
(windows ".dll")
(else ".so.0")))
(define platform-lib-prefix
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(stklos ".so")
(windows "")
(else "lib")))
@ -123,6 +129,23 @@
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
@ -138,11 +161,14 @@
(string-split (get-environment-variable "PATH") #\;)))
(else
(append
; Guix
(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") #\:)
"")
"/run/current-system/profile/lib")
; Debian
(if (get-environment-variable "LD_LIBRARY_PATH")
(list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:))
(list))
(list "/lib/x86_64-linux-gnu"
"/usr/lib/x86_64-linux-gnu"
@ -366,6 +392,48 @@
(values-objects (map value->object vals (map car arguments))))
(invoke method-handle 'invokeWithArguments values-objects)))))))
(define pffi-lambda
(lambda (shared-object name return-type argument-types)
(let ((types (map pffi-type->native-type argument-types))
(native-return-type (pffi-type->native-type return-type)))
(cond-expand
(sagittarius
(make-c-function shared-object
native-return-type
name
types))
(guile
(foreign-library-function shared-object
(symbol->string name)
#:return-type native-return-type
#:arg-types types))
(racket
(get-ffi-obj name
shared-object
(_cprocedure (mlist->list types)
native-return-type)))
(stklos
(stklos (make-external-function
(symbol->string name)
types
native-return-type
shared-object)))
(kawa
(let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
(of (class-methods java.lang.foreign.FunctionDescriptor 'of))
(function-descriptor (if (equal? return-type 'void)
(apply of-void types)
(apply of (append (list native-return-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)))
(lambda vals
(invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))))
(define pffi-size-of
(lambda (type)
(cond-expand
@ -416,54 +484,75 @@
(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)
(kawa (invoke arena 'allocateUtf8String 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)
(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))
(stklos (cpointer->string pointer))
(kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))))
(cond-expand
(sagittarius (pointer->string pointer))
(guile (pointer->string pointer))
(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
(lambda (pointer size)
(cond-expand (sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size))
(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))))))
(cond-expand
(sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size))
(racket (cast pointer _pointer _bytes))
(stklos (bytevector)) ; TODO FIX
(kawa (invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))))
;> ### pffi-shared-object-load
;>
;> Arguments:
;> - path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
;>
;> Returns:
;>
(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)
(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))
(cond-expand
(sagittarius (open-shared-library path))
(guile (load-foreign-library path #:lazy? #f))
(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)))))))
(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)))))))
;> ### pffi-shared-object-auto-load
;>
;> Arguments:
;> - object-name (symbol)
;> - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
;> - addition-paths (list (string)...)
;> - Any additional paths you want to search for the library
;>
;> Returns:
;> - (object) Shared object, the type depends on the implementation
(define pffi-shared-object-auto-load
(lambda (object-name additional-paths)
(let* ((paths (append auto-load-paths additional-paths))
@ -509,19 +598,21 @@
(define pffi-pointer-free
(lambda (pointer)
(cond-expand (sagittarius (c-free pointer))
(guile #t)
(racket (free pointer))
(stklos (free-bytes pointer))
(kawa (invoke pointer 'unload)))))
(cond-expand
(sagittarius (c-free pointer))
(guile #t)
(racket (free 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))
(racket (not pointer)) ; #f is the null pointer on racket
(stklos (cpointer-null? pointer))
(kawa (invoke pointer 'equals (pffi-pointer-null))))))
(cond-expand
(sagittarius (null-pointer? pointer))
(guile (null-pointer? 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)
@ -572,7 +663,7 @@
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-set! pointer type offset 'abs value))
(stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
(define pffi-pointer-get
@ -626,13 +717,14 @@
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-ref pointer type 'abs offset))
(stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX
(stklos #f) ; 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 (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)))))))
(cond-expand
(sagittarius (deref pointer 0))
(guile (dereference-pointer pointer))
(racket #f) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))

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

@ -40,6 +40,7 @@
(export pffi-shared-object-auto-load
pffi-shared-object-load
pffi-call
pffi-lambda
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
@ -86,18 +87,21 @@
(define platform-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(stklos ".so")
(windows ".dll")
(else ".so")))
(define platform-version-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
(stklos ".so")
(windows ".dll")
(else ".so.0")))
(define platform-lib-prefix
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(stklos ".so")
(windows "")
(else "lib")))
@ -387,6 +391,48 @@
(values-objects (map value->object vals (map car arguments))))
(invoke method-handle 'invokeWithArguments values-objects)))))))
(define pffi-lambda
(lambda (shared-object name return-type argument-types)
(let ((types (map pffi-type->native-type argument-types))
(native-return-type (pffi-type->native-type return-type)))
(cond-expand
(sagittarius
(make-c-function shared-object
native-return-type
name
types))
(guile
(foreign-library-function shared-object
(symbol->string name)
#:return-type native-return-type
#:arg-types types))
(racket
(get-ffi-obj name
shared-object
(_cprocedure (mlist->list types)
native-return-type)))
(stklos
(stklos (make-external-function
(symbol->string name)
types
native-return-type
shared-object)))
(kawa
(let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
(of (class-methods java.lang.foreign.FunctionDescriptor 'of))
(function-descriptor (if (equal? return-type 'void)
(apply of-void types)
(apply of (append (list native-return-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)))
(lambda vals
(invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))))
(define pffi-size-of
(lambda (type)
(cond-expand
@ -437,30 +483,33 @@
(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)
(kawa (invoke arena 'allocateUtf8String 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)
(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))
(stklos (cpointer->string pointer))
(kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))))
(cond-expand
(sagittarius (pointer->string pointer))
(guile (pointer->string pointer))
(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
(lambda (pointer size)
(cond-expand (sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size))
(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))))))
(cond-expand
(sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size))
(racket (cast pointer _pointer _bytes))
(stklos (bytevector)) ; TODO FIX
(kawa (invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))))
;> ### pffi-shared-object-load
;>
@ -471,26 +520,27 @@
;>
(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)
(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))
(cond-expand
(sagittarius (open-shared-library path))
(guile (load-foreign-library path #:lazy? #f))
(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)))))))
(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)))))))
;> ### pffi-shared-object-auto-load
;>
@ -547,19 +597,21 @@
(define pffi-pointer-free
(lambda (pointer)
(cond-expand (sagittarius (c-free pointer))
(guile #t)
(racket (free pointer))
(stklos (free-bytes pointer))
(kawa (invoke pointer 'unload)))))
(cond-expand
(sagittarius (c-free pointer))
(guile #t)
(racket (free 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))
(racket (not pointer)) ; #f is the null pointer on racket
(stklos (cpointer-null? pointer))
(kawa (invoke pointer 'equals (pffi-pointer-null))))))
(cond-expand
(sagittarius (null-pointer? pointer))
(guile (null-pointer? 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)
@ -610,7 +662,7 @@
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-set! pointer type offset 'abs value))
(stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
(define pffi-pointer-get
@ -664,13 +716,14 @@
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-ref pointer type 'abs offset))
(stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX
(stklos #f) ; 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 (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)))))))
(cond-expand
(sagittarius (deref pointer 0))
(guile (dereference-pointer pointer))
(racket #f) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))

17
retropikzel/pffi/v0.1.0/schubert-doc.md
View File

@ -1,4 +1,4 @@
# pffi test
# pffi
## Procedures
@ -34,9 +34,24 @@ Example:
(cons 'int 4))
### pffi-shared-object-load
Arguments:
- path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
Returns:
### pffi-shared-object-auto-load
Arguments:
- object-name (symbol)
- The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
- addition-paths (list (string)...)
- Any additional paths you want to search for the library
Returns:
- (object) Shared object, the type depends on the implementation

BIN
test/SDL2.dll Executable file
View File

Binary file not shown.

BIN
test/SDL2_image.dll Executable file
View File

Binary file not shown.

BIN
test/SDL2_mixer.dll Executable file
View File

Binary file not shown.

BIN
test/SDL2_ttf.dll Executable file
View File

Binary file not shown.

11
test/pffi-lambda.scm Normal file
View File

@ -0,0 +1,11 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(define libcurl (pffi-shared-object-auto-load "curl" (list)))
(define curl-version (pffi-lambda libcurl 'curl_version 'string (list)))
(write (pffi-pointer->string (curl-version)))
(newline)