diff --git a/Makefile b/Makefile index 88cdc1d..cfc6fe7 100644 --- a/Makefile +++ b/Makefile @@ -1,103 +1,51 @@ VERSION=v0.1.0 -RACKETEXE=${HOME}/.wine/drive_c/Program Files/Racket/racket.exe +SASH=sash -r7 -L . +GUILE=guile --r7rs -L . +RACKET=racket -I r7rs --make -S $(shell pwd) --script +STKLOS=stklos -A . +KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=".." + +build: build-rkt documentation + +build-rkt: + echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt + cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt documentation: schubert document VERSION=${VERSION} bash doc/generate.sh > documentation.md -test-size-of: - @echo "Sagittarius" - sash -r7 -L . test/size-of.scm - @echo "Guile" - guile --r7rs -L . test/size-of.scm - #@echo "Racket" - #racket -I r7rs test/size-of.scm - #@echo "STKlos" - #stklos -A . test/hello.scm - @echo "Kawa" - java \ - --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED \ - --enable-native-access=ALL-UNNAMED \ - --enable-preview \ - -jar kawa.jar \ - --r7rs \ - --full-tailcalls \ - -Dkawa.import.path=".." \ - test/size-of.scm +test/import.scm: build + ${SASH} $@ + ${GUILE} $@ + #${RACKET} $@ + #${STKLOS} $@ + ${KAWA} $@ -test-pointer-set-get: - sash -r7 -L . test/pointer-set-get.scm - java \ - --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED \ - --enable-native-access=ALL-UNNAMED \ - --enable-preview \ - -jar kawa.jar \ - --r7rs \ - --full-tailcalls \ - -Dkawa.import.path=".." \ - test/pointer-set-get.scm +test/size-of.scm: build + ${SASH} $@ + ${GUILE} $@ + #${RACKET} $@ + #${STKLOS} $@ + ${KAWA} $@ -test-sagittatius-sdl2: - sash -r7 -L . test/sdl2.scm +test/pointer-set-get.scm: build + ${SASH} $@ + ${GUILE} $@ + #${RACKET} $@ + #${STKLOS} $@ + ${KAWA} $@ -test-guile-hello: - guile --debug --r7rs -L . test/hello.scm - -test-guile-sdl2: - guile --debug --r7rs -L . test/sdl2.scm - -build-rkt: - echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt - cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt - echo "#lang r7rs" > test/sdl2.rkt - cat test/sdl2.scm >> test/sdl2.rkt - -test-racket-load: build-rkt - racket -I r7rs retropikzel/pffi/${VERSION}/main.rkt - -test-racket-load-wine: build-rkt - wine64 ${RACKETEXE} -I r7rs retropikzel/pffi/${VERSION}/main.rkt - -test-racket-hello: build-rkt - racket -S $(shell pwd) -I r7rs test/hello.scm - -test-racket-hello-wine: build-rkt - wine64 ${RACKETEXE} -I r7rs -S $(shell pwd) -f test/hello.scm - -test-racket-sdl2: build-rkt - racket -S $(shell pwd) test/sdl2.rkt - -test-stklos-hello: - stklos -A . test/hello.scm - - -test-kawa-string-to-pointer-to-string: - java \ - --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED \ - --enable-native-access=ALL-UNNAMED \ - --enable-preview \ - -jar kawa.jar \ - --r7rs \ - --full-tailcalls \ - -Dkawa.import.path=".." \ - test/string-to-pointer-to-string.scm - -test-kawa-sdl2: - java \ - --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED \ - --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED \ - --enable-native-access=ALL-UNNAMED \ - --enable-preview \ - -jar kawa.jar \ - --r7rs \ - --full-tailcalls \ - -Dkawa.import.path=".." \ - test/sdl2.scm +test/string-to-pointer-to-string.scm: build + ${SASH} $@ + ${GUILE} $@ + #${RACKET} $@ + #${STKLOS} $@ + ${KAWA} $@ +test/sdl2.scm: build + ${SASH} $@ + ${GUILE} $@ + #${RACKET} $@ + #${STKLOS} $@ + ${KAWA} $@ diff --git a/retropikzel/pffi/v0.1.0/main.rkt b/retropikzel/pffi/v0.1.0/main.rkt index a9a2f76..94ec0c5 100644 --- a/retropikzel/pffi/v0.1.0/main.rkt +++ b/retropikzel/pffi/v0.1.0/main.rkt @@ -22,12 +22,20 @@ (scheme write) (scheme file) (scheme process-context) - (only (racket base) - system-type) + (only (racket base) system-type) (compatibility mlist) - (ffi unsafe)) - (stklos ) - ) + (ffi unsafe))) + (stklos + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (stklos))) + (kawa + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context))) (else (error "Implementation not supported by r7rs-pffi"))) (export pffi-call pffi-types @@ -49,6 +57,31 @@ (define library-version "v0.1.0") + (cond-expand + (sagittarius #t) + (guile #t) + (racket #t) + (stklos #t) + (kawa + (define arena (invoke-static java.lang.foreign.Arena 'global)) + (define value->object + (lambda (value type) + (cond ((equal? type 'byte) + (java.lang.Byte value)) + ((equal? type 'short) + (java.lang.Short value)) + ((equal? type 'int) + (java.lang.Integer value)) + ((equal? type 'long) + (java.lang.Long value)) + ((equal? type 'float) + (java.lang.Float value)) + ((equal? type 'double) + (java.lang.Double value)) + ((equal? type 'char) + (java.lang.Char value)) + (else value)))))) + (define platform-file-extension (cond-expand (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) @@ -90,46 +123,9 @@ 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 - (racket (if (equal? (system-type 'os) 'windows) - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (list ".") - (string-split (get-environment-variable "PATH") #\;)) - (append - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") - "")) - (if (get-environment-variable "LD_LOAD_PATH") - (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:) - (list)) - (list "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib")))) (windows (append (if (get-environment-variable "SYSTEM") @@ -152,16 +148,6 @@ "/usr/lib/x86_64-linux-gnu" "/usr/local/lib")))))) - - - - - (define memorysession #f) - (define linker #f) - (define symbol-lookup #f) - (define kebab-case->snake-case - (lambda (str) (string-map (lambda (c) (if (char=? c #\-) #\_ c)) str))) - (define pffi-type->native-type (lambda (type) (cond-expand @@ -187,6 +173,7 @@ ((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 @@ -198,12 +185,9 @@ ((equal? type 'uint32) uint32) ((equal? type 'int64) int64) ((equal? type 'uint64) uint64) - ;((equal? type 'intptr) intptr) - ;((equal? type 'uintptr) uintptr) ;((equal? type 'char) char) ((equal? type 'char) int) - ;((equal? type 'unsigned-char) char) - ;((equal? type 'unsigned-char) int) + ((equal? type 'unsigned-char) int) ((equal? type 'short) short) ((equal? type 'unsigned-short) unsigned-short) ((equal? type 'int) int) @@ -213,6 +197,7 @@ ((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 @@ -224,8 +209,6 @@ ((equal? type 'uint32) _uint32) ((equal? type 'int64) _int64) ((equal? type 'uint64) _uint64) - ;((equal? type 'intptr) intptr) - ;((equal? type 'uintptr) uintptr) ;((equal? type 'char) _int32) ((equal? type 'char) _int) ((equal? type 'unsigned-char) _int) @@ -238,15 +221,74 @@ ((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))))))) + (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))))) + (racket (cpointer? object)) + (stklos (cpointer? object)) + (kawa (string=? (invoke (invoke object 'getClass) 'getName) + "jdk.internal.foreign.NativeMemorySegmentImpl"))))) ;> ### pffi-call ;> @@ -279,7 +321,8 @@ (define pffi-call (lambda (shared-object name type arguments) (let ((types (map pffi-type->native-type (map car arguments))) - (vals (map cdr arguments))) + (vals (map cdr arguments)) + (native-type (pffi-type->native-type type))) (cond-expand (sagittarius (apply (make-c-function shared-object @@ -299,7 +342,29 @@ shared-object (_cprocedure (mlist->list types) (pffi-type->native-type type))) - vals)))))) + vals)) + (stklos + (stklos (apply (make-external-function + (symbol->string name) + types + native-type + shared-object) + vals))) + (kawa + (let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)) + (of (class-methods java.lang.foreign.FunctionDescriptor 'of)) + (function-descriptor (if (equal? type 'void) + (apply of-void types) + (apply of (append (list native-type) types)))) + (method-handle (invoke (cdr (assoc 'linker shared-object)) + 'downcallHandle + (invoke (invoke (cdr (assoc 'lookup shared-object)) + 'find + (symbol->string name)) + 'orElseThrow) + function-descriptor)) + (values-objects (map value->object vals (map car arguments)))) + (invoke method-handle 'invokeWithArguments values-objects))))))) (define pffi-size-of (lambda (type) @@ -313,8 +378,6 @@ ((eq? type 'uint32) size-of-uint32_t) ((eq? type 'int64) size-of-int64_t) ((eq? type 'uint64) size-of-uint64_t) - ((eq? type 'intptr) size-of-intptr_t) - ((eq? type 'uintptr) size-of-uintptr_t) ((eq? type 'char) size-of-char) ((eq? type 'unsigned-char) size-of-char) ((eq? type 'short) size-of-short) @@ -325,48 +388,81 @@ ((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)))))) + (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))))) + (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)))) + (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))))) + (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))))) + (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))))) + (racket (cast pointer _pointer _bytes)) + (stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX + (kawa (invoke (invoke pointer 'reinterpret size) + 'toArray + (static-field java.lang.foreign.ValueLayout + 'JAVA_BYTE)))))) (define pffi-shared-object-load (lambda (path) (cond-expand (sagittarius (open-shared-library path)) (guile (load-foreign-library path #:lazy? #f)) - (racket (ffi-lib path))))) + (racket (ffi-lib path)) + (stklos path) + (kawa + (let* ((library-file (make java.io.File path)) + (file-name (invoke library-file 'getName)) + (library-parent-folder (make java.io.File (invoke library-file 'getParent))) + (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) + "/" + file-name)) + ;(set! arena (invoke-static java.lang.foreign.Arena 'ofConfined)) + + (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) + (lookup (invoke-static java.lang.foreign.SymbolLookup + 'libraryLookup + absolute-path + arena))) + (list (cons 'linker linker) + (cons 'lookup lookup))))))) (define pffi-shared-object-auto-load (lambda (object-name additional-paths) @@ -415,14 +511,17 @@ (lambda (pointer) (cond-expand (sagittarius (c-free pointer)) (guile #t) - (racket (free pointer))))) + (racket (free pointer)) + (stklos (free-bytes pointer)) + (kawa (invoke pointer 'unload))))) (define pffi-pointer-null? (lambda (pointer) (cond-expand (sagittarius (null-pointer? pointer)) (guile (null-pointer? pointer)) - (racket (not pointer) ; #f is the null pointer on racket - )))) + (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) @@ -472,7 +571,9 @@ ;((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 value))))) + (racket (ptr-set! pointer type offset 'abs value)) + (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX + (kawa (invoke pointer 'set (pffi-type->native-type type) offset value))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -524,10 +625,14 @@ ;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset)) ))) - (racket (ptr-ref pointer type offset))))) + (racket (ptr-ref pointer type 'abs offset)) + (stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX + (kawa (invoke pointer 'get (pffi-type->native-type type) offset))))) (define pffi-pointer-deref (lambda (pointer) (cond-expand (sagittarius (deref pointer 0)) (guile (dereference-pointer pointer)) - (racket #t)))))) + (racket (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX + (stklos (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX + (kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0))))))) diff --git a/retropikzel/pffi/v0.1.0/main.scm b/retropikzel/pffi/v0.1.0/main.scm index 104abd2..f8df0cd 100644 --- a/retropikzel/pffi/v0.1.0/main.scm +++ b/retropikzel/pffi/v0.1.0/main.scm @@ -21,8 +21,7 @@ (scheme write) (scheme file) (scheme process-context) - (only (racket base) - system-type) + (only (racket base) system-type) (compatibility mlist) (ffi unsafe))) (stklos @@ -427,7 +426,7 @@ (cond-expand (sagittarius (pointer->string pointer)) (guile (pointer->string pointer)) (racket (cast pointer _pointer _string)) - (cpointer->string pointer) + (stklos (cpointer->string pointer)) (kawa (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0))))) (define pffi-pointer->bytevector @@ -571,7 +570,7 @@ ;((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 value)) + (racket (ptr-set! pointer type offset 'abs value)) (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX (kawa (invoke pointer 'set (pffi-type->native-type type) offset value))))) @@ -625,7 +624,7 @@ ;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset)) ))) - (racket (ptr-ref pointer type offset)) + (racket (ptr-ref pointer type 'abs offset)) (stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX (kawa (invoke pointer 'get (pffi-type->native-type type) offset))))) diff --git a/test/import.scm b/test/import.scm new file mode 100644 index 0000000..653c8a0 --- /dev/null +++ b/test/import.scm @@ -0,0 +1,8 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0.1.0 main)) + +(display "Hello") +(newline) + + diff --git a/test/sdl2.rkt b/test/sdl2.rkt deleted file mode 100644 index cc51592..0000000 --- a/test/sdl2.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang r7rs -(import (scheme base) - (scheme write) - (scheme read) - (retropikzel pffi v0.1.0 main)) - - -(define sdl2 (pffi-shared-object-auto-load "SDL2" (list))) - -(pffi-call sdl2 'SDL_Init 'int '((int . 32))) - -(define window (pffi-call sdl2 - 'SDL_CreateWindow - 'pointer - (list (cons 'pointer (pffi-string->pointer "Testing pffi")) - (cons 'int 1) - (cons 'int 1) - (cons 'int 400) - (cons 'int 400) - (cons 'int 4)))) - -(define renderer (pffi-call sdl2 - 'SDL_CreateRenderer - 'pointer - (list (cons 'pointer window) - (cons 'int -1) - (cons 'int 2)))) - -(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer))) -(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer))) - -(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000)))) -