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

Started adding stklos support

This commit is contained in:
retropikzel 2024-05-01 19:15:59 +03:00
parent 6fe5ef864e
commit 5234dd78f4
5 changed files with 214 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
Makefile
View File

@ -5,16 +5,20 @@ documentation:
schubert document schubert document
VERSION=${VERSION} bash doc/generate.sh > documentation.md VERSION=${VERSION} bash doc/generate.sh > documentation.md
test-sagittatius-sdl2: test-sagittatius-sdl2:
sash -r7 -L . test/sdl2.scm sash -r7 -L . test/sdl2.scm
test-guile-hello:
guile --debug --r7rs -L . test/hello.scm
test-guile-sdl2: test-guile-sdl2:
guile --debug --r7rs -L . test/sdl2.scm guile --debug --r7rs -L . test/sdl2.scm
build-rkt: build-rkt:
echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt
echo "#lang r7rs" > test/sdl2.rkt
cat test/sdl2.scm >> test/sdl2.rkt
test-racket-load: build-rkt test-racket-load: build-rkt
racket -I r7rs retropikzel/pffi/${VERSION}/main.rkt racket -I r7rs retropikzel/pffi/${VERSION}/main.rkt
@ -23,10 +27,16 @@ test-racket-load-wine: build-rkt
wine64 ${RACKETEXE} -I r7rs retropikzel/pffi/${VERSION}/main.rkt wine64 ${RACKETEXE} -I r7rs retropikzel/pffi/${VERSION}/main.rkt
test-racket-hello: build-rkt test-racket-hello: build-rkt
racket -I r7rs -S $(shell pwd) -f test/hello.scm racket -S $(shell pwd) -I r7rs test/hello.scm
test-racket-hello-wine: build-rkt test-racket-hello-wine: build-rkt
wine64 ${RACKETEXE} -I r7rs -S $(shell pwd) -f test/hello.scm wine64 ${RACKETEXE} -I r7rs -S $(shell pwd) -f test/hello.scm
test-racket-sdl2: build-rkt test-racket-sdl2: build-rkt
racket -I r7rs -S $(shell pwd) -f test/sdl2.scm racket -S $(shell pwd) test/sdl2.rkt
test-stklos-hello:
stklos -A . test/hello.scm
test-racket-sdl2:
stklos -A . test/sdl2.scm

83
retropikzel/pffi/v0.1.0/main.rkt
View File

@ -25,7 +25,9 @@
(only (racket base) (only (racket base)
system-type) system-type)
(compatibility mlist) (compatibility mlist)
(ffi unsafe))) (ffi unsafe))
(stklos )
)
(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
@ -50,14 +52,12 @@
(define platform-file-extension (define platform-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(guile "")
(windows ".dll") (windows ".dll")
(else ".so"))) (else ".so")))
(define platform-version-file-extension (define platform-version-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
(guile "")
(windows ".dll") (windows ".dll")
(else ".so.0"))) (else ".so.0")))
@ -243,10 +243,39 @@
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(cond-expand (sagittarius (pointer? object)) (cond-expand
(sagittarius (pointer? object))
(guile (pointer? object)) (guile (pointer? object))
(racket (cpointer? object))))) (racket (cpointer? object)))))
;> ### pffi-call
;>
;> Arguments:
;>
;> - shared-object (object)
;> - Shared object returned by pffi-shared-object-load or pffi-shared-object-auto-load
;> - name (symbol)
;> - Name of the C function you want to call
;> - type (symbol)
;> - Return type of the C function you want to call
;> - arguments (list (cons type value)...)
;> - Arguments you want to pass to the C function as pairs of type and value
;>
;> Example:
;>
;> (define sdl2* (pffi-shared-object-auto-load "SDL2" (list))
;>
;> (pffi-call sdl2* 'SDL_Init 'int '((int . 32)))
;>
;> (define window* (pffi-call sdl2*
;> 'SDL_CreateWindow
;> 'pointer
;> (list (cons 'pointer (pffi-string->pointer "Hello"))
;> (cons 'int 1)
;> (cons 'int 1)
;> (cons 'int 400)
;> (cons 'int 400)
;> (cons 'int 4))
(define pffi-call (define pffi-call
(lambda (shared-object name type arguments) (lambda (shared-object name type arguments)
(let ((types (map pffi-type->native-type (map car arguments))) (let ((types (map pffi-type->native-type (map car arguments)))
@ -276,27 +305,27 @@
(lambda (type) (lambda (type)
(cond-expand (cond-expand
(sagittarius (sagittarius
(cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) (cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) ((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) ((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) ((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) ((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) ((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) ((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) ((eq? type 'uint64) size-of-uint64_t)
((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) ((eq? type 'intptr) size-of-intptr_t)
((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) ((eq? type 'uintptr) size-of-uintptr_t)
((eq? type 'char) (cond-expand (sagittarius size-of-char))) ((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) ((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) (cond-expand (sagittarius size-of-short))) ((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) ((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) (cond-expand (sagittarius size-of-int))) ((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) ((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) (cond-expand (sagittarius size-of-long))) ((eq? type 'long) size-of-long)
((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) ((eq? type 'unsigned-long) size-of-unsigned-long)
((eq? type 'float) (cond-expand (sagittarius size-of-float))) ((eq? type 'float) size-of-float)
((eq? type 'double) (cond-expand (sagittarius size-of-double))) ((eq? type 'double) size-of-double)
((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))) ((eq? type 'pointer) 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))) (guile (sizeof (pffi-type->native-type type)))
(racket (ctype-sizeof (pffi-type->native-type type)))))) (racket (ctype-sizeof (pffi-type->native-type type))))))
@ -432,7 +461,7 @@
((equal? native-type uint64) (bytevector-u64-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 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_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 char) (string-set! (pointer->string pointer) offset value))
;((equal? native-type 'short) (pointer-set-c-short p 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 '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 int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
@ -484,7 +513,7 @@
((equal? native-type uint64) (bytevector-u64-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 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_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 char) (string-ref (pointer->string pointer) offset))
;((equal? native-type 'short) (pointer-set-c-short p 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 '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 int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))

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

@ -25,6 +25,12 @@
system-type) system-type)
(compatibility mlist) (compatibility mlist)
(ffi unsafe))) (ffi unsafe)))
(stklos
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos)))
(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
@ -49,14 +55,12 @@
(define platform-file-extension (define platform-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(guile "")
(windows ".dll") (windows ".dll")
(else ".so"))) (else ".so")))
(define platform-version-file-extension (define platform-version-file-extension
(cond-expand (cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
(guile "")
(windows ".dll") (windows ".dll")
(else ".so.0"))) (else ".so.0")))
@ -109,26 +113,6 @@
(define auto-load-paths (define auto-load-paths
(append (append
(cond-expand (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 (windows
(append (append
(if (get-environment-variable "SYSTEM") (if (get-environment-variable "SYSTEM")
@ -186,6 +170,7 @@
((equal? type 'float) 'float) ((equal? type 'float) 'float)
((equal? type 'double) 'double) ((equal? type 'double) 'double)
((equal? type 'pointer) 'void*) ((equal? type 'pointer) 'void*)
((equal? type 'string) 'void*)
((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
@ -212,6 +197,7 @@
((equal? type 'float) float) ((equal? type 'float) float)
((equal? type 'double) double) ((equal? type 'double) double)
((equal? type 'pointer) '*) ((equal? type 'pointer) '*)
((equal? type 'string) '*)
((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))))
(racket (racket
@ -237,14 +223,40 @@
((equal? type 'float) _float) ((equal? type 'float) _float)
((equal? type 'double) _double) ((equal? type 'double) _double)
((equal? type 'pointer) _pointer) ((equal? type 'pointer) _pointer)
((equal? type 'string) _pointer)
((equal? type 'void) _void) ((equal? type 'void) _void)
(else (error "pffi-type->native-type -- No such pffi type" type))))
(sktlos
(cond ((equal? type 'int8) :int)
((equal? type 'uint8) :uint)
((equal? type 'int16) :int)
((equal? type 'uint16) :uint)
((equal? type 'int32) :int)
((equal? type 'uint32) :uint)
((equal? type 'int64) :int)
((equal? type 'uint64) :uint)
((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar)
((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 'string) :string)
((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)))))))
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(cond-expand (sagittarius (pointer? object)) (cond-expand
(sagittarius (pointer? object))
(guile (pointer? object)) (guile (pointer? object))
(racket (cpointer? object))))) (racket (cpointer? object))
(stklos (cpointer? object)))))
;> ### pffi-call ;> ### pffi-call
;> ;>
@ -277,7 +289,8 @@
(define pffi-call (define pffi-call
(lambda (shared-object name type arguments) (lambda (shared-object name type arguments)
(let ((types (map pffi-type->native-type (map car arguments))) (let ((types (map pffi-type->native-type (map car arguments)))
(vals (map cdr arguments))) (vals (map cdr arguments))
(native-type (pffi-type->native-type type)))
(cond-expand (cond-expand
(sagittarius (sagittarius
(apply (make-c-function shared-object (apply (make-c-function shared-object
@ -297,74 +310,89 @@
shared-object shared-object
(_cprocedure (mlist->list types) (_cprocedure (mlist->list types)
(pffi-type->native-type type))) (pffi-type->native-type type)))
vals)))))) vals))
(stklos
(stklos (apply (make-external-function
(symbol->string name)
types
native-type
shared-object)
vals)))))))
(define pffi-size-of (define pffi-size-of
(lambda (type) (lambda (type)
(cond-expand (cond-expand
(sagittarius (sagittarius
(cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) (cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) ((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) ((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) ((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) ((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) ((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) ((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) ((eq? type 'uint64) size-of-uint64_t)
((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) ((eq? type 'intptr) size-of-intptr_t)
((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) ((eq? type 'uintptr) size-of-uintptr_t)
((eq? type 'char) (cond-expand (sagittarius size-of-char))) ((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) ((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) (cond-expand (sagittarius size-of-short))) ((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) ((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) (cond-expand (sagittarius size-of-int))) ((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) ((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) (cond-expand (sagittarius size-of-long))) ((eq? type 'long) size-of-long)
((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) ((eq? type 'unsigned-long) size-of-unsigned-long)
((eq? type 'float) (cond-expand (sagittarius size-of-float))) ((eq? type 'float) size-of-float)
((eq? type 'double) (cond-expand (sagittarius size-of-double))) ((eq? type 'double) size-of-double)
((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))) ((eq? type 'pointer) 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))) (guile (sizeof (pffi-type->native-type type)))
(racket (ctype-sizeof (pffi-type->native-type type)))))) (racket (ctype-sizeof (pffi-type->native-type type)))
(stklos 4) ; FIX
)))
(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))) (guile (bytevector->pointer (make-bytevector size 0)))
(racket (malloc size))))) (racket (malloc size))
(stklos (allocate-bytes size)))))
(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)) (guile (make-pointer 0))
(racket #f)))) (racket #f)
(stklos (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))))
(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)) (guile (string->pointer string-content))
(racket (cast string-content _string _pointer))))) (racket (cast string-content _string _pointer))
(stklos 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)) (guile (pointer->string pointer))
(racket (cast pointer _pointer _string))))) (racket (cast pointer _pointer _string))
(cpointer->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)) (guile (pointer->bytevector pointer size))
(racket (cast pointer _pointer _bytes))))) (racket (cast pointer _pointer _bytes))
(stklos (error "STKlos does not support pffi-pointer->bytevector")))))
(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)) (guile (load-foreign-library path #:lazy? #f))
(racket (ffi-lib path))))) (racket (ffi-lib path))
(stklos path))))
(define pffi-shared-object-auto-load (define pffi-shared-object-auto-load
(lambda (object-name additional-paths) (lambda (object-name additional-paths)
@ -413,14 +441,16 @@
(lambda (pointer) (lambda (pointer)
(cond-expand (sagittarius (c-free pointer)) (cond-expand (sagittarius (c-free pointer))
(guile #t) (guile #t)
(racket (free pointer))))) (racket (free pointer))
(stklos (free-bytes pointer)))))
(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)) (guile (null-pointer? pointer))
(racket (not pointer) ; #f is the null pointer on racket ; #f is the null pointer on racket
)))) (racket (not pointer))
(stklos (cpointer-null? pointer)))))
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
@ -459,7 +489,7 @@
((equal? native-type uint64) (bytevector-u64-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 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_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 char) (string-set! (pointer->string pointer) offset value))
;((equal? native-type 'short) (pointer-set-c-short p 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 '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 int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
@ -470,7 +500,9 @@
;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset))
;((equal? native-type '*) (pointer-ref-c-void* p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset))
))) )))
(racket (ptr-set! pointer type offset value))))) (racket (ptr-set! pointer type offset value))
(stklos ())
)))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -511,7 +543,7 @@
((equal? native-type uint64) (bytevector-u64-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 'intptr_t) (pointer-ref-c-intptr_t p offset))
;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_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 char) (string-ref (pointer->string pointer) offset))
;((equal? native-type 'short) (pointer-set-c-short p 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 '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 int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))

17
test.scm Normal file
View File

@ -0,0 +1,17 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(stklos))
(define puts (make-external-function "puts" (list :string) :string ""))
(define hello "Hello")
(display (%get-typed-ext-var hello :string))
(newline)
;(puts "Hello")
;(newline)

33
test/sdl2.rkt Normal file
View File

@ -0,0 +1,33 @@
#lang r7rs
(import (scheme base)
(scheme write)
(scheme read)
(retropikzel pffi v0.1.0 main))
(define sdl2 (pffi-shared-object-auto-load "SDL2" (list)))
(pffi-call sdl2 'SDL_Init 'int '((int . 32)))
(define window (pffi-call sdl2
'SDL_CreateWindow
'pointer
(list (cons 'pointer (pffi-string->pointer "Testing pffi"))
(cons 'int 1)
(cons 'int 1)
(cons 'int 400)
(cons 'int 400)
(cons 'int 4))))
(define renderer (pffi-call sdl2
'SDL_CreateRenderer
'pointer
(list (cons 'pointer window)
(cons 'int -1)
(cons 'int 2))))
(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer)))
(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer)))
(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000))))