Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Started adding racket support

This commit is contained in:
retropikzel 2024-04-30 23:28:06 +03:00
parent c499e28154
commit c3736015f8
5 changed files with 677 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Makefile
View File

@ -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

1
manifest.scm
View File

@ -4,6 +4,7 @@
(specifications->manifest
(list "guile"
"racket-minimal"
"sdl2"
"sdl2-image"
"sdl2-ttf"

504
retropikzel/pffi/v0.1.0/main.rkt Normal file
View File

@ -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))))))

198
retropikzel/pffi/v0.1.0/main.scm
View File

@ -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))))))
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)
@ -335,29 +420,29 @@
((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))
))))))
(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)
@ -388,7 +473,7 @@
(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))
(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)))
@ -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))))))

8
test/hello.scm Normal file
View File

@ -0,0 +1,8 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(display "Hello")
(newline)