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

Making good progress with guile support

This commit is contained in:
retropikzel 2024-04-29 19:17:58 +03:00
parent a21955af1a
commit c499e28154
2 changed files with 158 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -2,4 +2,4 @@ test-sagittatius-sdl2:
sash -r7 -L . test/sdl2.scm sash -r7 -L . test/sdl2.scm
test-guile-sdl2: test-guile-sdl2:
guile -rr7rs -L . test/sdl2.scm guile --debug --r7rs -L . test/sdl2.scm

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

@ -1,20 +1,21 @@
(define-library (define-library
(retropikzel pffi v0.1.0 main) (retropikzel pffi v0.1.0 main)
(cond-expand (cond-expand
(guile
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library)))
(sagittarius (sagittarius
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(sagittarius ffi) (sagittarius ffi)
(sagittarius)) (sagittarius)))
(guile (import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(system foreign)
(system foreign-library))))
(else (error "Implementation not supported by r7rs-pffi"))) (else (error "Implementation not supported by r7rs-pffi")))
(export pffi-call (export pffi-call
pffi-types pffi-types
@ -144,28 +145,30 @@
((equal? type 'void) 'void) ((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) (else (error "pffi-type->native-type -- No such pffi type" type))))
(guile (guile
(cond ((equal? type 'int8) 'int8) (cond ((equal? type 'int8) int8)
((equal? type 'uint8) 'uint8) ((equal? type 'uint8) uint8)
((equal? type 'int16) 'int16) ((equal? type 'int16) int16)
((equal? type 'uint16) 'uint16) ((equal? type 'uint16) uint16)
((equal? type 'int32) 'int32) ((equal? type 'int32) int32)
((equal? type 'uint32) 'uint32) ((equal? type 'uint32) uint32)
((equal? type 'int64) 'int64) ((equal? type 'int64) int64)
((equal? type 'uint64) 'uint64) ((equal? type 'uint64) uint64)
((equal? type 'intptr) 'intptr) ;((equal? type 'intptr) intptr)
((equal? type 'uintptr) 'uintptr) ;((equal? type 'uintptr) uintptr)
((equal? type 'char) 'char) ;((equal? type 'char) char)
((equal? type 'unsigned-char) 'char) ((equal? type 'char) int)
((equal? type 'short) 'short) ;((equal? type 'unsigned-char) char)
((equal? type 'unsigned-short) 'unsigned-short) ((equal? type 'unsigned-char) int)
((equal? type 'int) 'int) ((equal? type 'short) short)
((equal? type 'unsigned-int) 'unsigned-int) ((equal? type 'unsigned-short) unsigned-short)
((equal? type 'long) 'long) ((equal? type 'int) int)
((equal? type 'unsigned-long) 'unsigned-long) ((equal? type 'unsigned-int) unsigned-int)
((equal? type 'float) 'float) ((equal? type 'long) long)
((equal? type 'double) 'double) ((equal? type 'unsigned-long) unsigned-long)
((equal? type 'float) float)
((equal? type 'double) double)
((equal? type 'pointer) '*) ((equal? type 'pointer) '*)
((equal? type 'void) 'void) ((equal? type 'void) void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) (else (error "pffi-type->native-type -- No such pffi type" type))))
))) )))
@ -183,67 +186,75 @@
(apply (make-c-function shared-object (apply (make-c-function shared-object
(pffi-type->native-type type) (pffi-type->native-type type)
name name
types) vals)) types)
vals))
(guile (guile
(foreign-library-function shared-object (apply
name (foreign-library-function shared-object
type (symbol->string name)
types) #:return-type (pffi-type->native-type type)
#:arg-types types)
vals))))))
)
))))
(define pffi-size-of (define pffi-size-of
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) (cond-expand
((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) (guile (sizeof (pffi-type->native-type type)))
((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) (sagittarius
((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) (cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t)))
((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) ((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t)))
((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) ((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t)))
((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) ((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t)))
((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) ((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t)))
((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) ((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t)))
((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) ((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t)))
((eq? type 'char) (cond-expand (sagittarius size-of-char))) ((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t)))
((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) ((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t)))
((eq? type 'short) (cond-expand (sagittarius size-of-short))) ((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t)))
((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) ((eq? type 'char) (cond-expand (sagittarius size-of-char)))
((eq? type 'int) (cond-expand (sagittarius size-of-int))) ((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char)))
((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) ((eq? type 'short) (cond-expand (sagittarius size-of-short)))
((eq? type 'long) (cond-expand (sagittarius size-of-long))) ((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short)))
((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) ((eq? type 'int) (cond-expand (sagittarius size-of-int)))
((eq? type 'float) (cond-expand (sagittarius size-of-float))) ((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int)))
((eq? type 'double) (cond-expand (sagittarius size-of-double))) ((eq? type 'long) (cond-expand (sagittarius size-of-long)))
((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))) ((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long)))
(else (error "Can not get size of unknown type" type))))) ((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 (define pffi-pointer-allocate
(lambda (size) (lambda (size)
(cond-expand (cond-expand
(sagittarius (allocate-pointer size))))) (sagittarius (allocate-pointer size))
(guile (bytevector->pointer (make-bytevector size 0))))))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(cond-expand (cond-expand
(sagittarius (integer->pointer 0))))) (sagittarius (integer->pointer 0))
(guile (make-pointer 0)))))
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))))) (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
(guile (string->pointer string-content)))))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (pointer->string pointer))))) (cond-expand (sagittarius (pointer->string pointer))
(guile (pointer->string pointer)))))
(define pffi-pointer->bytevector (define pffi-pointer->bytevector
(lambda (pointer size) (lambda (pointer size)
(cond-expand (sagittarius (pointer->bytevector pointer size))))) (cond-expand (sagittarius (pointer->bytevector pointer size))
(guile (pointer->bytevector pointer size)))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (path) (lambda (path)
(cond-expand (sagittarius (open-shared-library path))))) (cond-expand (sagittarius (open-shared-library path))
(guile (load-foreign-library path #:lazy? #f)))))
(define pffi-shared-object-auto-load (define pffi-shared-object-auto-load
(lambda (object-name additional-paths) (lambda (object-name additional-paths)
@ -251,27 +262,29 @@
(shared-object #f)) (shared-object #f))
(for-each (for-each
(lambda (path) (lambda (path)
(write path)
(newline)
(if (not shared-object) (if (not shared-object)
(let ((object-path (string-append path (let ((object-path
"/" (string-append path
object-name "/"
(cond-expand (windows ".dll") (else ".so")))) object-name
(object-version-path (string-append path (cond-expand (windows ".dll") (else ".so"))))
"/" (object-version-path
object-name (string-append path
(cond-expand (windows ".dll") (else ".so.0")))) "/"
(object-lib-path (string-append path object-name
"/" (cond-expand (windows ".dll") (else ".so.0"))))
(cond-expand (windows "") (else "lib")) (object-lib-path
object-name (string-append path
(cond-expand (windows ".dll") (else ".so")))) "/"
(object-version-lib-path (string-append path (cond-expand (windows "") (else "lib"))
"/" object-name
(cond-expand (windows "") (else "lib")) (cond-expand (windows ".dll") (else ".so"))))
object-name (object-version-lib-path
(cond-expand (windows ".dll") (else ".so.0"))))) (string-append path
"/"
(cond-expand (windows "") (else "lib"))
object-name
(cond-expand (windows ".dll") (else ".so.0")))))
(cond (cond
((file-exists? object-path) ((file-exists? object-path)
(set! shared-object (pffi-shared-object-load object-path))) (set! shared-object (pffi-shared-object-load object-path)))
@ -288,11 +301,13 @@
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (c-free pointer))))) (cond-expand (sagittarius (c-free pointer))
(guile #t))))
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (null-pointer? pointer))))) (cond-expand (sagittarius (null-pointer? pointer))
(guile (null-pointer? pointer)))))
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
@ -318,7 +333,31 @@
((equal? type 'unsigned-long) (pointer-set-c-unsigned-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 'float) (pointer-set-c-float! p offset value))
((equal? type 'double) (pointer-set-c-double! p offset value)) ((equal? type 'double) (pointer-set-c-double! p offset value))
((equal? type 'void) (pointer-set-c-void*! 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 (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -345,8 +384,34 @@
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-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 'float) (pointer-ref-c-float p offset))
((equal? native-type 'double) (pointer-ref-c-double p offset)) ((equal? native-type 'double) (pointer-ref-c-double p offset))
((equal? native-type 'void*) (pointer-ref-c-void* 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 (define pffi-pointer-deref
(lambda (pointer offset) (lambda (pointer)
(cond-expand (sagittarius (deref pointer offset))))))) (cond-expand (sagittarius (deref pointer 0))
(guile (dereference-pointer pointer)))))))