#lang r7rs (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))) (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") (define platform-file-extension (cond-expand (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (guile "") (windows ".dll") (else ".so"))) (define platform-version-file-extension (cond-expand (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) (guile "") (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 (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") (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 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 (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 '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 '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 'void) _void) (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))))) (define pffi-call (lambda (shared-object name type arguments) (let ((types (map pffi-type->native-type (map car arguments))) (vals (map cdr arguments))) (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)))))) (define pffi-size-of (lambda (type) (cond-expand (sagittarius (cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) ((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) ((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) ((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) ((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) ((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) ((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) ((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) ((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) ((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) ((eq? type 'char) (cond-expand (sagittarius size-of-char))) ((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) ((eq? type 'short) (cond-expand (sagittarius size-of-short))) ((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) ((eq? type 'int) (cond-expand (sagittarius size-of-int))) ((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) ((eq? type 'long) (cond-expand (sagittarius size-of-long))) ((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) ((eq? type 'float) (cond-expand (sagittarius size-of-float))) ((eq? type 'double) (cond-expand (sagittarius size-of-double))) ((eq? type 'pointer) (cond-expand (sagittarius 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)))))) (define pffi-pointer-allocate (lambda (size) (cond-expand (sagittarius (allocate-pointer size)) (guile (bytevector->pointer (make-bytevector size 0))) (racket (malloc size))))) (define pffi-pointer-null (lambda () (cond-expand (sagittarius (integer->pointer 0)) (guile (make-pointer 0)) (racket #f)))) (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))))) (define pffi-pointer->string (lambda (pointer) (cond-expand (sagittarius (pointer->string pointer)) (guile (pointer->string pointer)) (racket (cast pointer _pointer _string))))) (define pffi-pointer->bytevector (lambda (pointer size) (cond-expand (sagittarius (pointer->bytevector pointer size)) (guile (pointer->bytevector pointer size)) (racket (cast pointer _pointer _bytes))))) (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))))) (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))))) (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 )))) (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))))) (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))))) (define pffi-pointer-deref (lambda (pointer) (cond-expand (sagittarius (deref pointer 0)) (guile (dereference-pointer pointer)) (racket #t))))))