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

Improved portability a lot. Started export renaming.

This commit is contained in:
retropikzel 2025-04-25 18:01:24 +03:00
parent 637d31b834
commit 439c097ab0
29 changed files with 1390 additions and 1464 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
' Normal file
View File

@ -0,0 +1,213 @@
(define size-of-type
(lambda (type)
(cond ((eq? type 'int8) (size-of-int8_t))
((eq? type 'uint8) (size-of-uint8_t))
((eq? type 'int16) (size-of-int16_t))
((eq? type 'uint16) (size-of-uint16_t))
((eq? type 'int32) (size-of-int32_t))
((eq? type 'uint32) (size-of-uint32_t))
((eq? type 'int64) (size-of-int64_t))
((eq? type 'uint64) (size-of-uint64_t))
((eq? type 'char) (size-of-char))
((eq? type 'unsigned-char) (size-of-char))
((eq? type 'short) (size-of-short))
((eq? type 'unsigned-short) (size-of-unsigned-short))
((eq? type 'int) (size-of-int))
((eq? type 'unsigned-int) (size-of-unsigned-int))
((eq? type 'long) (size-of-long))
((eq? type 'unsigned-long) (size-of-unsigned-long))
((eq? type 'float) (size-of-float))
((eq? type 'double) (size-of-double))
((eq? type 'pointer) (size-of-pointer))
((eq? type 'string) (size-of-pointer))
((eq? type 'struct) (size-of-pointer))
((eq? type 'callback) (size-of-pointer))
((eq? type 'void) 0)
(else #f))))
(define pffi-shared-object-load
(lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror)))
(when (not (pffi-pointer-null? maybe-error))
(error (pffi-pointer->string maybe-error)))
shared-object)))
#;(define pffi-pointer-null
(lambda ()
(pointer-null)))
#;(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is null on Chibi
(define pffi-pointer?
(lambda (object)
(or (equal? object #f) ; False can be null pointer
(pointer? object))))
(define pffi-pointer-allocate
(lambda (size)
(pointer-allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-free
(lambda (pointer)
(pointer-free pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
((equal? type 'long) (pointer-set-c-long! pointer offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
((equal? type 'float) (pointer-set-c-float! pointer offset value))
((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset))
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
((equal? type 'long) (pointer-ref-c-long pointer offset))
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
((equal? type 'float) (pointer-ref-c-float pointer offset))
((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
#;(define pffi-string->pointer
(lambda (string-content)
(string-to-pointer string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer-to-string pointer)))
(define pffi-type->native-type
(lambda (type)
(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 '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) '(maybe-null void*))
((equal? type 'string) 'string)
((equal? type 'void) 'void)
((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
;; pffi-define-function
(define pffi-type->libffi-type
(lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8))
((equal? type 'uint8) (get-ffi-type-uint8))
((equal? type 'int16) (get-ffi-type-int16))
((equal? type 'uint16) (get-ffi-type-uint16))
((equal? type 'int32) (get-ffi-type-int32))
((equal? type 'uint32) (get-ffi-type-uint32))
((equal? type 'int64) (get-ffi-type-int64))
((equal? type 'uint64) (get-ffi-type-uint64))
((equal? type 'char) (get-ffi-type-char))
((equal? type 'unsigned-char) (get-ffi-type-uchar))
((equal? type 'bool) (get-ffi-type-int8))
((equal? type 'short) (get-ffi-type-short))
((equal? type 'unsigned-short) (get-ffi-type-ushort))
((equal? type 'int) (get-ffi-type-int))
((equal? type 'unsigned-int) (get-ffi-type-uint))
((equal? type 'long) (get-ffi-type-long))
((equal? type 'unsigned-long) (get-ffi-type-ulong))
((equal? type 'float) (get-ffi-type-float))
((equal? type 'double) (get-ffi-type-double))
((equal? type 'void) (get-ffi-type-void))
((equal? type 'pointer) (get-ffi-type-pointer))
((equal? type 'callback) (get-ffi-type-pointer)))))
(define argument->pointer
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
pointer)))))
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror)))
(lambda arguments
(let ((return-value (pffi-pointer-allocate
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
(internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type)
(map pffi-type->libffi-type argument-types)
c-function
return-value
(map argument->pointer
arguments
argument-types))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define-function
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))
(define make-c-callback
(lambda (return-type argument-types procedure)
(scheme-procedure-to-pointer procedure)))
(define-syntax pffi-define-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback return-type 'argument-types procedure)))))

1
.gitignore vendored
View File

@ -44,3 +44,4 @@ tests/retropikzel
*.rkt
testfile.test
tests/testfile.test
snow

18
Makefile
View File

@ -4,6 +4,9 @@ DOCKER=docker run -it -v ${PWD}:/workdir
DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}')
snow:
snow-chibi --install-source-dir ./snow install "(r6rs bytevectors)"
# apt-get install pandoc weasyprint
docs:
mkdir -p documentation
@ -64,13 +67,19 @@ tr7:
ypsilon:
make -C retropikzel/pffi tr7
test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so
test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
make ${COMPILE_R7RS}
cp -r retropikzel tmp/test/
cp tests/compliance.scm tmp/test/
cp tests/c-include/libtest.h tmp/test/
cd tmp/test && COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." compile-r7rs -I . -o compliance compliance.scm
cd tmp/test && LD_LIBRARY_PATH=. ./compliance
cp -r snow/* tmp/test/
cd tmp/test && \
COMPILE_R7RS_GAMBIT="-cc-options \"-ltest -I. -L\" -ld-options \"-L.\"" \
COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \
compile-r7rs -I . -o compliance compliance.scm
cd tmp/test && \
LD_LIBRARY_PATH=. \
./compliance
test-compile-r7rs-docker:
docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} -f dockerfiles/test .
@ -84,10 +93,11 @@ tmp/test/libtest.so: tests/c-src/libtest.c
mkdir -p tmp/test
${CC} -o tmp/test/libtest.so -shared -fPIC tests/c-src/libtest.c -I./include
tmp/test/libtest.a: tmp/test/libtest.o src/libtest.c
tmp/test/libtest.a: tmp/test/libtest.o tests/c-src/libtest.c
ar rcs tmp/test/libtest.a tmp/test/libtest.o
clean:
@rm -rf retropikzel/pffi/pffi.c
@rm -rf retropikzel/pffi/*.o*
@rm -rf retropikzel/pffi/*.so
@rm -rf retropikzel/pffi/*.meta

174
README.md
View File

@ -47,19 +47,19 @@ conforming to some specification.
- [PFFI\_LOAD\_PATH](#environment-variables-pffi-load-path)
- [Procedures and macros](#procedures-and-macros)
- [pffi-init](#pffi-init)
- [pffi-size-of](#pffi-size-of)
- [c-size-of](#c-size-of)
- [pffi-align-of](#pffi-align-of)
- [pffi-define-library](#pffi-define-library)
- [pffi-pointer-null](#pffi-pointer-null)
- [pffi-pointer-null?](#pffi-pointer-null)
- [pffi-pointer-allocate](#pffi-pointer-allocate)
- [define-c-library](#define-c-library)
- [make-c-null](#make-c-null)
- [c-null?](#is-c-null)
- [make-c-bytevector ](#make-c-bytevector )
- [pffi-pointer-address](#pffi-pointer-address)
- [pffi-pointer?](#pffi-pointer)
- [pffi-pointer-free](#pffi-pointer-free)
- [c-bytevector?](#is-c-bytevector)
- [c-free](#c-free)
- [pffi-pointer-set!](#pffi-pointer-set!)
- [pffi-pointer-get](#pffi-pointer-get)
- [pffi-string->pointer](#pffi-string->pointer)
- [pffi-pointer->string](#pffi-pointer->string)
- [string->c-bytevector](#string-into-c-bytevector)
- [c-bytevector->sring](#c-bytevector-into-string)
- [pffi-struct-make](#pffi-struct-make)
- [pffi-struct-pointer](#pffi-struct-pointer)
- [pffi-struct-offset-get](#pffi-struct-offset-get)
@ -73,7 +73,7 @@ conforming to some specification.
- [pffi-array-set!](#pffi-array-set!)
- [pffi-list->array](#pffi-list->array)
- [pffi-array->list](#pffi-array->list)
- [pffi-define-function](#pffi-define-function)
- [define-c-procedure](#define-c-procedure)
- [pffi-define-callback](#pffi-define-callback)
</nav>
@ -99,8 +99,7 @@ conforming to some specification.
## Status
<a name="status"></a>
Currently the interface of the library is in okay shape. It propably will not change much but no
guarantees are being made just yet.
In alpha.
### Current caveats
<a name="current-caveats"></a>
@ -111,7 +110,7 @@ guarantees are being made just yet.
- Always pass pffi-define-callback procedure as lambda in place
- No support for variadic function arguments
- Can be partially worked around by defining multiple versions of same
function with different amount of arguments
function with different number of arguments
## Roadmap
@ -123,24 +122,24 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear
## Primitives
<a name="feature-implementation-table-primitives"></a>
| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback |
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:|
| Chibi | X | X | X | X | X | X | X | X | X | X | |
| Chicken | X | X | X | X | X | X | X | X | X | X | X |
| Cyclone | X | X | X | X | X | | X | X | X | X | |
| Gambit | X | X | | | | X | | | | | |
| Gauche | X | X | X | X | X | X | X | X | X | X | |
| Gerbil | X | | | | | | | | | | |
| Guile | X | X | X | X | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X | X | X | X | X |
| Larceny | X | | | | | | | | | | |
| Mosh | X | X | X | X | X | | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | |
| Stklos | X | X | X | X | X | | X | | | | |
| tr7 | | | | | | | | | | | |
| Ypsilon | X | X | X | X | X | X | X | X | X | X | X |
| | c-size-of | define-c-library | c-bytevector? | pffi-pointer-set! | pffi-pointer-get | define-c-procedure | pffi-define-callback |
|--------------|:------------:|:-------------------:|:-------------:|:-----------------:|:----------------:|:-------------------:|:--------------------:|
| Chibi | X | X | X | X | X | X | |
| Chicken | X | X | X | X | X | X | X |
| Cyclone | X | X | X | X | X | X | |
| Gambit | X | | | | | | |
| Gauche | X | X | X | X | X | X | |
| Gerbil | | | | | | | |
| Guile | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X |
| Larceny | | | | | | | |
| Mosh | X | X | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X |
| Skint | | | | | | | |
| Stklos | X | X | X | | | | |
| tr7 | | | | | | | |
| Ypsilon | X | X | X | X | X | X | X |
## Built upon
<a name="feature-implementation-table-built-upon"></a>
@ -148,8 +147,11 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear
These features are built upon the primitives and if primitives are implemented
and work, they should work too.
- pffi-pointer-allocate
- pffi-pointer-free
- make-c-bytevector
- make-c-null
- c-null?
- pffi-pointer-address
- c-free
- pffi-pointer-\>string
- pffi-string-\>pointer
- pffi-struct-make
@ -339,10 +341,10 @@ Some of these are procedures and some macros, it might also change implementatio
Always call this first, on most implementation it does nothing but some implementations might need
initialisation run.
#### pffi-size-of
<a name="pffi-size-of"></a>
#### c-size-of
<a name="c-size-of"></a>
**pffi-size-of** object -> number
**c-size-of** object -> number
Returns the size of the pffi-struct, pffi-enum or pffi-type.
@ -353,10 +355,10 @@ Returns the size of the pffi-struct, pffi-enum or pffi-type.
Returns the align of the type.
#### pffi-define-library
<a name="pffi-define-library"></a>
#### define-c-library
<a name="define-c-library"></a>
**pffi-define-library** headers shared-object-name [options] -> object
**define-c-library** headers shared-object-name [options] -> object
Load given shared object automatically searching many predefined paths.
@ -377,12 +379,12 @@ keyword. The options are:
Example:
(cond-expand
(windows (pffi-define-library libc-stdlib
(windows (define-c-library libc-stdlib
'("stdlib.h")
"ucrtbase"
'((additional-versions ("0" "6"))
(additiona-paths (".")))))
(else (pffi-define-library libc-stdlib
(else (define-c-library libc-stdlib
(list "stdlib.h")
"c"
'((additional-versions ("0" "6"))
@ -399,45 +401,57 @@ implementations.
- Do pass the options using quote
- As '(... and not (list...
#### pffi-pointer-null
<a name="pffi-pointer-null"></a>
#### make-c-null
<a name="make-c-null"></a>
**pffi-pointer-null** -> pointer
**make-c-null** -> pointer
Returns a new NULL pointer.
#### pffi-pointer-null?
<a name="pffi-pointer-null"></a>
#### c-null?
<a name="is-c-null"></a>
**pffi-pointer-null?** pointer -> boolean
**c-null?** pointer -> boolean
Returns #t if given pointer is null pointer, #f otherwise.
#### pffi-pointer-allocate
<a name="pffi-pointer-allocate"></a>
#### make-c-bytevector
<a name="make-c-bytevector "></a>
**pffi-pointer-allocate** size -> pointer
(make-c-bytevector *k*)
(make-c-bytevector *k* *fill*)
Returns newly allocated pointer of given size.
Returns a newly allocated C bytevector(pointer) of length k. If byte is given,
then all elements of the C bytevector are initialized to byte, otherwise the
contents of each element are unspecified.
#### pffi-pointer-address
<a name="pffi-pointer-address"></a>
**pffi-pointer-address** pointer -> number
**pffi-pointer-address** pointer -> pointer
Returns the address of given pointer as number.
Returns the address of given pointer inside a pointer. This is used when
passing pointers to pointers to foreign procedures. This is similar to the
c's &. One **important difference** is that after you have passed a pointer to
the procedure you must get value from it back to the pointer which address you
are passing. Example:
#### pffi-pointer?
(define input-pointer (make-c-bytevector <needed size>))
(define input-pointer-address (pffi-pointer-address input-pointer))
(<foreign-procedure-that takes &pointer as argument> input-pointer-address)
(set! input-pointer (pffi-pointer-get input-pointer-address 'pointer 0))
#### c-bytevector?
<a name="pffi-pointer"></a>
**pffi-pointer?** object -> boolean
**c-bytevector?** object -> boolean
Returns #t if given object is pointer, #f otherwise.
#### pffi-pointer-free
<a name="pffi-pointer-free"></a>
#### c-free
<a name="c-free"></a>
**pffi-pointer-free** pointer
**c-free** pointer
Frees given pointer.
@ -448,7 +462,7 @@ Frees given pointer.
Sets the value on a pointer on given offset. For example:
(define p (pffi-pointer-allocate 128))
(define p (make-c-bytevector 128))
(pffi-pointer-set! p 'int 64 100)
Would set the offset of 64, on pointer p to value 100.
@ -460,22 +474,22 @@ Would set the offset of 64, on pointer p to value 100.
Gets the value from a pointer on given offset. For example:
(define p (pffi-pointer-allocate 128))
(define p (make-c-bytevector 128))
(pffi-pointer-set! p 'int 64 100)
(pffi-pointer-get p 'int 64)
> 100
#### pffi-string->pointer
<a name="pffi-string->pointer"></a>
#### string->c-bytevector
<a name="string-into-c-bytevector"></a>
**pffi-string->pointer** string -> pointer
**string->c-bytevector** string -> pointer
Makes pointer out of a given string.
#### pffi-pointer->string
<a name="pffi-pointer->string"></a>
#### c-bytevector->string
<a name="c-bytevector-into-string"></a>
**pffi-pointer->string** pointer -> string
**c-bytevector->sring** pointer -> string
Makes string out of a given pointer.
@ -581,17 +595,17 @@ Converts given list into C array of given type.
Converts given C array into list of given type and length.
#### pffi-define-function
<a name="pffi-define-function"></a>
#### define-c-procedure
<a name="define-c-procedure"></a>
**pffi-define-function** scheme-name shared-object c-name return-type argument-types
**define-c-procedure** scheme-name shared-object c-name return-type argument-types
Defines a new foreign function to be used from Scheme code. For example:
(cond-expand
(windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
(else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6"))))
(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
(windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
(else (define-c-library libc-stdlib '("stdlib.h") "c" '("" "6"))))
(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
(c-puts "Message brought to you by FFI!")
#### pffi-define-callback
@ -603,11 +617,11 @@ Defines a new Sceme function to be used as callback to C code. For example:
; Load the shared library
(cond-expand
(windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
(else (pffi-define-library '("stdlib.h") "c" '("" "6"))))
(windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
(else (define-c-library '("stdlib.h") "c" '("" "6"))))
; Define C function that takes a callback
(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback))
; Define our callback
(pffi-define-callback compare
@ -621,17 +635,17 @@ Defines a new Sceme function to be used as callback to C code. For example:
((< a b) -1)))))
; Create new array of ints to be sorted
(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3)))
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3)
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2)
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1)
(define array (make-c-bytevector (* (c-size-of 'int) 3)))
(pffi-pointer-set! array 'int (* (c-size-of 'int) 0) 3)
(pffi-pointer-set! array 'int (* (c-size-of 'int) 1) 2)
(pffi-pointer-set! array 'int (* (c-size-of 'int) 2) 1)
(display array)
(newline)
;> (3 2 1)
; Sort the array
(qsort array 3 (pffi-size-of 'int) compare)
(qsort array 3 (c-size-of 'int) compare)
(display array)
(newline)

232
documentation/R7RS-PFFI.html
View File

@ -76,23 +76,22 @@ Documentation - 0.6.0</title>
<li><a href="#procedures-and-macros">Procedures and macros</a>
<ul>
<li><a href="#pffi-init">pffi-init</a></li>
<li><a href="#pffi-size-of">pffi-size-of</a></li>
<li><a href="#c-size-of">c-size-of</a></li>
<li><a href="#pffi-align-of">pffi-align-of</a></li>
<li><a href="#pffi-define-library">pffi-define-library</a></li>
<li><a href="#pffi-pointer-null">pffi-pointer-null</a></li>
<li><a href="#pffi-pointer-null">pffi-pointer-null?</a></li>
<li><a
href="#pffi-pointer-allocate">pffi-pointer-allocate</a></li>
<li><a href="#define-c-library">define-c-library</a></li>
<li><a href="#make-c-null">make-c-null</a></li>
<li><a href="#is-c-null">c-null?</a></li>
<li><a href="#make-c-bytevector">make-c-bytevector</a></li>
<li><a
href="#pffi-pointer-address">pffi-pointer-address</a></li>
<li><a href="#pffi-pointer">pffi-pointer?</a></li>
<li><a href="#pffi-pointer-free">pffi-pointer-free</a></li>
<li><a href="#is-c-bytevector">c-bytevector?</a></li>
<li><a href="#c-free">c-free</a></li>
<li><a href="#pffi-pointer-set!">pffi-pointer-set!</a></li>
<li><a href="#pffi-pointer-get">pffi-pointer-get</a></li>
<li><a
href="#pffi-string-%3Epointer">pffi-string-&gt;pointer</a></li>
href="#string-into-c-bytevector">string-&gt;c-bytevector</a></li>
<li><a
href="#pffi-pointer-%3Estring">pffi-pointer-&gt;string</a></li>
href="#c-bytevector-into-string">c-bytevector-&gt;sring</a></li>
<li><a href="#pffi-struct-make">pffi-struct-make</a></li>
<li><a href="#pffi-struct-pointer">pffi-struct-pointer</a></li>
<li><a
@ -108,8 +107,7 @@ Documentation - 0.6.0</title>
<li><a href="#pffi-array-set!">pffi-array-set!</a></li>
<li><a href="#pffi-list-%3Earray">pffi-list-&gt;array</a></li>
<li><a href="#pffi-array-%3Elist">pffi-array-&gt;list</a></li>
<li><a
href="#pffi-define-function">pffi-define-function</a></li>
<li><a href="#define-c-procedure">define-c-procedure</a></li>
<li><a
href="#pffi-define-callback">pffi-define-callback</a></li>
</ul></li>
@ -141,9 +139,7 @@ Documentation - 0.6.0</title>
</ul>
<h2 id="status">Status</h2>
<p><a name="status"></a></p>
<p>Currently the interface of the library is in okay shape. It
propably will not change much but no guarantees are being made
just yet.</p>
<p>In alpha.</p>
<h3 id="current-caveats">Current caveats</h3>
<p><a name="current-caveats"></a></p>
<ul>
@ -156,7 +152,7 @@ Documentation - 0.6.0</title>
<li>No support for variadic function arguments
<ul>
<li>Can be partially worked around by defining multiple versions
of same function with different amount of arguments</li>
of same function with different number of arguments</li>
</ul></li>
</ul>
<h2 id="roadmap">Roadmap</h2>
@ -167,34 +163,26 @@ Documentation - 0.6.0</title>
<p><a name="feature-implementation-table"></a></p>
<h2 id="primitives">Primitives</h2>
<p><a name="feature-implementation-table-primitives"></a></p>
<table style="width:100%;">
<table>
<colgroup>
<col style="width: 6%" />
<col style="width: 5%" />
<col style="width: 6%" />
<col style="width: 10%" />
<col style="width: 9%" />
<col style="width: 9%" />
<col style="width: 14%" />
<col style="width: 10%" />
<col style="width: 7%" />
<col style="width: 9%" />
<col style="width: 8%" />
<col style="width: 6%" />
<col style="width: 10%" />
<col style="width: 13%" />
<col style="width: 12%" />
<col style="width: 14%" />
<col style="width: 15%" />
</colgroup>
<thead>
<tr class="header">
<th></th>
<th style="text-align: center;">pffi-init</th>
<th style="text-align: center;">pffi-size-of</th>
<th style="text-align: center;">pffi-define-library</th>
<th style="text-align: center;">pffi-pointer-null</th>
<th style="text-align: center;">pffi-pointer-null?</th>
<th style="text-align: center;">pffi-pointer-address</th>
<th style="text-align: center;">pffi-pointer?</th>
<th style="text-align: center;">c-size-of</th>
<th style="text-align: center;">define-c-library</th>
<th style="text-align: center;">c-bytevector?</th>
<th style="text-align: center;">pffi-pointer-set!</th>
<th style="text-align: center;">pffi-pointer-get</th>
<th style="text-align: center;">pffi-define</th>
<th style="text-align: center;">define-c-procedure</th>
<th style="text-align: center;">pffi-define-callback</th>
</tr>
</thead>
@ -207,10 +195,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
</tr>
<tr class="even">
@ -222,10 +206,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
<tr class="odd">
<td>Cyclone</td>
@ -234,23 +214,15 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
</tr>
<tr class="even">
<td>Gambit</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
@ -263,18 +235,10 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
</tr>
<tr class="even">
<td>Gerbil</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
@ -292,10 +256,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
<tr class="even">
<td>Kawa</td>
@ -306,17 +266,9 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
<tr class="odd">
<td>Larceny</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
@ -332,10 +284,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
@ -348,10 +296,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
<tr class="even">
<td>Saggittarius</td>
@ -362,17 +306,9 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
<tr class="odd">
<td>Skint</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
@ -386,10 +322,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;">X</td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
@ -404,10 +336,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
</tr>
<tr class="even">
<td>Ypsilon</td>
@ -418,10 +346,6 @@ Documentation - 0.6.0</title>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr>
</tbody>
</table>
@ -430,8 +354,11 @@ Documentation - 0.6.0</title>
<p>These features are built upon the primitives and if
primitives are implemented and work, they should work too.</p>
<ul>
<li>pffi-pointer-allocate</li>
<li>pffi-pointer-free</li>
<li>make-c-bytevector</li>
<li>make-c-null</li>
<li>c-null?</li>
<li>pffi-pointer-address</li>
<li>c-free</li>
<li>pffi-pointer-&gt;string</li>
<li>pffi-string-&gt;pointer</li>
<li>pffi-struct-make</li>
@ -619,19 +546,19 @@ make &lt;SCHEME&gt;</code></pre>
<p>Always call this first, on most implementation it does
nothing but some implementations might need initialisation
run.</p>
<h4 id="pffi-size-of">pffi-size-of</h4>
<p><a name="pffi-size-of"></a></p>
<p><strong>pffi-size-of</strong> object -&gt; number</p>
<h4 id="c-size-of">c-size-of</h4>
<p><a name="c-size-of"></a></p>
<p><strong>c-size-of</strong> object -&gt; number</p>
<p>Returns the size of the pffi-struct, pffi-enum or
pffi-type.</p>
<h4 id="pffi-align-of">pffi-align-of</h4>
<p><a name="pffi-align-of"></a></p>
<p><strong>pffi-align-of</strong> type -&gt; number</p>
<p>Returns the align of the type.</p>
<h4 id="pffi-define-library">pffi-define-library</h4>
<p><a name="pffi-define-library"></a></p>
<p><strong>pffi-define-library</strong> headers
shared-object-name [options] -&gt; object</p>
<h4 id="define-c-library">define-c-library</h4>
<p><a name="define-c-library"></a></p>
<p><strong>define-c-library</strong> headers shared-object-name
[options] -&gt; object</p>
<p>Load given shared object automatically searching many
predefined paths.</p>
<p>Takes as argument a list of C headers, these are for the
@ -656,12 +583,12 @@ make &lt;SCHEME&gt;</code></pre>
</ul>
<p>Example:</p>
<pre><code>(cond-expand
(windows (pffi-define-library libc-stdlib
(windows (define-c-library libc-stdlib
&#39;(&quot;stdlib.h&quot;)
&quot;ucrtbase&quot;
&#39;((additional-versions (&quot;0&quot; &quot;6&quot;))
(additiona-paths (&quot;.&quot;)))))
(else (pffi-define-library libc-stdlib
(else (define-c-library libc-stdlib
(list &quot;stdlib.h&quot;)
&quot;c&quot;
&#39;((additional-versions (&quot;0&quot; &quot;6&quot;))
@ -681,38 +608,47 @@ make &lt;SCHEME&gt;</code></pre>
<li>As ’(… and not (list…</li>
</ul></li>
</ul>
<h4 id="pffi-pointer-null">pffi-pointer-null</h4>
<p><a name="pffi-pointer-null"></a></p>
<p><strong>pffi-pointer-null</strong> -&gt; pointer</p>
<h4 id="make-c-null">make-c-null</h4>
<p><a name="make-c-null"></a></p>
<p><strong>make-c-null</strong> -&gt; pointer</p>
<p>Returns a new NULL pointer.</p>
<h4 id="pffi-pointer-null-1">pffi-pointer-null?</h4>
<p><a name="pffi-pointer-null"></a></p>
<p><strong>pffi-pointer-null?</strong> pointer -&gt; boolean</p>
<h4 id="c-null">c-null?</h4>
<p><a name="is-c-null"></a></p>
<p><strong>c-null?</strong> pointer -&gt; boolean</p>
<p>Returns #t if given pointer is null pointer, #f
otherwise.</p>
<h4 id="pffi-pointer-allocate">pffi-pointer-allocate</h4>
<p><a name="pffi-pointer-allocate"></a></p>
<p><strong>pffi-pointer-allocate</strong> size -&gt; pointer</p>
<h4 id="make-c-bytevector">make-c-bytevector</h4>
<p><a name="make-c-bytevector "></a></p>
<p><strong>make-c-bytevector</strong> size -&gt; pointer</p>
<p>Returns newly allocated pointer of given size.</p>
<h4 id="pffi-pointer-address">pffi-pointer-address</h4>
<p><a name="pffi-pointer-address"></a></p>
<p><strong>pffi-pointer-address</strong> pointer -&gt;
number</p>
<p>Returns the address of given pointer as number.</p>
<h4 id="pffi-pointer">pffi-pointer?</h4>
pointer</p>
<p>Returns the address of given pointer inside a pointer. This
is used when passing pointers to pointers to foreign procedures.
This is similar to the c’s &amp;. One <strong>important
difference</strong> is that after you have passed a pointer to
the procedure you must get value from it back to the pointer
which address you are passing. Example:</p>
<pre><code>(define input-pointer (make-c-bytevector &lt;needed size&gt;))
(define input-pointer-address (pffi-pointer-address input-pointer))
(&lt;foreign-procedure-that takes &amp;pointer as argument&gt; input-pointer-address)
(set! input-pointer (pffi-pointer-get input-pointer-address &#39;pointer 0))</code></pre>
<h4 id="c-bytevector">c-bytevector?</h4>
<p><a name="pffi-pointer"></a></p>
<p><strong>pffi-pointer?</strong> object -&gt; boolean</p>
<p><strong>c-bytevector?</strong> object -&gt; boolean</p>
<p>Returns #t if given object is pointer, #f otherwise.</p>
<h4 id="pffi-pointer-free">pffi-pointer-free</h4>
<p><a name="pffi-pointer-free"></a></p>
<p><strong>pffi-pointer-free</strong> pointer</p>
<h4 id="c-free">c-free</h4>
<p><a name="c-free"></a></p>
<p><strong>c-free</strong> pointer</p>
<p>Frees given pointer.</p>
<h4 id="pffi-pointer-set">pffi-pointer-set!</h4>
<p><a name="pffi-pointer-set!"></a></p>
<p><strong>pffi-pointer-set!</strong> pointer type offset
value</p>
<p>Sets the value on a pointer on given offset. For example:</p>
<pre><code>(define p (pffi-pointer-allocate 128))
<pre><code>(define p (make-c-bytevector 128))
(pffi-pointer-set! p &#39;int 64 100)</code></pre>
<p>Would set the offset of 64, on pointer p to value 100.</p>
<h4 id="pffi-pointer-get">pffi-pointer-get</h4>
@ -721,18 +657,18 @@ make &lt;SCHEME&gt;</code></pre>
object</p>
<p>Gets the value from a pointer on given offset. For
example:</p>
<pre><code>(define p (pffi-pointer-allocate 128))
<pre><code>(define p (make-c-bytevector 128))
(pffi-pointer-set! p &#39;int 64 100)
(pffi-pointer-get p &#39;int 64)
&gt; 100</code></pre>
<h4 id="pffi-string-pointer">pffi-string-&gt;pointer</h4>
<p><a name="pffi-string->pointer"></a></p>
<p><strong>pffi-string-&gt;pointer</strong> string -&gt;
<h4 id="string-c-bytevector">string-&gt;c-bytevector</h4>
<p><a name="string-into-c-bytevector"></a></p>
<p><strong>string-&gt;c-bytevector</strong> string -&gt;
pointer</p>
<p>Makes pointer out of a given string.</p>
<h4 id="pffi-pointer-string">pffi-pointer-&gt;string</h4>
<p><a name="pffi-pointer->string"></a></p>
<p><strong>pffi-pointer-&gt;string</strong> pointer -&gt;
<h4 id="c-bytevector-string">c-bytevector-&gt;string</h4>
<p><a name="c-bytevector-into-string"></a></p>
<p><strong>c-bytevector-&gt;sring</strong> pointer -&gt;
string</p>
<p>Makes string out of a given pointer.</p>
<h4 id="pffi-struct-make">pffi-struct-make</h4>
@ -804,16 +740,16 @@ make &lt;SCHEME&gt;</code></pre>
<p><strong>pffi-array-&gt;list</strong> type list length</p>
<p>Converts given C array into list of given type and
length.</p>
<h4 id="pffi-define-function">pffi-define-function</h4>
<p><a name="pffi-define-function"></a></p>
<p><strong>pffi-define-function</strong> scheme-name
shared-object c-name return-type argument-types</p>
<h4 id="define-c-procedure">define-c-procedure</h4>
<p><a name="define-c-procedure"></a></p>
<p><strong>define-c-procedure</strong> scheme-name shared-object
c-name return-type argument-types</p>
<p>Defines a new foreign function to be used from Scheme code.
For example:</p>
<pre><code>(cond-expand
(windows (pffi-define-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;(&quot;&quot;)))
(else (pffi-define-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;c&quot; &#39;(&quot;&quot; &quot;6&quot;))))
(pffi-define-function c-puts libc-stdlib &#39;puts &#39;int &#39;(pointer))
(windows (define-c-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;(&quot;&quot;)))
(else (define-c-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;c&quot; &#39;(&quot;&quot; &quot;6&quot;))))
(define-c-procedure c-puts libc-stdlib &#39;puts &#39;int &#39;(pointer))
(c-puts &quot;Message brought to you by FFI!&quot;)</code></pre>
<h4 id="pffi-define-callback">pffi-define-callback</h4>
<p><a name="pffi-define-callback"></a></p>
@ -823,11 +759,11 @@ make &lt;SCHEME&gt;</code></pre>
code. For example:</p>
<pre><code>; Load the shared library
(cond-expand
(windows (pffi-define-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;()))
(else (pffi-define-library &#39;(&quot;stdlib.h&quot;) &quot;c&quot; &#39;(&quot;&quot; &quot;6&quot;))))
(windows (define-c-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;()))
(else (define-c-library &#39;(&quot;stdlib.h&quot;) &quot;c&quot; &#39;(&quot;&quot; &quot;6&quot;))))
; Define C function that takes a callback
(pffi-define-function qsort libc-stdlib &#39;qsort &#39;void &#39;(pointer int int callback))
(define-c-procedure qsort libc-stdlib &#39;qsort &#39;void &#39;(pointer int int callback))
; Define our callback
(pffi-define-callback compare
@ -841,17 +777,17 @@ make &lt;SCHEME&gt;</code></pre>
((&lt; a b) -1)))))
; Create new array of ints to be sorted
(define array (pffi-pointer-allocate (* (pffi-size-of &#39;int) 3)))
(pffi-pointer-set! array &#39;int (* (pffi-size-of &#39;int) 0) 3)
(pffi-pointer-set! array &#39;int (* (pffi-size-of &#39;int) 1) 2)
(pffi-pointer-set! array &#39;int (* (pffi-size-of &#39;int) 2) 1)
(define array (make-c-bytevector (* (c-size-of &#39;int) 3)))
(pffi-pointer-set! array &#39;int (* (c-size-of &#39;int) 0) 3)
(pffi-pointer-set! array &#39;int (* (c-size-of &#39;int) 1) 2)
(pffi-pointer-set! array &#39;int (* (c-size-of &#39;int) 2) 1)
(display array)
(newline)
;&gt; (3 2 1)
; Sort the array
(qsort array 3 (pffi-size-of &#39;int) compare)
(qsort array 3 (c-size-of &#39;int) compare)
(display array)
(newline)

BIN
documentation/R7RS-PFFI.pdf
View File

Binary file not shown.

208
retropikzel/pffi.sld
View File

@ -1,14 +1,15 @@
(define-library
(retropikzel pffi)
(retropikzel pffi) ; (foreign r7rs)? (foreign c)?
(cond-expand
(chibi
(import (scheme base)
(import (except (scheme base) bytevector-copy!)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(chibi ast)
(chibi))
(chibi)
(r6rs bytevectors))
(include-shared "pffi/chibi-pffi"))
(chicken
(import (scheme base)
@ -21,7 +22,8 @@
(chicken locative)
(chicken syntax)
(chicken memory)
(chicken random)))
(chicken random)
(r6rs bytevectors)))
(cyclone
(import (scheme base)
(scheme write)
@ -29,14 +31,16 @@
(scheme file)
(scheme process-context)
(cyclone foreign)
(scheme cyclone primitives)))
(scheme cyclone primitives)
(r6rs bytevectors)))
(gambit
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (gambit) c-declare c-lambda c-define define-macro)))
(only (gambit) c-declare c-lambda c-define define-macro)
(r6rs bytevectors)))
(gauche
(import (scheme base)
(scheme write)
@ -44,29 +48,32 @@
(scheme file)
(scheme process-context)
(gauche base)
(retropikzel pffi gauche)))
(retropikzel pffi gauche)
(r6rs bytevectors)))
(gerbil
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(scheme process-context)
(r6rs bytevectors)))
(guile
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library)
(only (guile) include-from-path)))
(only (guile) include-from-path)
(rnrs bytevectors)))
(kawa
(import (scheme base)
(import (except (scheme base) bytevector-copy bytevector-copy!)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(scheme process-context)
(r6rs bytevectors)))
(larceny
(import (scheme base)
(scheme write)
@ -77,14 +84,16 @@
(primitives std-ffi)
(primitives foreign-procedure)
(primitives foreign-file)
(primitives foreign-stdlib)))
(primitives foreign-stdlib)
(r6rs bytevectors)))
(mosh
(import (scheme base)
(import (except (scheme base) bytevector-copy!)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(mosh ffi)))
(mosh ffi)
(r6rs bytevectors)))
(racket
(import (scheme base)
(scheme write)
@ -95,37 +104,87 @@
(ffi winapi)
(compatibility mlist)
(ffi unsafe)
(ffi vector)))
(ffi vector)
(except (r6rs bytevectors) bytevector-copy!)))
(sagittarius
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius)))
(except (sagittarius ffi) c-free c-malloc)
(sagittarius)
(r6rs bytevectors)))
(skint
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(scheme process-context)
(r6rs bytevectors)))
(stklos
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(stklos))
(only (stklos)
make-external-function
allocate-bytes
free-bytes
cpointer?
cpointer-null?
cpointer-data
cpointer-data-set!
pointer-set-c-int8_t!
pointer-ref-c-int8_t
pointer-set-c-uint8_t!
pointer-ref-c-uint8_t
pointer-set-c-int16_t!
pointer-ref-c-int16_t
pointer-set-c-uint16_t!
pointer-ref-c-uint16_t
pointer-set-c-int32_t!
pointer-ref-c-int32_t
pointer-set-c-uint32_t!
pointer-ref-c-uint32_t
pointer-set-c-int64_t!
pointer-ref-c-int64_t
pointer-set-c-uint64_t!
pointer-ref-c-uint64_t
pointer-set-c-char!
pointer-ref-c-char
pointer-set-c-short!
pointer-ref-c-short
pointer-set-c-unsigned-short!
pointer-ref-c-unsigned-short
pointer-set-c-int!
pointer-ref-c-int
pointer-set-c-unsigned-int!
pointer-ref-c-unsigned-int
pointer-set-c-long!
pointer-ref-c-long
pointer-set-c-unsigned-long!
pointer-ref-c-unsigned-long
pointer-set-c-float!
pointer-ref-c-float
pointer-set-c-double!
pointer-ref-c-double
pointer-set-c-pointer!
pointer-ref-c-pointer
void?)
(r6rs bytevectors))
(export make-external-function
calculate-struct-size-and-offsets
struct-make))
struct-make
pffi:string-split))
(tr7
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(scheme process-context)
(r6rs bytevectors)))
(ypsilon
(import (scheme base)
(scheme write)
@ -134,42 +193,67 @@
(scheme process-context)
(ypsilon c-ffi)
(ypsilon c-types)
(only (core) define-macro syntax-case))))
(export pffi-init
pffi-size-of
pffi-type?
pffi-align-of
pffi-define-library
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer-address
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define-struct
pffi-struct-pointer
pffi-struct-offset-get
pffi-struct-get
pffi-struct-set!
pffi-array-allocate
pffi-array-pointer
pffi-array?
pffi-pointer->array
pffi-array-get
pffi-array-set!
pffi-list->array
pffi-array->list
pffi-define-function
pffi-define-callback)
(only (core) define-macro syntax-case)
(except (rnrs bytevectors)
bytevector-copy!
bytevector-copy
string->utf8
utf8->string))))
(export ;; Primitives
c-size-of
define-c-library
define-c-procedure
;pffi-define-callback; define-c-callback (?)
c-bytevector?
pffi-pointer-set!;c-bytevector-u8-set! and so on
pffi-pointer-get;c-bytevector-u8-ref and so on
;; c-bytevector
make-c-bytevector
c-bytevector ;; TODO Documentation, Testing
make-c-null
c-null?
c-free
c-bytevector-string-length ;; TODO Documentation, Testing
bytevector->c-bytevector
c-bytevector->bytevector
call-with-address-of-c-bytevector ;; Todo Documentation
string->c-bytevector
c-bytevector->string
;c-bytevector-u8-ref ;; TODO Documentation, Testing
;; c-struct
pffi-define-struct;define-c-struct
pffi-struct-pointer;c-struct-bytevector
pffi-struct-offset-get;c-struct-offset
pffi-struct-set!;c-struct-set!
pffi-struct-get;c-struct-get
;; c-array
;define-c-array (?)
pffi-array-allocate;make-c-array
pffi-array-pointer;c-array-pointer
pffi-array?;c-array?
pffi-pointer->array;c-bytevector->array
pffi-array-get;c-array-get
pffi-array-set!;c-array-set!
pffi-list->array;list->c-array
pffi-array->list;c-array->list
;; c-variable
;define-c-variable (?)
)
(cond-expand
(chibi (include "pffi/chibi.scm"))
(chicken-5 (include "pffi/chicken.scm"))
(chicken-5 (export foreign-declare
foreign-safe-lambda
void)
(include "pffi/chicken.scm"))
(chicken-6 (include-relative "pffi/chicken.scm"))
(cyclone (include "pffi/cyclone.scm"))
(cyclone (export calculate-struct-size-and-offsets
struct-make)
(include "pffi/cyclone.scm"))
(gambit (include "pffi/gambit.scm"))
(gauche (include "pffi/gauche.scm"))
(gerbil (include "pffi/gerbil.scm"))
@ -182,14 +266,14 @@
(skint (include "pffi/skint.scm"))
(stklos (include "pffi/stklos.scm"))
(tr7 (include "pffi/tr7.scm"))
(ypsilon (include "pffi/ypsilon.scm")))
;(include "pffi/shared/union.scm")
(ypsilon (export c-function)
(include "pffi/ypsilon.scm")))
(cond-expand
(chicken-6 (include-relative "pffi/shared/main.scm")
(include-relative "pffi/shared/pointer.scm")
(include-relative "pffi/shared/array.scm")
(include-relative "pffi/shared/struct.scm"))
(include-relative "pffi/shared/pointer.scm")
(include-relative "pffi/shared/array.scm")
(include-relative "pffi/shared/struct.scm"))
(else (include "pffi/shared/main.scm")
(include "pffi/shared/struct.scm")
(include "pffi/shared/pointer.scm")
(include "pffi/shared/array.scm")
(include "pffi/shared/struct.scm"))))
(include "pffi/shared/array.scm"))))

28
retropikzel/pffi/chibi-src/pffi.stub
View File

@ -4,7 +4,7 @@
(c-system-include "dlfcn.h")
(c-system-include "ffi.h")
;; pffi-size-of
;; c-size-of
(c-declare "
int size_of_int8_t() { return sizeof(int8_t); }
int size_of_uint8_t() { return sizeof(uint8_t); }
@ -47,7 +47,7 @@
(define-c int (size-of-double size_of_double) ())
(define-c int (size-of-pointer size_of_pointer) ())
;; pffi-shape-object-load
;; pffi-shared-object-load
(define-c-const int (RTLD-NOW "RTLD_NOW"))
(define-c (maybe-null pointer void*) dlopen (string int))
(define-c (maybe-null pointer void*) dlerror ())
@ -70,10 +70,10 @@
}")
(define-c sexp (pointer? is_pointer) (sexp))
(c-declare "intptr_t pointer_address(struct sexp_struct* pointer) {
return (intptr_t)&sexp_cpointer_value(pointer);
(c-declare "void* pointer_address(struct sexp_struct* pointer) {
return (void*)&sexp_cpointer_value(pointer);
}")
(define-c uint32_t (pointer-address pointer_address) (sexp))
(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp))
(c-declare "void pointer_free(void* pointer) { free(pointer); }")
(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
@ -99,8 +99,8 @@
(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { *((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char))
(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t))
(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
@ -149,8 +149,8 @@
(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }")
(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
(c-declare "char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }")
(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
@ -178,15 +178,7 @@
(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
;; pffi-string->pointer
;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }")
;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string))
;; pffi-pointer->string
;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
;; pffi-define-function
;; define-c-procedure
(c-declare "ffi_cif cif;")
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string))

52
retropikzel/pffi/chibi.scm
View File

@ -29,32 +29,22 @@
(lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror)))
(when (not (pffi-pointer-null? maybe-error))
(error (pffi-pointer->string maybe-error)))
#;(when (not (pffi-pointer-null? maybe-error))
(error (c-bytevector->string maybe-error)))
shared-object)))
(define pffi-pointer-null
(lambda ()
(pointer-null)))
(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is null on Chibi
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(or (equal? object #f) ; False can be null pointer
(pointer? object))))
(define pffi-pointer-allocate
(lambda (size)
(pointer-allocate size)))
(define make-c-bytevector
(lambda (k . byte)
(if (null? byte)
(pointer-allocate k)
(bytevector->c-bytevector (make-bytevector k byte)))))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-free
(define c-free
(lambda (pointer)
(pointer-free pointer)))
@ -68,7 +58,7 @@
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
@ -90,7 +80,7 @@
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (pointer-ref-c-char pointer offset))
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset))
@ -102,14 +92,6 @@
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
#;(define pffi-string->pointer
(lambda (string-content)
(string-to-pointer string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer-to-string pointer)))
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
@ -136,7 +118,7 @@
((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
;; pffi-define-function
;; define-c-procedure
(define pffi-type->libffi-type
(lambda (type)
@ -166,7 +148,7 @@
(define argument->pointer
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(else (let ((pointer (make-c-bytevector (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
pointer)))))
@ -175,10 +157,10 @@
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments
(let ((return-value (pffi-pointer-allocate
(let ((return-value (make-c-bytevector
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
@ -193,7 +175,7 @@
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name

34
retropikzel/pffi/chicken.scm
View File

@ -25,11 +25,11 @@
((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(pointer? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
@ -136,18 +136,17 @@
((equal? type 'string) (foreign-value "sizeof(void*)" int))
((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
#;(define pffi-pointer-allocate
(lambda (size)
(allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer->address pointer)))
(define pffi-pointer-null
(define make-c-null
(lambda ()
(address->pointer 0)))
(define-syntax define-c-library
(syntax-rules ()
((_ scheme-name headers object-name options)
(begin
(define scheme-name #t)
(pffi-shared-object-load headers)))))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
@ -158,13 +157,7 @@
`(foreign-declare ,(string-append "#include <" header ">")))
headers))))))
#;(define pffi-pointer-free
(lambda (pointer)
(if (not (pointer? pointer))
(error "pffi-pointer-free -- Argument is not pointer" pointer))
(free pointer)))
(define pffi-pointer-null?
(define c-null?
(lambda (pointer)
(if (and (not (pointer? pointer))
pointer)
@ -215,8 +208,3 @@
((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
(define pffi-struct-dereference
(lambda (struct)
(pffi-pointer-address (pffi-struct-pointer struct))))

70
retropikzel/pffi/cyclone.scm
View File

@ -23,23 +23,23 @@
((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(opaque? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
(cond ((equal? type 'int8) 'int)
((equal? type 'uint8) 'int)
((equal? type 'int16) 'int)
((equal? type 'uint16) 'int)
((equal? type 'int32) 'int)
((equal? type 'uint32) 'int)
((equal? type 'int64) 'int)
((equal? type 'uint64) 'int)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
@ -50,22 +50,21 @@
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'void) 'void)
((equal? type 'struct) 'c-pointer)
((equal? type 'pointer) 'opaque)
((equal? type 'void) 'c-void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(scheme-name (cadr expr))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types)))))))
(map pffi-type->native-type types)))))
(if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name
,return-type ,c-name ,@ argument-types))))))
,return-type ,c-name ,@argument-types))))))
(define pffi-define-callback
(lambda (scheme-name return-type argument-types procedure)
@ -93,38 +92,31 @@
((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
#;(define-c pffi-pointer-allocate
"(void *data, int argc, closure _, object k, object size)"
"make_c_opaque(opq, malloc(obj_obj2int(size)));
(define-c pffi-pointer-address
"(void *data, int argc, closure _, object k, object pointer)"
"make_c_opaque(opq, &(void*)opaque_ptr(pointer));
return_closcall1(data, k, &opq);")
(define pffi-pointer-null
(lambda ()
(make-opaque)))
#;(define-c pffi-string->pointer
"(void *data, int argc, closure _, object k, object s)"
"make_c_opaque(opq, string_str(s));
return_closcall1(data, k, &opq);")
#;(define-c pffi-pointer->string
"(void *data, int argc, closure _, object k, object p)"
"make_string(s, opaque_ptr(p));
return_closcall1(data, k, &s);")
(define-syntax define-c-library
(syntax-rules ()
((_ scheme-name headers object-name options)
(begin
(define scheme-name #t)
(pffi-shared-object-load headers)))))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
`(begin
,@ (map
(lambda (header)
`(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr))))))))
#;(define-c pffi-pointer-free
"(void *data, int argc, closure _, object k, object pointer)"
"free(opaque_ptr(pointer));
return_closcall1(data, k, make_boolean(boolean_t));")
(let* ((headers (cadr (cadr expr)))
(includes (map
(lambda (header)
`(include-c-header ,(string-append "<" header ">")))
headers)))
`(,@includes)))))
(define pffi-pointer-null?
(lambda (pointer)

119
retropikzel/pffi/gambit.scm
View File

@ -1,11 +1,6 @@
(c-declare "#include <stdlib.h>")
(c-declare "#include <stdint.h>")
(define-macro
(pffi-init)
`(begin (c-define-type pointer (pointer void))
(c-define-type callback (pointer void))))
(define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));"))
(define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));"))
@ -52,16 +47,18 @@
(else (error "Can not get size of unknown type" type)))))
(define-macro
(pffi-define-library name headers object-name . options)
`(begin (define ,name #t)
(c-declare ,(apply string-append
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(cdr headers))))))
(define-c-library name headers object-name . options)
(begin
(let ((c-code (apply string-append
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(car (cdr headers))))))
`(begin (define ,name #t) (c-declare ,c-code)))))
(define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(call-with-current-continuation
(lambda (k)
@ -69,20 +66,6 @@
(lambda (x) #f)
(lambda () (pointer? object)))))))
(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);"))
(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }"))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(pointer-null? pointer))))
;(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
;(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
@ -167,31 +150,57 @@
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define-macro
(pffi-define-function scheme-name shared-object c-name return-type argument-types)
(letrec* ((native-argument-types
(if (equal? '(list) argument-types)
(list)
(let ((types (map cdr (cdr argument-types))))
(if (null? types) types (map car types)))))
(native-return-type (car (cdr return-type)))
(c-arguments (lambda (index argument-count result)
(if (> index argument-count)
result
(c-arguments (+ index 1)
argument-count
(string-append result
"___arg"
(number->string index)
(if (< index argument-count)
", "
""))))))
(c-code (string-append
(if (equal? 'void (cadr return-type)) "" "___return(")
(symbol->string (cadr c-name))
"(" (c-arguments 1 (- (length argument-types) 1) "") ")"
(if (equal? 'void (cadr return-type)) "" ")")
";")))
`(define ,scheme-name
(c-lambda ,native-argument-types
,native-return-type
,c-code))))
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
(begin
(letrec* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-int8)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'int64)
((equal? type 'uint64) 'unsigned-int64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-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) '(pointer void))
((equal? type 'void) 'void)
((equal? type 'callback) 'c-pointer)
((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(native-argument-types
(if (equal? '(list) argument-types)
(list)
(let ((types (map pffi-type->native-type (cadr argument-types))))
(if (null? types) types types))))
(native-return-type (pffi-type->native-type (cadr return-type)))
(argument-count (length native-argument-types))
(c-arguments (lambda (index result)
(if (>= index argument-count)
result
(c-arguments (+ index 1)
(string-append result
"___arg"
(number->string (+ index 1))
(if (<= index (- argument-count 2))
", "
""))))))
(c-code (string-append
(if (equal? 'void (cadr return-type)) "" "___return(")
(symbol->string (cadr c-name))
"(" (c-arguments 0 "") ")"
(if (equal? 'void (cadr return-type)) "" ")")
";")))
`(define ,scheme-name
(c-lambda ,native-argument-types
,native-return-type
,c-code)))))

2
retropikzel/pffi/gauche-src/gauchelib.scm
View File

@ -71,8 +71,6 @@
(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
(define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
(define-cproc string->pointer (string-content) string_to_pointer)
(define-cproc pointer->string (pointer) pointer_to_string)
(define-cproc dlerror () pffi_dlerror)
(define-cproc dlsym (shared-object c-name) pffi_dlsym)
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)

42
retropikzel/pffi/gauche.scm
View File

@ -1,17 +1,15 @@
(define-module retropikzel.pffi.gauche
(export size-of-type
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
;pffi-pointer-null
;pffi-pointer-null?
make-c-bytevector
pffi-pointer-address
pffi-pointer?
pffi-pointer-free
c-bytevector?
c-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define-function))
define-c-procedure))
(select-module retropikzel.pffi.gauche)
(dynamic-load "retropikzel/pffi/gauche-pffi")
@ -45,27 +43,15 @@
(lambda (path options)
(shared-object-load path)))
(define pffi-pointer-null
(lambda ()
(pointer-null)))
(define pffi-pointer-null?
(lambda (pointer)
(pointer-null? pointer)))
(define pffi-pointer-allocate
(define make-c-bytevector
(lambda (size)
(pointer-allocate size)))
(define pffi-pointer-address
(lambda (object)
(pointer-address object)))
(define pffi-pointer?
(define c-bytevector?
(lambda (pointer)
(pointer? pointer)))
(define pffi-pointer-free
(define c-free
(lambda (pointer)
(pointer-free pointer)))
@ -141,7 +127,7 @@
(define argument->pointer
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(else (let ((pointer (make-c-bytevector (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
pointer)))))
@ -150,10 +136,10 @@
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments
(let ((return-value (pffi-pointer-allocate
(let ((return-value (make-c-bytevector
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
@ -168,7 +154,7 @@
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name

32
retropikzel/pffi/gerbil.scm
View File

@ -2,11 +2,11 @@
(lambda (type)
(error "Not defined")))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
@ -15,34 +15,10 @@
(lambda (type)
(error "Not defined")))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
#;(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
#;(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-shared-object-load
(lambda (header path)
(error "Not defined")))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-null?
(lambda (pointer)
(error "Not defined")))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
@ -51,7 +27,3 @@
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))

43
retropikzel/pffi/guile.scm
View File

@ -25,11 +25,11 @@
((equal? type 'struct) '*)
(else #f))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(pointer? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
@ -53,39 +53,10 @@
(native-type (sizeof native-type))
(else #f)))))
#;(define pffi-pointer-allocate
(lambda (size)
(bytevector->pointer (make-bytevector size 0))))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-null
(lambda ()
(make-pointer 0)))
#;(define pffi-string->pointer
(lambda (string-content)
(string->pointer string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-shared-object-load
(lambda (path options)
(load-foreign-library path)))
#;(define pffi-pointer-free
(lambda (pointer)
#t))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(null-pointer? pointer))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100))))
@ -106,8 +77,7 @@
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (size-of-type type)))))))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
(define pffi-pointer-get
(lambda (pointer type offset)
@ -129,9 +99,4 @@
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))))
#;(define pffi-struct-dereference
(lambda (struct)
(dereference-pointer (pffi-struct-pointer struct))))
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))

32
retropikzel/pffi/kawa.scm
View File

@ -54,14 +54,14 @@
((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
(else #f))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((pffi-define-function scheme-name shared-object c-name return-type argument-types)
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(lambda vals
(invoke (invoke (cdr (assoc 'linker shared-object))
@ -131,28 +131,10 @@
(invoke native-type 'byteAlignment)
#f))))
#;(define pffi-pointer-allocate
(lambda (size)
(invoke (invoke arena 'allocate size 1) 'reinterpret size)))
(define pffi-pointer-address
(lambda (pointer)
(invoke pointer 'address)))
(define pffi-pointer-null
(define make-c-null
(lambda ()
(static-field java.lang.foreign.MemorySegment 'NULL)))
#;(define pffi-string->pointer
(lambda (string-content)
(let ((size (+ (invoke string-content 'length) 1)))
(invoke (invoke arena 'allocateFrom (invoke string-content 'toString))
'reinterpret size))))
#;(define pffi-pointer->string
(lambda (pointer)
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0)))
(define pffi-shared-object-load
(lambda (path options)
(let* ((library-file (make java.io.File path))
@ -169,11 +151,7 @@
(list (cons 'linker linker)
(cons 'lookup lookup)))))
#;(define pffi-pointer-free
(lambda (pointer)
#t))
(define pffi-pointer-null?
(define c-null?
(lambda (pointer)
(invoke pointer 'equals (pffi-pointer-null))))

43
retropikzel/pffi/larceny.scm
View File

@ -1,6 +1,4 @@
(require 'std-ffi)
;(require "Standard/foreign-stdlib")
;(require "Lib/Common/system-interface")
;; FIXME
(define size-of-type
@ -28,49 +26,12 @@
((eq? type 'callback) 4)
(else (error "Can not get size of unknown type" type)))))
(define c-malloc (foreign-procedure "malloc" '(int) 'void*))
;(define c-malloc (stdlib/malloc rtd-void*))
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
#;(define c-free (foreign-procedure "free" '(void*) 'int))
;(define c-malloc (stdlib/malloc rtd-void*))
#;(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
(define pffi-pointer-null (lambda () 0))
(define pffi-pointer-null?
(lambda (object)
(and (number? object)
(= object 0))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
;(void*? object)
(number? object)
))
(define pffi-pointer-address
(lambda (pointer)
;(void*->address pointer)
pointer
))
(define pffi-pointer->string
(lambda (pointer)
;(char*->string pointer)
pointer
))
(define pffi-string->pointer
(lambda (string-content)
;(string->char* string-content)
string-content
))
(define pffi-shared-object-load
(lambda (headers path . options)
(foreign-file path)))
@ -122,7 +83,7 @@
((equal? type 'void) (%peek-pointer (+ pointer offset)))
((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name

46
retropikzel/pffi/mosh.scm
View File

@ -25,33 +25,13 @@
(else #f))))
(define pffi-shared-object-load
(lambda (path . options)
(lambda (path options)
(open-shared-library path)))
(define pffi-pointer-null
(lambda ()
pointer-null))
(define pffi-pointer-null?
(lambda (pointer)
(pointer-null? pointer)))
#;(define pffi-pointer-allocate
(lambda (size)
(malloc size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer->integer pointer)))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(pointer? object)))
#;(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
@ -96,22 +76,6 @@
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
#;(define pffi-string->pointer
(lambda (string-content)
(let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1)))
(index 0))
(string-for-each
(lambda (c)
(pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) c)
(set! index (+ index 1)))
string-content)
(pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null)
pointer)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
@ -139,7 +103,7 @@
((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
@ -155,7 +119,3 @@
(make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)
procedure)))))
#;(define pffi-struct-dereference
(lambda (struct)
(pffi-struct-pointer struct)))

42
retropikzel/pffi/racket.scm
View File

@ -21,15 +21,14 @@
((equal? type 'pointer) _pointer)
((equal? type 'void) _void)
((equal? type 'callback) _pointer)
((equal? type 'string) _pointer)
((equal? type 'struct) _pointer)
(else #f))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(cpointer? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
@ -53,31 +52,6 @@
(ctype-sizeof native-type)
#f))))
#;(define pffi-pointer-allocate
(lambda (size)
(malloc 'raw size)))
(define pffi-pointer-address
(lambda (pointer)
pointer))
(define pffi-pointer-null
(lambda ()
#f )) ; #f is the null pointer on racket
#;(define pffi-string->pointer
(lambda (string-content)
(let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1))))
(memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
pointer)))
#;(define pffi-pointer->string
(lambda (pointer)
(when (pffi-pointer-null? pointer)
(error "Can not make string from null pointer" pointer))
(string-copy (cast pointer _pointer _string))))
(define pffi-shared-object-load
(lambda (path options)
(if (and (not (null? options))
@ -87,14 +61,6 @@
(list #f))))
(ffi-lib path))))
#;(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is the null pointer on racket
(define pffi-pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer
@ -114,7 +80,3 @@
(if (equal? type 'char)
(integer->char r)
r))))
#;(define pffi-struct-dereference
(lambda (struct)
(pffi-struct-pointer struct)))

106
retropikzel/pffi/sagittarius.scm
View File

@ -1,3 +1,33 @@
(define size-of-type
(lambda (type)
(cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_t)
((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) size-of-long)
((eq? type 'unsigned-long) size-of-unsigned-long)
((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double)
((eq? type 'pointer) size-of-void*)
((eq? type 'void) 0)
((eq? type 'string) size-of-void*)
((eq? type 'callback) size-of-void*)
(else #f))))
(define pffi-shared-object-load
(lambda (path options)
(open-shared-library path)))
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
@ -25,11 +55,7 @@
((and (pair? type) (equal? 'struct (car type))) 'void*)
(else #f))))
(define pffi-pointer?
(lambda (object)
(pointer? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
@ -46,72 +72,9 @@
(map pffi-type->native-type argument-types)
procedure)))))
(define size-of-type
(lambda (type)
(cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t)
((eq? type 'int16) size-of-int16_t)
((eq? type 'uint16) size-of-uint16_t)
((eq? type 'int32) size-of-int32_t)
((eq? type 'uint32) size-of-uint32_t)
((eq? type 'int64) size-of-int64_t)
((eq? type 'uint64) size-of-uint64_t)
((eq? type 'char) size-of-char)
((eq? type 'unsigned-char) size-of-char)
((eq? type 'short) size-of-short)
((eq? type 'unsigned-short) size-of-unsigned-short)
((eq? type 'int) size-of-int)
((eq? type 'unsigned-int) size-of-unsigned-int)
((eq? type 'long) size-of-long)
((eq? type 'unsigned-long) size-of-unsigned-long)
((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double)
((eq? type 'pointer) size-of-void*)
((eq? type 'void) 0)
((eq? type 'string) size-of-void*)
((eq? type 'callback) size-of-void*)
(else #f))))
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
(define pffi-pointer-address
(lambda (pointer)
(address pointer)))
(define pffi-pointer-null
(lambda ()
(empty-pointer)))
#;(define (string->c-string s)
(let* ((bv (string->utf8 s))
(p (allocate-pointer (+ (bytevector-length bv) 1))))
(do ((i 0 (+ i 1)))
((= i (bytevector-length bv)) p)
(pointer-set-c-uint8! p i (bytevector-u8-ref bv i)))
p))
#;(define pffi-string->pointer
(lambda (string-content)
(string->c-string string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-shared-object-load
(lambda (path options)
(open-shared-library path)))
#;(define pffi-pointer-free
(lambda (pointer)
(when (pointer? pointer)
(c-free pointer))))
(define pffi-pointer-null?
(lambda (pointer)
(null-pointer? pointer)))
(define c-bytevector?
(lambda (object)
(pointer? object)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
@ -156,3 +119,4 @@
((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))

12
retropikzel/pffi/shared/array.scm
View File

@ -8,8 +8,8 @@
(define pffi-list->array
(lambda (type list-arg)
(let* ((array-size (length list-arg))
(type-size (pffi-size-of type))
(array (pffi-pointer-allocate (* type-size array-size)))
(type-size (c-size-of type))
(array (make-c-bytevector (* type-size array-size)))
(offset 0))
(for-each
(lambda (item)
@ -25,7 +25,7 @@
(define pffi-array->list
(lambda (array)
(letrec* ((type (pffi-array-type array))
(type-size (pffi-size-of type))
(type-size (c-size-of type))
(max-offset (* type-size (pffi-array-size array)))
(array-pointer (pffi-array-pointer array))
(looper (lambda (offset result)
@ -40,19 +40,19 @@
(define pffi-array-allocate
(lambda (type size)
(array-make type size (pffi-pointer-allocate-calloc size (pffi-size-of type)))))
(array-make type size (pffi-pointer-allocate-calloc size (c-size-of type)))))
(define pffi-array-get
(lambda (array index)
(let ((type (pffi-array-type array)))
(pffi-pointer-get (pffi-array-pointer array)
type
(* (pffi-size-of type) index)))))
(* (c-size-of type) index)))))
(define pffi-array-set!
(lambda (array index value)
(let ((type (pffi-array-type array)))
(pffi-pointer-set! (pffi-array-pointer array)
type
(* (pffi-size-of type) index)
(* (c-size-of type) index)
value))))

54
retropikzel/pffi/shared/main.scm
View File

@ -1,4 +1,4 @@
(cond-expand
#;(cond-expand
(mosh (define pffi-init (lambda () #t)))
(chicken
(define-syntax pffi-init
@ -8,7 +8,7 @@
(chicken memory))
#t))))
(gambit #t)
(ypsilon
#;(ypsilon
(define-syntax pffi-init
(syntax-rules ()
((_)
@ -22,37 +22,12 @@
#f
#t)))
(define pffi-size-of
(define c-size-of
(lambda (object)
(cond ((pffi-struct? object) (pffi-struct-size object))
((pffi-type? object) (size-of-type object))
(else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
(define pffi-string->pointer
(lambda (str)
(letrec* ((str-length (string-length str))
(pointer (pffi-pointer-allocate (+ str-length 1)))
(looper (lambda (index)
(when (< index str-length)
(pffi-pointer-set! pointer
'char
index
(string-ref str index))
(looper (+ index 1))))))
(looper 0)
(pffi-pointer-set! pointer 'char str-length #\null)
pointer)))
(define pffi-pointer->string
(lambda (pointer)
(letrec* ((looper (lambda (index str)
(let ((c (pffi-pointer-get pointer 'char index)))
(if (char=? c #\null)
str
(looper (+ index 1) (cons c str)))))))
(list->string (reverse (looper 0 (list)))))))
(define pffi-types
'(int8
uint8
@ -75,7 +50,7 @@
pointer
void))
(define string-split
(define pffi:string-split
(lambda (str mark)
(let* ((str-l (string->list str))
(res (list))
@ -93,16 +68,11 @@
res)))
(cond-expand
(gambit #t)
((or chicken cyclone)
(define-syntax pffi-define-library
(syntax-rules ()
((_ scheme-name headers object-name options)
(begin
(define scheme-name #t)
(pffi-shared-object-load headers))))))
(gambit #t) ; Defined in pffi/gambit.scm
(chicken #t) ; Defined in pffi/chicken.scm
(cyclone #t) ; Defined in pffi/cyclone.scm
(else
(define-syntax pffi-define-library
(define-syntax define-c-library
(syntax-rules ()
((_ scheme-name headers object-name options)
(define scheme-name
@ -125,7 +95,7 @@
(windows
(append
(if (get-environment-variable "PFFI_LOAD_PATH")
(string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
(list))
(if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM"))
@ -144,7 +114,7 @@
(list))
(list ".")
(if (get-environment-variable "PATH")
(string-split (get-environment-variable "PATH") #\;)
(pffi:string-split (get-environment-variable "PATH") #\;)
(list))
(if (get-environment-variable "PWD")
(list (get-environment-variable "PWD"))
@ -152,7 +122,7 @@
(else
(append
(if (get-environment-variable "PFFI_LOAD_PATH")
(string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
(list))
; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
@ -161,7 +131,7 @@
"/run/current-system/profile/lib")
; Debian
(if (get-environment-variable "LD_LIBRARY_PATH")
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(pffi:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(list))
(list
;;; x86-64

152
retropikzel/pffi/shared/pointer.scm
View File

@ -1,75 +1,105 @@
(cond-expand
(windows (pffi-define-library pffi-libc-stdlib
'("stdlib.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (pffi-define-library pffi-libc-stdlib
'("stdlib.h")
"c"
'((additional-versions ("0" "6"))))))
(windows (define-c-library libc
'("stdlib.h" "string.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (define-c-library libc
'("stdlib.h" "string.h")
"c"
'((additional-versions ("0" "6"))))))
(cond-expand
(windows (pffi-define-library pffi-libc-stdio
'("stdio.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (pffi-define-library pffi-libc-stdio
'("stdio")
"c"
'((additional-versions ("0" "6"))))))
;(pffi-define-function c-snprintf pffi-libc-stdio 'snprintf 'int '(pointer int pointer pointer))
;(pffi-define-function c-strtol pffi-libc-stdio 'strtol 'uint64 '(pointer pointer int))
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int))
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(cond-expand
(chibi #t) ; FIXME
(else (pffi-define-function pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
(else (define make-c-bytevector
(lambda (k . byte)
(if (null? byte)
(c-malloc k)
(bytevector->c-bytevector (make-bytevector k (car byte))))))))
(pffi-define-function pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(define c-bytevector
(lambda bytes
(bytevector->c-bytevector (apply bytevector bytes))))
(cond-expand
(chibi #t) ; FIXME
(else (pffi-define-function pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
(else (define-c-procedure c-free libc 'free 'void '(pointer))))
#;(define pffi-pointer-null
(lambda ()
(let ((pointer (pffi-pointer-allocate (pffi-size-of 'pointer))))
(pffi-pointer-set! pointer 'int 0 0)
(define bytevector->c-bytevector
(lambda (bytes)
(letrec* ((bytes-length (bytevector-length bytes))
(pointer (make-c-bytevector bytes-length))
(looper (lambda (index)
(when (< index bytes-length)
(pffi-pointer-set! pointer
'uint8
index
(bytevector-u8-ref bytes index))
(looper (+ index 1))))))
(looper 0)
pointer)))
#;(define pffi-pointer-null?
(lambda (pointer)
(let ((address
(let ((str (pffi-pointer-allocate 512)))
(c-snprintf str 512 (pffi-string->pointer "%p") pointer)
(display "Scheme: p1 address: ")
(write (pffi-pointer->string str))
(newline)
(display "Scheme: p1 address int: ")
(write (c-strtol str (pffi-pointer-null) 16))
(newline)
(c-strtol str (pffi-pointer-null) 16))))
(= address 0))))
(define c-bytevector->bytevector
(lambda (pointer size)
(letrec* ((bytes (make-bytevector size))
(looper (lambda (index)
(let ((byte (pffi-pointer-get pointer 'uint8 index)))
(if (= index size)
bytes
(begin
(bytevector-u8-set! bytes index byte)
(looper (+ index 1))))))))
(looper 0))))
#;(define pffi-pointer-address
(define c-bytevector-string-length
(lambda (bytevector)
(c-strlen bytevector)))
(define c-bytevector->string
(lambda (pointer)
(let* ((address-number
(let ((str (pffi-pointer-allocate 512)))
(c-snprintf str 512 (pffi-string->pointer "%p") pointer)
(display "Scheme: p1 address: ")
(write (pffi-pointer->string str))
(newline)
(display "Scheme: p1 address int: ")
(write (c-strtol str (pffi-pointer-null) 16))
(newline)
(c-strtol str (pffi-pointer-null) 16)))
(address (pffi-pointer-allocate (pffi-size-of 'uint64))))
(display "Scheme: p2 address: ")
(write address)
(newline)
;address-number
(pffi-pointer-set! address 'uint64 0 address-number)
;address-number
;(pffi-pointer-get address 'pointer 0)
address
)
))
(when (not (c-bytevector? pointer))
(error "c-bytevector->string argument not c-bytevector" pointer))
(let ((size (c-strlen pointer)))
(utf8->string (c-bytevector->bytevector pointer size)))))
(define string->c-bytevector
(lambda (text)
(when (not (string? text))
(error "string->bytevector argument not string" text))
(bytevector->c-bytevector (string->utf8 (string-append text (string #\null))))))
(cond-expand
(kawa #t) ; FIXME
(chicken #t) ; FIXME
(else (define make-c-null
(lambda ()
(cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
(free-bytes pointer)
pointer))
(else (c-memset-address->pointer 0 0 0)))))))
(cond-expand
(kawa #t) ; FIXME
(chicken #t) ; FIXME
(else (define c-null?
(lambda (pointer)
(if (c-bytevector? pointer)
(= (c-memset-pointer->address pointer 0 0) 0)
#f)))))
(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
(apply thunk (list address-pointer))
(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
(c-free address-pointer)))))

30
retropikzel/pffi/shared/struct.scm
View File

@ -15,33 +15,13 @@
(size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (if (and (not (null? arguments))
(pffi-pointer? (car arguments)))
(c-bytevector? (car arguments)))
(car arguments)
(pffi-pointer-allocate size)))
(make-c-bytevector size)))
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type-string size pointer offsets)))))))
#;(define pffi-struct-dereference
(lambda (struct)
(let ((pointer (pffi-pointer-allocate (pffi-struct-size struct)))
(offset 0))
(for-each
(lambda (struct-member)
(let* ((member-type (cadr struct-member))
(member-name (car struct-member))
(member-size (pffi-size-of member-type)))
(pffi-pointer-set! pointer
member-type
offset
(pffi-struct-get struct member-name))
(set! offset (+ offset member-size))))
(pffi-struct-members struct))
;(pffi-pointer-get (pffi-struct-pointer struct) 'pointer 0)
;(pffi-pointer-get pointer 'pointer 0)
pointer
)))
(define pffi-align-of
(define c-align-of
(lambda (type)
(cond-expand
;(guile (alignof (pffi-type->native-type type)))
@ -60,7 +40,7 @@
(offsets (map (lambda (member)
(let* ((name (cdr member))
(type (car member))
(type-alignment (pffi-align-of type)))
(type-alignment (c-align-of type)))
(when (> (size-of-type type) largest-member-size)
(set! largest-member-size (size-of-type type)))
(if (or (= size 0)
@ -97,7 +77,7 @@
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
(size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer)))
(pointer (if (null? pointer) (make-c-bytevector size) (car pointer)))
(c-type (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type size pointer offsets))))

8
retropikzel/pffi/shared/union.scm
View File

@ -1,8 +0,0 @@
(define-record-type <pffi-union>
(union-make c-type size pointer members)
pffi-union?
(c-type pffi-union-c-type)
(size pffi-union-size)
(pointer pffi-union-pointer)
(members pffi-union-members))

88
retropikzel/pffi/stklos.scm
View File

@ -1,13 +1,13 @@
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) :int)
((equal? type 'uint8) :uint)
((equal? type 'int16) :int)
((equal? type 'uint16) :uint)
(cond ((equal? type 'int8) :char)
((equal? type 'uint8) :char)
((equal? type 'int16) :short)
((equal? type 'uint16) :ushort)
((equal? type 'int32) :int)
((equal? type 'uint32) :uint)
((equal? type 'int64) :int)
((equal? type 'uint64) :uint)
((equal? type 'int64) :long)
((equal? type 'uint64) :ulong)
((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar)
((equal? type 'short) :short)
@ -19,21 +19,15 @@
((equal? type 'float) :float)
((equal? type 'double) :double)
((equal? type 'pointer) :pointer)
((equal? type 'string) :string)
((equal? type 'void) :void)
((equal? type 'struct) :void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(display "HERE: ")
(write object)
(newline)
(write (cpointer? object))
(newline)
(cpointer? object)))
(define-syntax pffi-define-function
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(begin
@ -76,53 +70,25 @@
; FIXME
(define size-of-type
(lambda (type)
(cond
((equal? type 'int8) 1)
((equal? type 'uint8) 1)
((equal? type 'int16) 2)
((equal? type 'uint16) 2)
((equal? type 'int32) 4)
((equal? type 'uint32) 4)
((equal? type 'int64) 8)
((equal? type 'uint64) 8)
((equal? type 'char) 1)
((equal? type 'unsigned-char) 1)
((equal? type 'short) 2)
((equal? type 'unsigned-short) 2)
((equal? type 'int) 4)
((equal? type 'unsigned-int) 4)
((equal? type 'long) 8)
((equal? type 'unsigned-long) 8)
((equal? type 'float) 4)
((equal? type 'double) 8)
((equal? type 'pointer) 8)
)))
#;(define pffi-pointer-allocate
(lambda (size)
(allocate-bytes size)))
;; FIXME
(define pffi-pointer-address
(lambda (pointer)
0))
;; FIXME
(define pffi-pointer-null
(lambda ()
(let ((p (allocate-bytes 0)))
(free-bytes p)
p)))
#;(define pffi-pointer-free
(lambda (pointer)
(free-bytes pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(and (cpointer? pointer)
(cpointer-null? pointer))))
(cond ((equal? type 'int8) 1)
((equal? type 'uint8) 1)
((equal? type 'int16) 2)
((equal? type 'uint16) 2)
((equal? type 'int32) 4)
((equal? type 'uint32) 4)
((equal? type 'int64) 8)
((equal? type 'uint64) 8)
((equal? type 'char) 1)
((equal? type 'unsigned-char) 1)
((equal? type 'short) 2)
((equal? type 'unsigned-short) 2)
((equal? type 'int) 4)
((equal? type 'unsigned-int) 4)
((equal? type 'long) 8)
((equal? type 'unsigned-long) 8)
((equal? type 'float) 4)
((equal? type 'double) 8)
((equal? type 'pointer) 8))))
(define pffi-pointer-set!
(lambda (pointer type offset value)

159
retropikzel/pffi/ypsilon.scm
View File

@ -25,52 +25,13 @@
((eq? type 'void) 0)
(else #f))))
;(define c-malloc (c-function void* malloc (size_t)))
;(define c-free (c-function int free (void*)))
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
(define pffi-pointer-address
(lambda (pointer)
pointer))
(define pffi-pointer?
(define c-bytevector?
(lambda (object)
(number? object)))
#;(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
(define pffi-pointer-null
(lambda ()
0))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(= (pffi-pointer-address pointer) 0))))
#;(define pffi-pointer->string
(lambda (pointer)
(c-string-ref pointer)))
;(define c-memset(c-function int memset (void* int int)))
;(define c-snprintf (c-function int snprintf (void* size_t void*) (long double)))
#;(define pffi-string->pointer
(lambda (string-content)
(let* ((c-string (make-c-string string-content))
(c-string-length (bytevector-length c-string))
(pointer (c-malloc c-string-length)))
(c-memset pointer 0 c-string-length)
(c-snprintf pointer c-string-length (make-c-string "%s") c-string)
pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
@ -93,7 +54,7 @@
(define pffi-pointer-get
(lambda (pointer type offset)
(let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
((equal? type 'int16) (bytevector-c-int16-ref bv 0))
@ -115,44 +76,96 @@
((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
(define pffi-shared-object-load
(lambda (headers path options)
(lambda (path options)
(load-shared-object path)))
(define-macro (pffi-type->native-type type)
`(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 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 string) void*)
((equal? ,type void) void)
((equal? ,type callback) void*)
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
#;(define-macro
(pffi-type->native-type type)
`(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 '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 'string) 'void*)
((equal? ,type 'void) 'void)
;((equal? ,type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
(define-macro
(pffi-define-function scheme-name shared-object c-name return-type argument-types)
`(define ,scheme-name
(c-function ,(pffi-type->native-type return-type)
,(cadr c-name)
,(map pffi-type->native-type (cdr argument-types)))))
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
(begin
(let ((pffi-type->native-type
(lambda (type)
(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 '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 'string) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))))
`(define ,scheme-name
(c-function ,(pffi-type->native-type (cadr return-type))
,(cadr c-name)
,(map pffi-type->native-type (cadr argument-types)))))))
(define-macro
(pffi-define-callback scheme-name return-type argument-types procedure)
(let ((pffi-type->native-type
(lambda (type)
(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 '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 'string) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))))
`(define ,scheme-name
(c-callback ,(pffi-type->native-type return-type)
,(map pffi-type->native-type (cdr argument-types))
,procedure)))
,procedure))))

814
tests/compliance.scm
View File

File diff suppressed because it is too large Load Diff