(define-library (retropikzel pffi v0.1.0 main) (cond-expand (sagittarius (import (scheme base) (scheme write) (scheme file) (scheme process-context) (sagittarius ffi) (sagittarius))) (guile (import (scheme base) (scheme write) (scheme file) (scheme process-context) (rnrs bytevectors) (system foreign) (system foreign-library))) (racket (import (scheme base) (scheme write) (scheme file) (scheme process-context) (only (racket base) system-type) (compatibility mlist) (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 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-shared-object-load pffi-shared-object-auto-load pffi-pointer-set! pffi-pointer-get 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 linker #f) (define lookup #f) (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")) (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 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 (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")))))) (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 '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 '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 'intptr) intptr) ;((equal? type 'uintptr) uintptr) ;((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) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'uint8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'int16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'uint16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'int32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'uint32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((equal? type 'int64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) ((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 '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 (display "pffi-pointer? called with: ") ; TODO FIX (write object) (newline) #f)))) ;> ### 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 linker 'downcallHandle (invoke (invoke lookup '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) (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 '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) ((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 '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) 'byteSize))))) (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 rackter #f is null pointer (stklos (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)) (kawa (invoke-static java.lang.foreign.MemorySegment 'ofAddress 0))))) (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)) (cpointer->string pointer) (kawa (invoke pointer 'getString))))) (define pffi-pointer->bytevector (lambda (pointer size) (cond-expand (sagittarius (pointer->bytevector pointer size)) (guile (pointer->bytevector pointer size)) (racket (cast pointer _pointer _bytes)) (stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX (kawa (invoke pointer 'toArray))))) (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)) (set! linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) (set! lookup (invoke-static java.lang.foreign.SymbolLookup 'libraryLookup absolute-path (invoke-static java.lang.foreign.Arena 'ofAuto) )) ;(invoke-static java.lang.System 'load absolute-path) #t)) ))) (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 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 value)) (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX (kawa (invoke pointer 'set (pffi-type->native-type type) offset))))) (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 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 (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX (stklos (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX (kawa (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX )))))