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

Restructuring of code for different implementations

This commit is contained in:
retropikzel 2024-05-16 22:18:10 +03:00
parent 6138e053ee
commit 8b0057474e
20 changed files with 1736 additions and 1188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored
View File

@ -1,2 +1,8 @@
*.swp
docuptmp
*.log
*.c
*.so
*.o
*.meta
old

97
Makefile
View File

@ -1,64 +1,91 @@
.PHONY: test/import.scm test/import.scm test/pffi-define.scm
CHICKEN_INSTALL_REPOSITORY=${HOME}/.local/share/chicken
ENV_CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}
VERSION=v0.1.0
SASH=sash -r7 -L .
GUILE=guile --r7rs -L .
SASH=sash -c -r7 -L .
GUILE=GUILE_AUTO_COMPILE=0 guile --no-auto-compile --fresh-auto-compile --r7rs -L .
RACKET=racket -I r7rs --make -S $(shell pwd) --script
STKLOS=stklos -A . -f
STKLOS=STKLOS_FRAMES=200 stklos -A . --compiler-flags='+line-info,+time-display,unroll-iterations=3' -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=".."
CYCLONE=cyclone -t -A .
GAMBIT=gsc -:r7rs,search=$(shell pwd) test/
CHICKEN=CHICKEN_INCLUDE_PATH=$(shell pwd):$(shell pwd)/retropikzel/pffi/v0.1.0/ CHICKEN_REPOSITORY_PATH=${ENV_CHICKEN_REPOSITORY_PATH}:${CHICKEN_INSTALL_REPOSITORY} csc -X r7rs -R r7rs
build: build-rkt documentation
build: build-rkt build-main-scm
update-documentation:
schubert document
mkdir -p docuptmp
cd docuptmp && git clone git@codeberg.org:r7rs-pffi/pffi.wiki.git
cp retropikzel/pffi/${VERSION}/schubert-doc.md docuptmp/pffi.wiki/Documentation.md
cd docuptmp/pffi.wiki && git add Documentation.md ; git commit -m "Update documentation" ; git push
rm -rf docutmp
chicken-install:
mkdir -p ${CHICKEN_INSTALL_REPOSITORY}
CHICKEN_INSTALL_REPOSITORY=${CHICKEN_INSTALL_REPOSITORY} \
CHICKEN_REPOSITORY_PATH=${ENV_CHICKEN_REPOSITORY_PATH}:${CHICKEN_INSTALL_REPOSITORY} \
chicken-install r7rs
build-rkt:
echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt
cat retropikzel/pffi/${VERSION}/main.sld >> retropikzel/pffi/${VERSION}/main.rkt
build-main-scm:
cp retropikzel/pffi/${VERSION}/main.sld retropikzel/pffi/${VERSION}/main.scm
update-documentation:
schubert document
mkdir -p docutmp
cd docutmp && git clone git@codeberg.org:r7rs-pffi/pffi.wiki.git
cp retropikzel/pffi/${VERSION}/schubert-doc.md docutmp/pffi.wiki/Documentation.md
cd docutmp/pffi.wiki && git add Documentation.md ; git commit -m "Update documentation" ; git push
rm -rf docutmp
documentation:
schubert document
VERSION=${VERSION} bash doc/generate.sh > documentation.md
test/import.scm: build
test/import.scm: clean build
${SASH} $@
${GUILE} $@
#${RACKET} $@
${STKLOS} $@
${KAWA} $@
${CYCLONE} $@ && test/import
#${GAMBIT} $@
#${CHICKEN} $@
test/pffi-define.scm: clean build
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
#${CYCLONE} $@ && test/pffi-define
test/pffi-define.scm: build
${CYCLONE} $@ && test/pffi-define
test/size-of.scm:
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/size-of.scm: build
test/pointer-set-get.scm:
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/pointer-set-get.scm: build
test/string-to-pointer-to-string.scm:
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/string-to-pointer-to-string.scm: build
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/pffi-lambda.scm: build
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/sdl2.scm: build
test/sdl2.scm:
${SASH} $@
${GUILE} $@
#${RACKET} $@
@ -66,4 +93,14 @@ test/sdl2.scm: build
${KAWA} $@
clean:
rm -rf docuptmp
rm -rf docutmp
rm -rf retropikzel/pffi/${VERSION}/*.c
rm -rf retropikzel/pffi/${VERSION}/*.o
rm -rf retropikzel/pffi/${VERSION}/*.so
rm -rf retropikzel/pffi/${VERSION}/*.meta
rm -rf test/*.c
rm -rf test/*.o
rm -rf test/*.so
rm -rf test/*.meta
rm -rf test/import
rm -rf test/pffi-define

7
manifest.scm
View File

@ -5,10 +5,15 @@
(specifications->manifest
(list "guile"
"racket-minimal"
"gambit-c"
"chicken"
"chibi-scheme"
"openjdk"
"curl"
"sdl2"
"sdl2-image"
"sdl2-ttf"
"sdl2-mixer"
"zig"))
"ck"
"zig"
"gcc-toolchain"))

84
retropikzel/pffi/v0.1.0/chibi.scm Normal file
View File

@ -0,0 +1,84 @@
(define-library
(retropikzel pffi v0.1.0 chibi)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(error "Not defined")))
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-pointer->bytevector
(lambda (pointer size)
(error "Not defined")))
(define pffi-shared-object-load
(lambda (header path)
(error "Not defined")))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))

84
retropikzel/pffi/v0.1.0/chicken.scm Normal file
View File

@ -0,0 +1,84 @@
(define-library
(retropikzel pffi v0.1.0 chicken)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(error "Not defined")))
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-pointer->bytevector
(lambda (pointer size)
(error "Not defined")))
(define pffi-shared-object-load
(lambda (header path)
(error "Not defined")))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))

119
retropikzel/pffi/v0.1.0/cyclone.sld Normal file
View File

@ -0,0 +1,119 @@
(define-library
(retropikzel pffi v0.1.0 cyclone)
(import (scheme base)
(scheme write)
(scheme file)
(scheme eval)
(scheme process-context)
(scheme eval)
(cyclone foreign)
(scheme cyclone primitives))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) int)
((equal? type 'uint8) int)
((equal? type 'int16) int)
((equal? type 'uint16) int)
((equal? type 'int32) int)
((equal? type 'uint32) int)
((equal? type 'int64) int)
((equal? type 'uint64) int)
((equal? type 'char) char)
((equal? type 'unsigned-char) char)
((equal? type 'short) int)
((equal? type 'unsigned-short) int)
((equal? type 'int) int)
((equal? type 'unsigned-int) int)
((equal? type 'long) int)
((equal? type 'unsigned-long) int)
((equal? type 'float) float)
((equal? type 'double) double)
((equal? type 'pointer) opaque)
((equal? type 'string) string)
((equal? type 'void) c-void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define msg)
;(define-c t "(void *data, int argc, closure _, object k, object h)" "puts(string_str(h));")
;(c-define puts int "puts" string)
(c-code "char* buffer[1000]; fgets(buffer, 1000, stdin); puts(buffer);")
#t
)
)
)
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-pointer->bytevector
(lambda (pointer size)
(error "Not defined")))
(define-syntax pffi-shared-object-load
(syntax-rules ()
((when headers shared-object additional-paths)
)))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))

84
retropikzel/pffi/v0.1.0/empty.scm Normal file
View File

@ -0,0 +1,84 @@
(define-library
(retropikzel pffi v0.1.0 empty)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(error "Not defined")))
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-pointer->bytevector
(lambda (pointer size)
(error "Not defined")))
(define pffi-shared-object-load
(lambda (header path)
(error "Not defined")))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))

94
retropikzel/pffi/v0.1.0/gambit.scm Normal file
View File

@ -0,0 +1,94 @@
(define-library
(retropikzel pffi v0.1.0 gambit)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(error "Not defined")))
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(c-define scheme-name
(pffi-type->native-type return-type)
(symbol->string c-name)
string
)
)))
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-pointer->bytevector
(lambda (pointer size)
(error "Not defined")))
(define-syntax pffi-shared-object-load
(syntax-rules ()
((header path)
(c-declare (string-append "#include <" header ">")))
;(error "Not defined")
))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))

159
retropikzel/pffi/v0.1.0/guile.scm Normal file
View File

@ -0,0 +1,159 @@
(define-library
(retropikzel pffi v0.1.0 guile)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) int8)
((equal? type 'uint8) uint8)
((equal? type 'int16) int16)
((equal? type 'uint16) uint16)
((equal? type 'int32) int32)
((equal? type 'uint32) uint32)
((equal? type 'int64) int64)
((equal? type 'uint64) uint64)
;((equal? type 'char) char)
((equal? type 'char) int)
((equal? type 'unsigned-char) int)
((equal? type 'short) short)
((equal? type 'unsigned-short) unsigned-short)
((equal? type 'int) int)
((equal? type 'unsigned-int) unsigned-int)
((equal? type 'long) long)
((equal? type 'unsigned-long) unsigned-long)
((equal? type 'float) float)
((equal? type 'double) double)
((equal? type 'pointer) '*)
((equal? type 'string) '*)
((equal? type 'void) void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer?
(lambda (object)
(pointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(foreign-library-function shared-object
(symbol->string c-name)
#:return-type (pffi-type->native-type return-type)
#:arg-types (map pffi-type->native-type argument-types))))))
(define pffi-size-of
(lambda (type)
(sizeof (pffi-type->native-type type))))
(define pffi-pointer-allocate
(lambda (size)
(bytevector->pointer (make-bytevector size 0))))
(define pffi-pointer-null
(lambda ()
(make-pointer 0)))
(define pffi-string->pointer
(lambda (string-content)
(string->pointer string-content)))
(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-pointer->bytevector
(lambda (pointer size)
(pointer->bytevector pointer size)))
(define pffi-shared-object-load
(lambda (header path)
(load-foreign-library path)))
(define pffi-pointer-free
(lambda (pointer)
#t))
(define pffi-pointer-null?
(lambda (pointer)
(null-pointer? pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
((equal? native-type uint8) (bytevector-u8-set! p offset value))
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-set! (pointer->string pointer) offset value))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
))))
(define pffi-pointer-get
(lambda (pointer type offset)
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
((equal? native-type uint8) (bytevector-u8-ref p offset))
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-ref (pointer->string pointer) offset))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
))
))
(define pffi-pointer-deref
(lambda (pointer)
(dereference-pointer pointer)))))

162
retropikzel/pffi/v0.1.0/kawa.scm Normal file
View File

@ -0,0 +1,162 @@
(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 pffi-type->native-type
(lambda (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)
(string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(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 (map pffi-type->native-type argument-types))
(apply of (append (list (pffi-type->native-type return-type)) (map pffi-type->native-type argument-types)))))
(method-handle (invoke (cdr (assoc 'linker shared-object))
'downcallHandle
(invoke (invoke (cdr (assoc 'lookup shared-object))
'find
(symbol->string c-name))
'orElseThrow)
function-descriptor)))
(lambda vals
(invoke method-handle 'invokeWithArguments (map value->object vals argument-types))))))))
(define pffi-size-of
(lambda (type)
(invoke (pffi-type->native-type type) 'byteAlignment)))
(define pffi-pointer-allocate
(lambda (size)
(invoke arena 'allocate size 1)))
(define pffi-pointer-null
(lambda ()
(static-field java.lang.foreign.MemorySegment 'NULL)))
(define pffi-string->pointer
(lambda (string-content)
(invoke arena 'allocateUtf8String string-content)))
(define pffi-pointer->string
(lambda (pointer)
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))
(define pffi-pointer->bytevector
(lambda (pointer size)
(invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))
(define pffi-shared-object-load
(lambda (header path)
(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-pointer-free
(lambda (pointer)
(invoke pointer 'unload)))
(define pffi-pointer-null?
(lambda (pointer)
(invoke pointer 'equals (pffi-pointer-null))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(invoke pointer 'set (pffi-type->native-type type) offset value)))
(define pffi-pointer-get
(lambda (pointer type offset)
(invoke pointer 'get (pffi-type->native-type type) offset)))
(define pffi-pointer-deref
(lambda (pointer)
(invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))

25
retropikzel/pffi/v0.1.0/kawa.sld Normal file
View File

@ -0,0 +1,25 @@
(define-library
(retropikzel pffi v0.1.0 guile)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 kawa))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
))

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

@ -1,5 +1,7 @@
#lang r7rs
;> # pffi
;> ## Procedures
(define-library
(retropikzel pffi v0.1.0 main)
(cond-expand
@ -8,40 +10,58 @@
(scheme write)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius)))
(retropikzel pffi v0.1.0 sagittarius)))
(guile
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library)))
(retropikzel pffi v0.1.0 guile)))
(racket
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
(compatibility mlist)
(ffi unsafe)))
(retropikzel pffi v0.1.0 racket)))
(stklos
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos)))
(stklos)
(retropikzel pffi v0.1.0 stklos)))
(kawa
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)))
(else (error "Implementation not supported by r7rs-pffi")))
(cyclone
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 cyclone)))
(gambit
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 gambit)))
(chicken
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chicken)))
(chibi
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chibi))))
(export pffi-shared-object-auto-load
pffi-shared-object-load
pffi-call
pffi-lambda
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
@ -56,53 +76,27 @@
pffi-pointer-deref)
(begin
(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 library-version "v0.1.0")
;> ## 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")))
@ -174,344 +168,6 @@
"/usr/lib/x86_64-linux-gnu"
"/usr/local/lib"))))))
(define pffi-type->native-type
(lambda (type)
(cond-expand
(sagittarius
(cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32_t)
((equal? type 'uint32) 'uint32_t)
((equal? type 'int64) 'int64_t)
((equal? type 'uint64) 'uint64_t)
((equal? type 'intptr) 'intptr_t)
((equal? type 'uintptr) 'uintptr_t)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'void*)
((equal? type 'string) 'void*)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(guile
(cond ((equal? type 'int8) int8)
((equal? type 'uint8) uint8)
((equal? type 'int16) int16)
((equal? type 'uint16) uint16)
((equal? type 'int32) int32)
((equal? type 'uint32) uint32)
((equal? type 'int64) int64)
((equal? type 'uint64) uint64)
;((equal? type 'char) char)
((equal? type 'char) int)
((equal? type 'unsigned-char) int)
((equal? type 'short) short)
((equal? type 'unsigned-short) unsigned-short)
((equal? type 'int) int)
((equal? type 'unsigned-int) unsigned-int)
((equal? type 'long) long)
((equal? type 'unsigned-long) unsigned-long)
((equal? type 'float) float)
((equal? type 'double) double)
((equal? type 'pointer) '*)
((equal? type 'string) '*)
((equal? type 'void) void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(racket
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64)
;((equal? type 'char) _int32)
((equal? type 'char) _int)
((equal? type 'unsigned-char) _int)
((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) _pointer)
((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)))))))
(define pffi-pointer?
(lambda (object)
(cond-expand
(sagittarius (pointer? object))
(guile (pointer? object))
(racket (cpointer? object))
(stklos (cpointer? object))
(kawa (string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))))
;> ### pffi-call
;>
;> Arguments:
;>
;> - shared-object (object)
;> - Shared object returned by pffi-shared-object-load or pffi-shared-object-auto-load
;> - name (symbol)
;> - Name of the C function you want to call
;> - type (symbol)
;> - Return type of the C function you want to call
;> - arguments (list (cons type value)...)
;> - Arguments you want to pass to the C function as pairs of type and value
;>
;> Example:
;>
;> (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 "Hello"))
;> (cons 'int 1)
;> (cons 'int 1)
;> (cons 'int 400)
;> (cons 'int 400)
;> (cons 'int 4))
(define pffi-call
(lambda (shared-object name type arguments)
(let ((types (map pffi-type->native-type (map car arguments)))
(vals (map cdr arguments))
(native-type (pffi-type->native-type type)))
(cond-expand
(sagittarius
(apply (make-c-function shared-object
(pffi-type->native-type type)
name
types)
vals))
(guile
(apply
(foreign-library-function shared-object
(symbol->string name)
#:return-type (pffi-type->native-type type)
#:arg-types types)
vals))
(racket
(apply (get-ffi-obj name
shared-object
(_cprocedure (mlist->list types)
(pffi-type->native-type type)))
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-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
(sagittarius
(cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_t)
((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) size-of-long)
((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) 'byteAlignment)))))
(define pffi-pointer-allocate
(lambda (size)
(cond-expand
(sagittarius (allocate-pointer size))
(guile (bytevector->pointer (make-bytevector size 0)))
(racket (malloc 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) ; 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
(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)))))
(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)))))
(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 (bytevector)) ; TODO FIX
(kawa (invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))))
;> ### pffi-shared-object-load
;>
;> Arguments:
@ -519,29 +175,9 @@
;>
;> 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))
(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
;>
@ -553,178 +189,55 @@
;>
;> 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))
(shared-object #f))
(for-each
(lambda (path)
(if (not shared-object)
(let ((object-path
(string-append path
"/"
object-name
platform-file-extension))
(object-version-path
(string-append path
"/"
object-name
platform-version-file-extension))
(object-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-file-extension))
(object-version-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-version-file-extension)))
(cond
((file-exists? object-path)
(set! shared-object (pffi-shared-object-load object-path)))
((file-exists? object-version-path)
(set! shared-object (pffi-shared-object-load object-version-path)))
((file-exists? object-lib-path)
(set! shared-object (pffi-shared-object-load object-lib-path)))
((file-exists? object-version-lib-path)
(set! shared-object (pffi-shared-object-load object-version-lib-path)))))))
paths)
(if (not shared-object)
(error "Could not load shared object" object-name)
shared-object))))
(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)))))
(define-syntax pffi-shared-object-auto-load
(syntax-rules ()
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))
(for-each
(lambda (path)
(if (not shared-object)
(let ((object-path
(string-append path
"/"
object-name
platform-file-extension))
(object-version-path
(string-append path
"/"
object-name
platform-version-file-extension))
(object-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-file-extension))
(object-version-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-version-file-extension)))
(cond
((file-exists? object-path)
(set! shared-object (pffi-shared-object-load headers object-path)))
((file-exists? object-version-path)
(set! shared-object (pffi-shared-object-load headers object-version-path)))
((file-exists? object-lib-path)
(set! shared-object (pffi-shared-object-load headers object-lib-path)))
((file-exists? object-version-lib-path)
(set! shared-object (pffi-shared-object-load headers object-version-lib-path)))))))
paths)
(if (not shared-object)
(error "Could not load shared object" object-name)
shared-object)))))))
(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))))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond-expand
(sagittarius
(let ((p pointer))
(cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value))
((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value))
((equal? type 'char) (pointer-set-c-char! p offset value))
((equal? type 'short) (pointer-set-c-short! p offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
((equal? type 'int) (pointer-set-c-int! p offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
((equal? type 'long) (pointer-set-c-long! p offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
((equal? type 'float) (pointer-set-c-float! p offset value))
((equal? type 'double) (pointer-set-c-double! p offset value))
((equal? type 'void) (pointer-set-c-void*! p offset value)))))
(guile (let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
((equal? native-type uint8) (bytevector-u8-set! p offset value))
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-set! (pointer->string pointer) offset value))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-set! pointer type offset 'abs value))
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond-expand
(sagittarius
(let ((p pointer)
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
((equal? native-type 'char) (pointer-ref-c-char p offset))
((equal? native-type 'short) (pointer-set-c-short p offset value))
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type 'int) (pointer-ref-c-int p offset))
((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
((equal? native-type 'long) (pointer-ref-c-long p offset))
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
((equal? native-type 'float) (pointer-ref-c-float p offset))
((equal? native-type 'double) (pointer-ref-c-double p offset))
((equal? native-type 'void*) (pointer-ref-c-void* p offset)))))
(guile
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
((equal? native-type uint8) (bytevector-u8-ref p offset))
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-ref (pointer->string pointer) offset))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-ref pointer type 'abs offset))
(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 #f) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))
(cond-expand
(kawa
(include "kawa.scm"))
(else #t))))

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

@ -1,4 +1,6 @@
;> # pffi
;> ## Procedures
(define-library
(retropikzel pffi v0.1.0 main)
(cond-expand
@ -7,40 +9,58 @@
(scheme write)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius)))
(retropikzel pffi v0.1.0 sagittarius)))
(guile
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library)))
(retropikzel pffi v0.1.0 guile)))
(racket
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
(compatibility mlist)
(ffi unsafe)))
(retropikzel pffi v0.1.0 racket)))
(stklos
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos)))
(stklos)
(retropikzel pffi v0.1.0 stklos)))
(kawa
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)))
(else (error "Implementation not supported by r7rs-pffi")))
(cyclone
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 cyclone)))
(gambit
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 gambit)))
(chicken
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chicken)))
(chibi
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chibi))))
(export pffi-shared-object-auto-load
pffi-shared-object-load
pffi-call
pffi-lambda
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
@ -55,53 +75,27 @@
pffi-pointer-deref)
(begin
(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 library-version "v0.1.0")
;> ## 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")))
@ -173,344 +167,6 @@
"/usr/lib/x86_64-linux-gnu"
"/usr/local/lib"))))))
(define pffi-type->native-type
(lambda (type)
(cond-expand
(sagittarius
(cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32_t)
((equal? type 'uint32) 'uint32_t)
((equal? type 'int64) 'int64_t)
((equal? type 'uint64) 'uint64_t)
((equal? type 'intptr) 'intptr_t)
((equal? type 'uintptr) 'uintptr_t)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'void*)
((equal? type 'string) 'void*)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(guile
(cond ((equal? type 'int8) int8)
((equal? type 'uint8) uint8)
((equal? type 'int16) int16)
((equal? type 'uint16) uint16)
((equal? type 'int32) int32)
((equal? type 'uint32) uint32)
((equal? type 'int64) int64)
((equal? type 'uint64) uint64)
;((equal? type 'char) char)
((equal? type 'char) int)
((equal? type 'unsigned-char) int)
((equal? type 'short) short)
((equal? type 'unsigned-short) unsigned-short)
((equal? type 'int) int)
((equal? type 'unsigned-int) unsigned-int)
((equal? type 'long) long)
((equal? type 'unsigned-long) unsigned-long)
((equal? type 'float) float)
((equal? type 'double) double)
((equal? type 'pointer) '*)
((equal? type 'string) '*)
((equal? type 'void) void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(racket
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64)
;((equal? type 'char) _int32)
((equal? type 'char) _int)
((equal? type 'unsigned-char) _int)
((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) _pointer)
((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)))))))
(define pffi-pointer?
(lambda (object)
(cond-expand
(sagittarius (pointer? object))
(guile (pointer? object))
(racket (cpointer? object))
(stklos (cpointer? object))
(kawa (string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))))
;> ### pffi-call
;>
;> Arguments:
;>
;> - shared-object (object)
;> - Shared object returned by pffi-shared-object-load or pffi-shared-object-auto-load
;> - name (symbol)
;> - Name of the C function you want to call
;> - type (symbol)
;> - Return type of the C function you want to call
;> - arguments (list (cons type value)...)
;> - Arguments you want to pass to the C function as pairs of type and value
;>
;> Example:
;>
;> (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 "Hello"))
;> (cons 'int 1)
;> (cons 'int 1)
;> (cons 'int 400)
;> (cons 'int 400)
;> (cons 'int 4))
(define pffi-call
(lambda (shared-object name type arguments)
(let ((types (map pffi-type->native-type (map car arguments)))
(vals (map cdr arguments))
(native-type (pffi-type->native-type type)))
(cond-expand
(sagittarius
(apply (make-c-function shared-object
(pffi-type->native-type type)
name
types)
vals))
(guile
(apply
(foreign-library-function shared-object
(symbol->string name)
#:return-type (pffi-type->native-type type)
#:arg-types types)
vals))
(racket
(apply (get-ffi-obj name
shared-object
(_cprocedure (mlist->list types)
(pffi-type->native-type type)))
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-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
(sagittarius
(cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_t)
((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) size-of-long)
((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) 'byteAlignment)))))
(define pffi-pointer-allocate
(lambda (size)
(cond-expand
(sagittarius (allocate-pointer size))
(guile (bytevector->pointer (make-bytevector size 0)))
(racket (malloc 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) ; 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
(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)))))
(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)))))
(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 (bytevector)) ; TODO FIX
(kawa (invoke (invoke pointer 'reinterpret size)
'toArray
(static-field java.lang.foreign.ValueLayout
'JAVA_BYTE))))))
;> ### pffi-shared-object-load
;>
;> Arguments:
@ -518,29 +174,9 @@
;>
;> 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))
(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
;>
@ -552,178 +188,55 @@
;>
;> 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))
(shared-object #f))
(for-each
(lambda (path)
(if (not shared-object)
(let ((object-path
(string-append path
"/"
object-name
platform-file-extension))
(object-version-path
(string-append path
"/"
object-name
platform-version-file-extension))
(object-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-file-extension))
(object-version-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-version-file-extension)))
(cond
((file-exists? object-path)
(set! shared-object (pffi-shared-object-load object-path)))
((file-exists? object-version-path)
(set! shared-object (pffi-shared-object-load object-version-path)))
((file-exists? object-lib-path)
(set! shared-object (pffi-shared-object-load object-lib-path)))
((file-exists? object-version-lib-path)
(set! shared-object (pffi-shared-object-load object-version-lib-path)))))))
paths)
(if (not shared-object)
(error "Could not load shared object" object-name)
shared-object))))
(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)))))
(define-syntax pffi-shared-object-auto-load
(syntax-rules ()
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))
(for-each
(lambda (path)
(if (not shared-object)
(let ((object-path
(string-append path
"/"
object-name
platform-file-extension))
(object-version-path
(string-append path
"/"
object-name
platform-version-file-extension))
(object-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-file-extension))
(object-version-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-version-file-extension)))
(cond
((file-exists? object-path)
(set! shared-object (pffi-shared-object-load headers object-path)))
((file-exists? object-version-path)
(set! shared-object (pffi-shared-object-load headers object-version-path)))
((file-exists? object-lib-path)
(set! shared-object (pffi-shared-object-load headers object-lib-path)))
((file-exists? object-version-lib-path)
(set! shared-object (pffi-shared-object-load headers object-version-lib-path)))))))
paths)
(if (not shared-object)
(error "Could not load shared object" object-name)
shared-object)))))))
(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))))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond-expand
(sagittarius
(let ((p pointer))
(cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value))
((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value))
((equal? type 'char) (pointer-set-c-char! p offset value))
((equal? type 'short) (pointer-set-c-short! p offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
((equal? type 'int) (pointer-set-c-int! p offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
((equal? type 'long) (pointer-set-c-long! p offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
((equal? type 'float) (pointer-set-c-float! p offset value))
((equal? type 'double) (pointer-set-c-double! p offset value))
((equal? type 'void) (pointer-set-c-void*! p offset value)))))
(guile (let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
((equal? native-type uint8) (bytevector-u8-set! p offset value))
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-set! (pointer->string pointer) offset value))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-set! pointer type offset 'abs value))
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond-expand
(sagittarius
(let ((p pointer)
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
((equal? native-type 'char) (pointer-ref-c-char p offset))
((equal? native-type 'short) (pointer-set-c-short p offset value))
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type 'int) (pointer-ref-c-int p offset))
((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
((equal? native-type 'long) (pointer-ref-c-long p offset))
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
((equal? native-type 'float) (pointer-ref-c-float p offset))
((equal? native-type 'double) (pointer-ref-c-double p offset))
((equal? native-type 'void*) (pointer-ref-c-void* p offset)))))
(guile
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
((equal? native-type uint8) (bytevector-u8-ref p offset))
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
;((equal? native-type char) (string-ref (pointer->string pointer) offset))
;((equal? native-type 'short) (pointer-set-c-short p offset value))
;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
;((equal? native-type 'long) (pointer-ref-c-long p offset))
;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
;((equal? native-type 'float) (pointer-ref-c-float p offset))
;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset))
)))
(racket (ptr-ref pointer type 'abs offset))
(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 #f) ; TODO FIX
(stklos #f) ; TODO FIX
(kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))
(cond-expand
(kawa
(include "kawa.scm"))
(else #t))))

242
retropikzel/pffi/v0.1.0/main.sld Normal file
View File

@ -0,0 +1,242 @@
;> # pffi
;> ## Procedures
(define-library
(retropikzel pffi v0.1.0 main)
(cond-expand
(sagittarius
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 sagittarius)))
(guile
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 guile)))
(racket
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 racket)))
(stklos
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos)
(retropikzel pffi v0.1.0 stklos)))
(kawa
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)))
(cyclone
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 cyclone)))
(gambit
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 gambit)))
(chicken
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chicken)))
(chibi
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel pffi v0.1.0 chibi))))
(export pffi-shared-object-auto-load
pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define library-version "v0.1.0")
;> ## Procedures
(define platform-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(windows ".dll")
(else ".so")))
(define platform-version-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
(windows ".dll")
(else ".so.0")))
(define platform-lib-prefix
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(windows "")
(else "lib")))
(define pffi-types
'(int8
uint8
int16
uint16
int32
uint32
int64
uint64
intptr
uintptr
char
unsigned-char
short
unsigned-short
int
unsigned-int
long
unsigned-long
float
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
(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") #\;)))
(else
(append
; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
"")
"/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"
"/usr/local/lib"))))))
;> ### 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
(define-syntax pffi-shared-object-auto-load
(syntax-rules ()
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))
(for-each
(lambda (path)
(if (not shared-object)
(let ((object-path
(string-append path
"/"
object-name
platform-file-extension))
(object-version-path
(string-append path
"/"
object-name
platform-version-file-extension))
(object-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-file-extension))
(object-version-lib-path
(string-append path
"/"
platform-lib-prefix
object-name
platform-version-file-extension)))
(cond
((file-exists? object-path)
(set! shared-object (pffi-shared-object-load headers object-path)))
((file-exists? object-version-path)
(set! shared-object (pffi-shared-object-load headers object-version-path)))
((file-exists? object-lib-path)
(set! shared-object (pffi-shared-object-load headers object-lib-path)))
((file-exists? object-version-lib-path)
(set! shared-object (pffi-shared-object-load headers object-version-lib-path)))))))
paths)
(if (not shared-object)
(error "Could not load shared object" object-name)
shared-object)))))))
(cond-expand
(kawa
(include "kawa.scm"))
(else #t))))

114
retropikzel/pffi/v0.1.0/racket.scm Normal file
View File

@ -0,0 +1,114 @@
(define-library
(retropikzel pffi v0.1.0 racket)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
(compatibility mlist)
(ffi unsafe))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64)
;((equal? type 'char) _int32)
((equal? type 'char) _int)
((equal? type 'unsigned-char) _int)
((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) _pointer)
((equal? type 'void) _void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer?
(lambda (object)
(cpointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(get-ffi-obj c-name
shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(define pffi-size-of
(lambda (type)
(ctype-sizeof (pffi-type->native-type type))))
(define pffi-pointer-allocate
(lambda (size)
(malloc size)))
(define pffi-pointer-null
(lambda ()
#f ; In racket #f is null pointer
))
(define pffi-string->pointer
(lambda (string-content)
(cast string-content _string _pointer)))
(define pffi-pointer->string
(lambda (pointer)
(cast pointer _pointer _string)))
(define pffi-pointer->bytevector
(lambda (pointer size)
(pointer->bytevector pointer size)))
(define pffi-shared-object-load
(lambda header path)
(ffi-lib path))
(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(not pointer) ; #f is the null pointer on racket
))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer type offset 'abs value)))
(define pffi-pointer-get
(lambda (pointer type offset)
(ptr-ref pointer type 'abs offset)))
(define pffi-pointer-deref
(lambda (pointer)
#f ; TODO FIX
))))

170
retropikzel/pffi/v0.1.0/sagittarius.scm Normal file
View File

@ -0,0 +1,170 @@
(define-library
(retropikzel pffi v0.1.0 sagittarius)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius))
(export pffi-shared-object-load
pffi-define
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer->bytevector
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32_t)
((equal? type 'uint32) 'uint32_t)
((equal? type 'int64) 'int64_t)
((equal? type 'uint64) 'uint64_t)
((equal? type 'intptr) 'intptr_t)
((equal? type 'uintptr) 'uintptr_t)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'void*)
((equal? type 'string) 'void*)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer? (lambda (object) (pointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(pffi-type->native-type return-type)
c-name
(map pffi-type->native-type argument-types))))))
(define pffi-size-of
(lambda (type)
(cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_t)
((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) size-of-long)
((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)))))
(define pffi-pointer-allocate
(lambda (size)
(allocate-pointer size)))
(define pffi-pointer-null
(lambda ()
(integer->pointer 0)))
(define pffi-string->pointer
(lambda (string-content)
(bytevector->pointer (string->utf8 (string-copy string-content)))))
(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-pointer->bytevector
(lambda (pointer size)
(pointer->bytevector pointer size)))
(define pffi-shared-object-load
(lambda (header path)
(open-shared-library path)))
(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(null-pointer? pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value))
((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value))
((equal? type 'char) (pointer-set-c-char! p offset value))
((equal? type 'short) (pointer-set-c-short! p offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
((equal? type 'int) (pointer-set-c-int! p offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
((equal? type 'long) (pointer-set-c-long! p offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
((equal? type 'float) (pointer-set-c-float! p offset value))
((equal? type 'double) (pointer-set-c-double! p offset value))
((equal? type 'void) (pointer-set-c-void*! p offset value))))))
(define pffi-pointer-get
(lambda (pointer type offset)
(let ((p pointer)
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
((equal? native-type 'char) (pointer-ref-c-char p offset))
((equal? native-type 'short) (pointer-set-c-short p offset value))
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
((equal? native-type 'int) (pointer-ref-c-int p offset))
((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
((equal? native-type 'long) (pointer-ref-c-long p offset))
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
((equal? native-type 'float) (pointer-ref-c-float p offset))
((equal? native-type 'double) (pointer-ref-c-double p offset))
((equal? native-type 'void*) (pointer-ref-c-void* p offset))))))
(define pffi-pointer-deref
(lambda (pointer)
(deref pointer 0)))))

115
retropikzel/pffi/v0.1.0/stklos.scm Normal file
View File

@ -0,0 +1,115 @@
(define-library
(retropikzel pffi v0.1.0 stklos)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos))
(export pffi-define
pffi-pointer->bytevector
pffi-pointer->string
pffi-pointer-allocate
pffi-pointer-deref
pffi-pointer-free
pffi-pointer-get
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer?
pffi-shared-object-load
pffi-size-of
pffi-string->pointer)
(begin
(define pffi-type->native-type
(lambda (type)
(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)))))
(define pffi-pointer?
(lambda (object)
(cpointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-external-function
(symbol->string c-name)
(map pffi-type->native-type argument-types)
(pffi-type->native-type return-type)
shared-object)))))
(define pffi-size-of
(lambda (type)
4 ; TODO FIX
))
(define pffi-pointer-allocate
(lambda (size)
(allocate-bytes size)))
(define pffi-pointer-null
(lambda ()
(let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))
(define pffi-string->pointer
(lambda (string-content)
string-content))
(define pffi-pointer->string
(lambda (pointer)
(cpointer->string pointer)))
(define pffi-pointer->bytevector
(lambda (pointer size)
(bytevector) ; TODO FIX
))
(define pffi-shared-object-load
(lambda (header path)
path ))
(define pffi-pointer-free
(lambda (pointer)
(free-bytes pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(cpointer-null? pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
#f ; TODO FIX
))
(define pffi-pointer-get
(lambda (pointer type offset)
#f ; TODO FIX
))
(define pffi-pointer-deref
(lambda (pointer)
#f ; TODO FIX
))))

20
test.scm
View File

@ -1,17 +1,15 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme eval)
(scheme process-context)
(stklos))
(cyclone foreign))
(define puts (make-external-function "puts" (list :string) :string ""))
(define hello "Hello")
(display (%get-typed-ext-var hello :string))
(newline)
;(puts "Hello")
;(newline)
(define-syntax while
(syntax-rules ()
((while condition . body)
(let loop ()
(cond (condition
(begin . body)
(loop)))))))

BIN
test/pffi-define Executable file
View File

Binary file not shown.

24
test/pffi-define.scm Normal file
View File

@ -0,0 +1,24 @@
(import (scheme base)
(scheme write)
(scheme process-context)
(scheme eval)
(cyclone foreign)
(retropikzel pffi v0.1.0 main))
(define libc (pffi-shared-object-auto-load (list "stdio.h") "c" (list)))
(display libc)
(newline)
;(pffi-shared-object-load #t (display "this"))
(display "=================")
(newline)
;(pffi-define "hello")
;(c-define puts int "puts" string)
;(puts "I'm from C")
(newline)
(display "=================")
(newline)