diff --git a/.gitignore b/.gitignore index 06f4913..03a92d3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,8 @@ *.swp docuptmp +*.log +*.c +*.so +*.o +*.meta +old diff --git a/Makefile b/Makefile index 6c0c407..4b02293 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/manifest.scm b/manifest.scm index e11694c..1a33d88 100644 --- a/manifest.scm +++ b/manifest.scm @@ -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")) diff --git a/retropikzel/pffi/v0.1.0/chibi.scm b/retropikzel/pffi/v0.1.0/chibi.scm new file mode 100644 index 0000000..3f2b1ae --- /dev/null +++ b/retropikzel/pffi/v0.1.0/chibi.scm @@ -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"))))) diff --git a/retropikzel/pffi/v0.1.0/chicken.scm b/retropikzel/pffi/v0.1.0/chicken.scm new file mode 100644 index 0000000..3711fd9 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/chicken.scm @@ -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"))))) diff --git a/retropikzel/pffi/v0.1.0/cyclone.sld b/retropikzel/pffi/v0.1.0/cyclone.sld new file mode 100644 index 0000000..d4eba70 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/cyclone.sld @@ -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"))))) diff --git a/retropikzel/pffi/v0.1.0/empty.scm b/retropikzel/pffi/v0.1.0/empty.scm new file mode 100644 index 0000000..4a93a95 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/empty.scm @@ -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"))))) diff --git a/retropikzel/pffi/v0.1.0/gambit.scm b/retropikzel/pffi/v0.1.0/gambit.scm new file mode 100644 index 0000000..2749b33 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/gambit.scm @@ -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"))))) diff --git a/retropikzel/pffi/v0.1.0/guile.scm b/retropikzel/pffi/v0.1.0/guile.scm new file mode 100644 index 0000000..ecaceab --- /dev/null +++ b/retropikzel/pffi/v0.1.0/guile.scm @@ -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))))) diff --git a/retropikzel/pffi/v0.1.0/kawa.scm b/retropikzel/pffi/v0.1.0/kawa.scm new file mode 100644 index 0000000..c50f692 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/kawa.scm @@ -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))) diff --git a/retropikzel/pffi/v0.1.0/kawa.sld b/retropikzel/pffi/v0.1.0/kawa.sld new file mode 100644 index 0000000..e1db640 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/kawa.sld @@ -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 + + + )) diff --git a/retropikzel/pffi/v0.1.0/main.rkt b/retropikzel/pffi/v0.1.0/main.rkt index efff3f0..98e95a4 100644 --- a/retropikzel/pffi/v0.1.0/main.rkt +++ b/retropikzel/pffi/v0.1.0/main.rkt @@ -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)))) diff --git a/retropikzel/pffi/v0.1.0/main.scm b/retropikzel/pffi/v0.1.0/main.scm index 2b4d09d..ffa09ad 100644 --- a/retropikzel/pffi/v0.1.0/main.scm +++ b/retropikzel/pffi/v0.1.0/main.scm @@ -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)))) diff --git a/retropikzel/pffi/v0.1.0/main.sld b/retropikzel/pffi/v0.1.0/main.sld new file mode 100644 index 0000000..ffa09ad --- /dev/null +++ b/retropikzel/pffi/v0.1.0/main.sld @@ -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)))) diff --git a/retropikzel/pffi/v0.1.0/racket.scm b/retropikzel/pffi/v0.1.0/racket.scm new file mode 100644 index 0000000..043af62 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/racket.scm @@ -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 + )))) diff --git a/retropikzel/pffi/v0.1.0/sagittarius.scm b/retropikzel/pffi/v0.1.0/sagittarius.scm new file mode 100644 index 0000000..7b895cf --- /dev/null +++ b/retropikzel/pffi/v0.1.0/sagittarius.scm @@ -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))))) diff --git a/retropikzel/pffi/v0.1.0/stklos.scm b/retropikzel/pffi/v0.1.0/stklos.scm new file mode 100644 index 0000000..8cc4dfa --- /dev/null +++ b/retropikzel/pffi/v0.1.0/stklos.scm @@ -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 + )))) diff --git a/test.scm b/test.scm index 98796d9..54a211f 100644 --- a/test.scm +++ b/test.scm @@ -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))))))) diff --git a/test/pffi-define b/test/pffi-define new file mode 100755 index 0000000..a838f85 Binary files /dev/null and b/test/pffi-define differ diff --git a/test/pffi-define.scm b/test/pffi-define.scm new file mode 100644 index 0000000..4d80842 --- /dev/null +++ b/test/pffi-define.scm @@ -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)