418 lines
20 KiB
Scheme
418 lines
20 KiB
Scheme
(define-library
|
|
(retropikzel pffi v0.1.0 main)
|
|
(cond-expand
|
|
(guile
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(rnrs bytevectors)
|
|
(system foreign)
|
|
(system foreign-library)))
|
|
(sagittarius
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(sagittarius ffi)
|
|
(sagittarius)))
|
|
(else (error "Implementation not supported by r7rs-pffi")))
|
|
(export pffi-call
|
|
pffi-types
|
|
pffi-type-sizes
|
|
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 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
|
|
(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 platform-file-extension
|
|
(cond-expand
|
|
(guile "")
|
|
(windows ".dll")
|
|
(else ".so")))
|
|
|
|
(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))))
|
|
)))
|
|
|
|
(define pffi-pointer?
|
|
(lambda (object)
|
|
(cond-expand (sagittarius (pointer? object))
|
|
(guile (pointer? 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))))))
|
|
|
|
(define pffi-size-of
|
|
(lambda (type)
|
|
(cond-expand
|
|
(guile (sizeof (pffi-type->native-type type)))
|
|
(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)))))))
|
|
|
|
(define pffi-pointer-allocate
|
|
(lambda (size)
|
|
(cond-expand
|
|
(sagittarius (allocate-pointer size))
|
|
(guile (bytevector->pointer (make-bytevector size 0))))))
|
|
|
|
(define pffi-pointer-null
|
|
(lambda ()
|
|
(cond-expand
|
|
(sagittarius (integer->pointer 0))
|
|
(guile (make-pointer 0)))))
|
|
|
|
(define pffi-string->pointer
|
|
(lambda (string-content)
|
|
(cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
|
|
(guile (string->pointer string-content)))))
|
|
|
|
(define pffi-pointer->string
|
|
(lambda (pointer)
|
|
(cond-expand (sagittarius (pointer->string pointer))
|
|
(guile (pointer->string pointer)))))
|
|
|
|
(define pffi-pointer->bytevector
|
|
(lambda (pointer size)
|
|
(cond-expand (sagittarius (pointer->bytevector pointer size))
|
|
(guile (pointer->bytevector pointer size)))))
|
|
|
|
(define pffi-shared-object-load
|
|
(lambda (path)
|
|
(cond-expand (sagittarius (open-shared-library path))
|
|
(guile (load-foreign-library path #:lazy? #f)))))
|
|
|
|
(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
|
|
(cond-expand (windows ".dll") (else ".so"))))
|
|
(object-version-path
|
|
(string-append path
|
|
"/"
|
|
object-name
|
|
(cond-expand (windows ".dll") (else ".so.0"))))
|
|
(object-lib-path
|
|
(string-append path
|
|
"/"
|
|
(cond-expand (windows "") (else "lib"))
|
|
object-name
|
|
(cond-expand (windows ".dll") (else ".so"))))
|
|
(object-version-lib-path
|
|
(string-append path
|
|
"/"
|
|
(cond-expand (windows "") (else "lib"))
|
|
object-name
|
|
(cond-expand (windows ".dll") (else ".so.0")))))
|
|
(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))))
|
|
|
|
(define pffi-pointer-null?
|
|
(lambda (pointer)
|
|
(cond-expand (sagittarius (null-pointer? pointer))
|
|
(guile (null-pointer? pointer)))))
|
|
|
|
(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))
|
|
|
|
))))))
|
|
|
|
(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))
|
|
|
|
))))))
|
|
|
|
(define pffi-pointer-deref
|
|
(lambda (pointer)
|
|
(cond-expand (sagittarius (deref pointer 0))
|
|
(guile (dereference-pointer pointer)))))))
|