Started adding racket support
This commit is contained in:
parent
c499e28154
commit
c3736015f8
22
Makefile
22
Makefile
|
|
@ -1,5 +1,27 @@
|
|||
VERSION=v0.1.0
|
||||
RACKETEXE=${HOME}/.wine/drive_c/Program Files/Racket/racket.exe
|
||||
|
||||
test-sagittatius-sdl2:
|
||||
sash -r7 -L . test/sdl2.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
|
||||
|
||||
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 -I r7rs -S $(shell pwd) -f 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 -I r7rs -S $(shell pwd) -f test/sdl2.scm
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(specifications->manifest
|
||||
(list "guile"
|
||||
"racket-minimal"
|
||||
"sdl2"
|
||||
"sdl2-image"
|
||||
"sdl2-ttf"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,504 @@
|
|||
#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))))))
|
||||
|
|
@ -1,6 +1,13 @@
|
|||
(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)
|
||||
|
|
@ -9,17 +16,18 @@
|
|||
(rnrs bytevectors)
|
||||
(system foreign)
|
||||
(system foreign-library)))
|
||||
(sagittarius
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(sagittarius ffi)
|
||||
(sagittarius)))
|
||||
(only (racket base)
|
||||
system-type)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)))
|
||||
(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
|
||||
|
|
@ -38,6 +46,26 @@
|
|||
|
||||
(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
|
||||
|
|
@ -81,6 +109,26 @@
|
|||
(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")
|
||||
|
|
@ -105,11 +153,7 @@
|
|||
|
||||
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(guile "")
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
|
||||
(define memorysession #f)
|
||||
(define linker #f)
|
||||
|
|
@ -158,7 +202,7 @@
|
|||
;((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)
|
||||
|
|
@ -170,12 +214,37 @@
|
|||
((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)))))
|
||||
(guile (pointer? object))
|
||||
(racket (cpointer? object)))))
|
||||
|
||||
(define pffi-call
|
||||
(lambda (shared-object name type arguments)
|
||||
|
|
@ -194,12 +263,17 @@
|
|||
(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
|
||||
(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)))
|
||||
|
|
@ -222,39 +296,47 @@
|
|||
((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)))))))
|
||||
(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))))))
|
||||
(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)))))
|
||||
(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)))))
|
||||
(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)))))
|
||||
(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)))))
|
||||
(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)))))
|
||||
(guile (load-foreign-library path #:lazy? #f))
|
||||
(racket (ffi-lib path)))))
|
||||
|
||||
(define pffi-shared-object-auto-load
|
||||
(lambda (object-name additional-paths)
|
||||
|
|
@ -267,24 +349,24 @@
|
|||
(string-append path
|
||||
"/"
|
||||
object-name
|
||||
(cond-expand (windows ".dll") (else ".so"))))
|
||||
platform-file-extension))
|
||||
(object-version-path
|
||||
(string-append path
|
||||
"/"
|
||||
object-name
|
||||
(cond-expand (windows ".dll") (else ".so.0"))))
|
||||
platform-version-file-extension))
|
||||
(object-lib-path
|
||||
(string-append path
|
||||
"/"
|
||||
(cond-expand (windows "") (else "lib"))
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
(cond-expand (windows ".dll") (else ".so"))))
|
||||
platform-file-extension))
|
||||
(object-version-lib-path
|
||||
(string-append path
|
||||
"/"
|
||||
(cond-expand (windows "") (else "lib"))
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
(cond-expand (windows ".dll") (else ".so.0")))))
|
||||
platform-version-file-extension)))
|
||||
(cond
|
||||
((file-exists? object-path)
|
||||
(set! shared-object (pffi-shared-object-load object-path)))
|
||||
|
|
@ -302,12 +384,15 @@
|
|||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(cond-expand (sagittarius (c-free pointer))
|
||||
(guile #t))))
|
||||
(guile #t)
|
||||
(racket (free pointer)))))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(cond-expand (sagittarius (null-pointer? pointer))
|
||||
(guile (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)
|
||||
|
|
@ -356,8 +441,8 @@
|
|||
;((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)
|
||||
|
|
@ -408,10 +493,11 @@
|
|||
;((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)))))))
|
||||
(guile (dereference-pointer pointer))
|
||||
(racket #t))))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel pffi v0.1.0 main))
|
||||
|
||||
(display "Hello")
|
||||
(newline)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue