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 *.rkt
testfile.test testfile.test
tests/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 && DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') 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 # apt-get install pandoc weasyprint
docs: docs:
mkdir -p documentation mkdir -p documentation
@ -64,13 +67,19 @@ tr7:
ypsilon: ypsilon:
make -C retropikzel/pffi tr7 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} make ${COMPILE_R7RS}
cp -r retropikzel tmp/test/ cp -r retropikzel tmp/test/
cp tests/compliance.scm tmp/test/ cp tests/compliance.scm tmp/test/
cp tests/c-include/libtest.h 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 cp -r snow/* tmp/test/
cd tmp/test && LD_LIBRARY_PATH=. ./compliance 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: test-compile-r7rs-docker:
docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} -f dockerfiles/test . 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 mkdir -p tmp/test
${CC} -o tmp/test/libtest.so -shared -fPIC tests/c-src/libtest.c -I./include ${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 ar rcs tmp/test/libtest.a tmp/test/libtest.o
clean: clean:
@rm -rf retropikzel/pffi/pffi.c
@rm -rf retropikzel/pffi/*.o* @rm -rf retropikzel/pffi/*.o*
@rm -rf retropikzel/pffi/*.so @rm -rf retropikzel/pffi/*.so
@rm -rf retropikzel/pffi/*.meta @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) - [PFFI\_LOAD\_PATH](#environment-variables-pffi-load-path)
- [Procedures and macros](#procedures-and-macros) - [Procedures and macros](#procedures-and-macros)
- [pffi-init](#pffi-init) - [pffi-init](#pffi-init)
- [pffi-size-of](#pffi-size-of) - [c-size-of](#c-size-of)
- [pffi-align-of](#pffi-align-of) - [pffi-align-of](#pffi-align-of)
- [pffi-define-library](#pffi-define-library) - [define-c-library](#define-c-library)
- [pffi-pointer-null](#pffi-pointer-null) - [make-c-null](#make-c-null)
- [pffi-pointer-null?](#pffi-pointer-null) - [c-null?](#is-c-null)
- [pffi-pointer-allocate](#pffi-pointer-allocate) - [make-c-bytevector ](#make-c-bytevector )
- [pffi-pointer-address](#pffi-pointer-address) - [pffi-pointer-address](#pffi-pointer-address)
- [pffi-pointer?](#pffi-pointer) - [c-bytevector?](#is-c-bytevector)
- [pffi-pointer-free](#pffi-pointer-free) - [c-free](#c-free)
- [pffi-pointer-set!](#pffi-pointer-set!) - [pffi-pointer-set!](#pffi-pointer-set!)
- [pffi-pointer-get](#pffi-pointer-get) - [pffi-pointer-get](#pffi-pointer-get)
- [pffi-string->pointer](#pffi-string->pointer) - [string->c-bytevector](#string-into-c-bytevector)
- [pffi-pointer->string](#pffi-pointer->string) - [c-bytevector->sring](#c-bytevector-into-string)
- [pffi-struct-make](#pffi-struct-make) - [pffi-struct-make](#pffi-struct-make)
- [pffi-struct-pointer](#pffi-struct-pointer) - [pffi-struct-pointer](#pffi-struct-pointer)
- [pffi-struct-offset-get](#pffi-struct-offset-get) - [pffi-struct-offset-get](#pffi-struct-offset-get)
@ -73,7 +73,7 @@ conforming to some specification.
- [pffi-array-set!](#pffi-array-set!) - [pffi-array-set!](#pffi-array-set!)
- [pffi-list->array](#pffi-list->array) - [pffi-list->array](#pffi-list->array)
- [pffi-array->list](#pffi-array->list) - [pffi-array->list](#pffi-array->list)
- [pffi-define-function](#pffi-define-function) - [define-c-procedure](#define-c-procedure)
- [pffi-define-callback](#pffi-define-callback) - [pffi-define-callback](#pffi-define-callback)
</nav> </nav>
@ -99,8 +99,7 @@ conforming to some specification.
## Status ## Status
<a name="status"></a> <a name="status"></a>
Currently the interface of the library is in okay shape. It propably will not change much but no In alpha.
guarantees are being made just yet.
### Current caveats ### Current caveats
<a name="current-caveats"></a> <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 - Always pass pffi-define-callback procedure as lambda in place
- No support for variadic function arguments - No support for variadic function arguments
- Can be partially worked around by defining multiple versions of same - Can be partially worked around by defining multiple versions of same
function with different amount of arguments function with different number of arguments
## Roadmap ## Roadmap
@ -123,24 +122,24 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear
## Primitives ## Primitives
<a name="feature-implementation-table-primitives"></a> <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 | | | 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 | X | X | X | X | | | Chibi | X | X | X | X | X | X | |
| Chicken | X | X | X | X | X | X | X | X | X | X | X | | Chicken | X | X | X | X | X | X | X |
| Cyclone | X | X | X | X | X | | X | X | X | X | | | Cyclone | X | X | X | X | X | X | |
| Gambit | X | X | | | | X | | | | | | | Gambit | X | | | | | | |
| Gauche | X | X | X | X | X | X | X | X | X | X | | | Gauche | X | X | X | X | X | X | |
| Gerbil | X | | | | | | | | | | | | Gerbil | | | | | | | |
| Guile | X | X | X | X | X | X | X | X | X | X | X | | Guile | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X | X | X | X | X | | Kawa | X | X | X | X | X | X | X |
| Larceny | X | | | | | | | | | | | | Larceny | | | | | | | |
| Mosh | X | X | X | X | X | | X | X | X | X | X | | Mosh | X | X | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | X | X | X | X | | Racket | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | | Saggittarius | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | | | Skint | | | | | | | |
| Stklos | X | X | X | X | X | | X | | | | | | Stklos | X | X | X | | | | |
| tr7 | | | | | | | | | | | | | tr7 | | | | | | | |
| Ypsilon | X | X | X | X | X | X | X | X | X | X | X | | Ypsilon | X | X | X | X | X | X | X |
## Built upon ## Built upon
<a name="feature-implementation-table-built-upon"></a> <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 These features are built upon the primitives and if primitives are implemented
and work, they should work too. and work, they should work too.
- pffi-pointer-allocate - make-c-bytevector
- pffi-pointer-free - make-c-null
- c-null?
- pffi-pointer-address
- c-free
- pffi-pointer-\>string - pffi-pointer-\>string
- pffi-string-\>pointer - pffi-string-\>pointer
- pffi-struct-make - 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 Always call this first, on most implementation it does nothing but some implementations might need
initialisation run. initialisation run.
#### pffi-size-of #### c-size-of
<a name="pffi-size-of"></a> <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. 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. Returns the align of the type.
#### pffi-define-library #### define-c-library
<a name="pffi-define-library"></a> <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. Load given shared object automatically searching many predefined paths.
@ -377,12 +379,12 @@ keyword. The options are:
Example: Example:
(cond-expand (cond-expand
(windows (pffi-define-library libc-stdlib (windows (define-c-library libc-stdlib
'("stdlib.h") '("stdlib.h")
"ucrtbase" "ucrtbase"
'((additional-versions ("0" "6")) '((additional-versions ("0" "6"))
(additiona-paths ("."))))) (additiona-paths (".")))))
(else (pffi-define-library libc-stdlib (else (define-c-library libc-stdlib
(list "stdlib.h") (list "stdlib.h")
"c" "c"
'((additional-versions ("0" "6")) '((additional-versions ("0" "6"))
@ -399,45 +401,57 @@ implementations.
- Do pass the options using quote - Do pass the options using quote
- As '(... and not (list... - As '(... and not (list...
#### pffi-pointer-null #### make-c-null
<a name="pffi-pointer-null"></a> <a name="make-c-null"></a>
**pffi-pointer-null** -> pointer **make-c-null** -> pointer
Returns a new NULL pointer. Returns a new NULL pointer.
#### pffi-pointer-null? #### c-null?
<a name="pffi-pointer-null"></a> <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. Returns #t if given pointer is null pointer, #f otherwise.
#### pffi-pointer-allocate #### make-c-bytevector
<a name="pffi-pointer-allocate"></a> <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 #### pffi-pointer-address
<a name="pffi-pointer-address"></a> <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> <a name="pffi-pointer"></a>
**pffi-pointer?** object -> boolean **c-bytevector?** object -> boolean
Returns #t if given object is pointer, #f otherwise. Returns #t if given object is pointer, #f otherwise.
#### pffi-pointer-free #### c-free
<a name="pffi-pointer-free"></a> <a name="c-free"></a>
**pffi-pointer-free** pointer **c-free** pointer
Frees given pointer. Frees given pointer.
@ -448,7 +462,7 @@ Frees given pointer.
Sets the value on a pointer on given offset. For example: 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) (pffi-pointer-set! p 'int 64 100)
Would set the offset of 64, on pointer p to value 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: 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-set! p 'int 64 100)
(pffi-pointer-get p 'int 64) (pffi-pointer-get p 'int 64)
> 100 > 100
#### pffi-string->pointer #### string->c-bytevector
<a name="pffi-string->pointer"></a> <a name="string-into-c-bytevector"></a>
**pffi-string->pointer** string -> pointer **string->c-bytevector** string -> pointer
Makes pointer out of a given string. Makes pointer out of a given string.
#### pffi-pointer->string #### c-bytevector->string
<a name="pffi-pointer->string"></a> <a name="c-bytevector-into-string"></a>
**pffi-pointer->string** pointer -> string **c-bytevector->sring** pointer -> string
Makes string out of a given pointer. 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. Converts given C array into list of given type and length.
#### pffi-define-function #### define-c-procedure
<a name="pffi-define-function"></a> <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: Defines a new foreign function to be used from Scheme code. For example:
(cond-expand (cond-expand
(windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '(""))) (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
(else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6")))) (else (define-c-library libc-stdlib '("stdlib.h") "c" '("" "6"))))
(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer)) (define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
(c-puts "Message brought to you by FFI!") (c-puts "Message brought to you by FFI!")
#### pffi-define-callback #### 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 ; Load the shared library
(cond-expand (cond-expand
(windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '())) (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
(else (pffi-define-library '("stdlib.h") "c" '("" "6")))) (else (define-c-library '("stdlib.h") "c" '("" "6"))))
; Define C function that takes a callback ; 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 ; Define our callback
(pffi-define-callback compare (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))))) ((< a b) -1)))))
; Create new array of ints to be sorted ; Create new array of ints to be sorted
(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) (define array (make-c-bytevector (* (c-size-of 'int) 3)))
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) (pffi-pointer-set! array 'int (* (c-size-of 'int) 0) 3)
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) (pffi-pointer-set! array 'int (* (c-size-of 'int) 1) 2)
(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) (pffi-pointer-set! array 'int (* (c-size-of 'int) 2) 1)
(display array) (display array)
(newline) (newline)
;> (3 2 1) ;> (3 2 1)
; Sort the array ; Sort the array
(qsort array 3 (pffi-size-of 'int) compare) (qsort array 3 (c-size-of 'int) compare)
(display array) (display array)
(newline) (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> <li><a href="#procedures-and-macros">Procedures and macros</a>
<ul> <ul>
<li><a href="#pffi-init">pffi-init</a></li> <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-align-of">pffi-align-of</a></li>
<li><a href="#pffi-define-library">pffi-define-library</a></li> <li><a href="#define-c-library">define-c-library</a></li>
<li><a href="#pffi-pointer-null">pffi-pointer-null</a></li> <li><a href="#make-c-null">make-c-null</a></li>
<li><a href="#pffi-pointer-null">pffi-pointer-null?</a></li> <li><a href="#is-c-null">c-null?</a></li>
<li><a <li><a href="#make-c-bytevector">make-c-bytevector</a></li>
href="#pffi-pointer-allocate">pffi-pointer-allocate</a></li>
<li><a <li><a
href="#pffi-pointer-address">pffi-pointer-address</a></li> href="#pffi-pointer-address">pffi-pointer-address</a></li>
<li><a href="#pffi-pointer">pffi-pointer?</a></li> <li><a href="#is-c-bytevector">c-bytevector?</a></li>
<li><a href="#pffi-pointer-free">pffi-pointer-free</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-set!">pffi-pointer-set!</a></li>
<li><a href="#pffi-pointer-get">pffi-pointer-get</a></li> <li><a href="#pffi-pointer-get">pffi-pointer-get</a></li>
<li><a <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 <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-make">pffi-struct-make</a></li>
<li><a href="#pffi-struct-pointer">pffi-struct-pointer</a></li> <li><a href="#pffi-struct-pointer">pffi-struct-pointer</a></li>
<li><a <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-array-set!">pffi-array-set!</a></li>
<li><a href="#pffi-list-%3Earray">pffi-list-&gt;array</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-array-%3Elist">pffi-array-&gt;list</a></li>
<li><a <li><a href="#define-c-procedure">define-c-procedure</a></li>
href="#pffi-define-function">pffi-define-function</a></li>
<li><a <li><a
href="#pffi-define-callback">pffi-define-callback</a></li> href="#pffi-define-callback">pffi-define-callback</a></li>
</ul></li> </ul></li>
@ -141,9 +139,7 @@ Documentation - 0.6.0</title>
</ul> </ul>
<h2 id="status">Status</h2> <h2 id="status">Status</h2>
<p><a name="status"></a></p> <p><a name="status"></a></p>
<p>Currently the interface of the library is in okay shape. It <p>In alpha.</p>
propably will not change much but no guarantees are being made
just yet.</p>
<h3 id="current-caveats">Current caveats</h3> <h3 id="current-caveats">Current caveats</h3>
<p><a name="current-caveats"></a></p> <p><a name="current-caveats"></a></p>
<ul> <ul>
@ -156,7 +152,7 @@ Documentation - 0.6.0</title>
<li>No support for variadic function arguments <li>No support for variadic function arguments
<ul> <ul>
<li>Can be partially worked around by defining multiple versions <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></li>
</ul> </ul>
<h2 id="roadmap">Roadmap</h2> <h2 id="roadmap">Roadmap</h2>
@ -167,34 +163,26 @@ Documentation - 0.6.0</title>
<p><a name="feature-implementation-table"></a></p> <p><a name="feature-implementation-table"></a></p>
<h2 id="primitives">Primitives</h2> <h2 id="primitives">Primitives</h2>
<p><a name="feature-implementation-table-primitives"></a></p> <p><a name="feature-implementation-table-primitives"></a></p>
<table style="width:100%;"> <table>
<colgroup> <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: 9%" /> <col style="width: 9%" />
<col style="width: 14%" />
<col style="width: 10%" /> <col style="width: 10%" />
<col style="width: 7%" /> <col style="width: 13%" />
<col style="width: 9%" /> <col style="width: 12%" />
<col style="width: 8%" /> <col style="width: 14%" />
<col style="width: 6%" /> <col style="width: 15%" />
<col style="width: 10%" />
</colgroup> </colgroup>
<thead> <thead>
<tr class="header"> <tr class="header">
<th></th> <th></th>
<th style="text-align: center;">pffi-init</th> <th style="text-align: center;">c-size-of</th>
<th style="text-align: center;">pffi-size-of</th> <th style="text-align: center;">define-c-library</th>
<th style="text-align: center;">pffi-define-library</th> <th style="text-align: center;">c-bytevector?</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;">pffi-pointer-set!</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-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> <th style="text-align: center;">pffi-define-callback</th>
</tr> </tr>
</thead> </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;">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;"></td>
</tr> </tr>
<tr class="even"> <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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
<tr class="odd"> <tr class="odd">
<td>Cyclone</td> <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;">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>
<td style="text-align: center;"></td> <td style="text-align: center;"></td>
</tr> </tr>
<tr class="even"> <tr class="even">
<td>Gambit</td> <td>Gambit</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;"></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;">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>
<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;">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;"></td>
</tr> </tr>
<tr class="even"> <tr class="even">
<td>Gerbil</td> <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> <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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
<tr class="even"> <tr class="even">
<td>Kawa</td> <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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
<tr class="odd"> <tr class="odd">
<td>Larceny</td> <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> <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;">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>
<td style="text-align: center;">X</td> <td style="text-align: center;">X</td>
</tr> </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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
<tr class="even"> <tr class="even">
<td>Saggittarius</td> <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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
<tr class="odd"> <tr class="odd">
<td>Skint</td> <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> <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;">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> <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>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
<td style="text-align: center;"></td>
</tr> </tr>
<tr class="even"> <tr class="even">
<td>Ypsilon</td> <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>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
<td style="text-align: center;">X</td>
</tr> </tr>
</tbody> </tbody>
</table> </table>
@ -430,8 +354,11 @@ Documentation - 0.6.0</title>
<p>These features are built upon the primitives and if <p>These features are built upon the primitives and if
primitives are implemented and work, they should work too.</p> primitives are implemented and work, they should work too.</p>
<ul> <ul>
<li>pffi-pointer-allocate</li> <li>make-c-bytevector</li>
<li>pffi-pointer-free</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-pointer-&gt;string</li>
<li>pffi-string-&gt;pointer</li> <li>pffi-string-&gt;pointer</li>
<li>pffi-struct-make</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 <p>Always call this first, on most implementation it does
nothing but some implementations might need initialisation nothing but some implementations might need initialisation
run.</p> run.</p>
<h4 id="pffi-size-of">pffi-size-of</h4> <h4 id="c-size-of">c-size-of</h4>
<p><a name="pffi-size-of"></a></p> <p><a name="c-size-of"></a></p>
<p><strong>pffi-size-of</strong> object -&gt; number</p> <p><strong>c-size-of</strong> object -&gt; number</p>
<p>Returns the size of the pffi-struct, pffi-enum or <p>Returns the size of the pffi-struct, pffi-enum or
pffi-type.</p> pffi-type.</p>
<h4 id="pffi-align-of">pffi-align-of</h4> <h4 id="pffi-align-of">pffi-align-of</h4>
<p><a name="pffi-align-of"></a></p> <p><a name="pffi-align-of"></a></p>
<p><strong>pffi-align-of</strong> type -&gt; number</p> <p><strong>pffi-align-of</strong> type -&gt; number</p>
<p>Returns the align of the type.</p> <p>Returns the align of the type.</p>
<h4 id="pffi-define-library">pffi-define-library</h4> <h4 id="define-c-library">define-c-library</h4>
<p><a name="pffi-define-library"></a></p> <p><a name="define-c-library"></a></p>
<p><strong>pffi-define-library</strong> headers <p><strong>define-c-library</strong> headers shared-object-name
shared-object-name [options] -&gt; object</p> [options] -&gt; object</p>
<p>Load given shared object automatically searching many <p>Load given shared object automatically searching many
predefined paths.</p> predefined paths.</p>
<p>Takes as argument a list of C headers, these are for the <p>Takes as argument a list of C headers, these are for the
@ -656,12 +583,12 @@ make &lt;SCHEME&gt;</code></pre>
</ul> </ul>
<p>Example:</p> <p>Example:</p>
<pre><code>(cond-expand <pre><code>(cond-expand
(windows (pffi-define-library libc-stdlib (windows (define-c-library libc-stdlib
&#39;(&quot;stdlib.h&quot;) &#39;(&quot;stdlib.h&quot;)
&quot;ucrtbase&quot; &quot;ucrtbase&quot;
&#39;((additional-versions (&quot;0&quot; &quot;6&quot;)) &#39;((additional-versions (&quot;0&quot; &quot;6&quot;))
(additiona-paths (&quot;.&quot;))))) (additiona-paths (&quot;.&quot;)))))
(else (pffi-define-library libc-stdlib (else (define-c-library libc-stdlib
(list &quot;stdlib.h&quot;) (list &quot;stdlib.h&quot;)
&quot;c&quot; &quot;c&quot;
&#39;((additional-versions (&quot;0&quot; &quot;6&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> <li>As ’(… and not (list…</li>
</ul></li> </ul></li>
</ul> </ul>
<h4 id="pffi-pointer-null">pffi-pointer-null</h4> <h4 id="make-c-null">make-c-null</h4>
<p><a name="pffi-pointer-null"></a></p> <p><a name="make-c-null"></a></p>
<p><strong>pffi-pointer-null</strong> -&gt; pointer</p> <p><strong>make-c-null</strong> -&gt; pointer</p>
<p>Returns a new NULL pointer.</p> <p>Returns a new NULL pointer.</p>
<h4 id="pffi-pointer-null-1">pffi-pointer-null?</h4> <h4 id="c-null">c-null?</h4>
<p><a name="pffi-pointer-null"></a></p> <p><a name="is-c-null"></a></p>
<p><strong>pffi-pointer-null?</strong> pointer -&gt; boolean</p> <p><strong>c-null?</strong> pointer -&gt; boolean</p>
<p>Returns #t if given pointer is null pointer, #f <p>Returns #t if given pointer is null pointer, #f
otherwise.</p> otherwise.</p>
<h4 id="pffi-pointer-allocate">pffi-pointer-allocate</h4> <h4 id="make-c-bytevector">make-c-bytevector</h4>
<p><a name="pffi-pointer-allocate"></a></p> <p><a name="make-c-bytevector "></a></p>
<p><strong>pffi-pointer-allocate</strong> size -&gt; pointer</p> <p><strong>make-c-bytevector</strong> size -&gt; pointer</p>
<p>Returns newly allocated pointer of given size.</p> <p>Returns newly allocated pointer of given size.</p>
<h4 id="pffi-pointer-address">pffi-pointer-address</h4> <h4 id="pffi-pointer-address">pffi-pointer-address</h4>
<p><a name="pffi-pointer-address"></a></p> <p><a name="pffi-pointer-address"></a></p>
<p><strong>pffi-pointer-address</strong> pointer -&gt; <p><strong>pffi-pointer-address</strong> pointer -&gt;
number</p> pointer</p>
<p>Returns the address of given pointer as number.</p> <p>Returns the address of given pointer inside a pointer. This
<h4 id="pffi-pointer">pffi-pointer?</h4> 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><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> <p>Returns #t if given object is pointer, #f otherwise.</p>
<h4 id="pffi-pointer-free">pffi-pointer-free</h4> <h4 id="c-free">c-free</h4>
<p><a name="pffi-pointer-free"></a></p> <p><a name="c-free"></a></p>
<p><strong>pffi-pointer-free</strong> pointer</p> <p><strong>c-free</strong> pointer</p>
<p>Frees given pointer.</p> <p>Frees given pointer.</p>
<h4 id="pffi-pointer-set">pffi-pointer-set!</h4> <h4 id="pffi-pointer-set">pffi-pointer-set!</h4>
<p><a name="pffi-pointer-set!"></a></p> <p><a name="pffi-pointer-set!"></a></p>
<p><strong>pffi-pointer-set!</strong> pointer type offset <p><strong>pffi-pointer-set!</strong> pointer type offset
value</p> value</p>
<p>Sets the value on a pointer on given offset. For example:</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> (pffi-pointer-set! p &#39;int 64 100)</code></pre>
<p>Would set the offset of 64, on pointer p to value 100.</p> <p>Would set the offset of 64, on pointer p to value 100.</p>
<h4 id="pffi-pointer-get">pffi-pointer-get</h4> <h4 id="pffi-pointer-get">pffi-pointer-get</h4>
@ -721,18 +657,18 @@ make &lt;SCHEME&gt;</code></pre>
object</p> object</p>
<p>Gets the value from a pointer on given offset. For <p>Gets the value from a pointer on given offset. For
example:</p> 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-set! p &#39;int 64 100)
(pffi-pointer-get p &#39;int 64) (pffi-pointer-get p &#39;int 64)
&gt; 100</code></pre> &gt; 100</code></pre>
<h4 id="pffi-string-pointer">pffi-string-&gt;pointer</h4> <h4 id="string-c-bytevector">string-&gt;c-bytevector</h4>
<p><a name="pffi-string->pointer"></a></p> <p><a name="string-into-c-bytevector"></a></p>
<p><strong>pffi-string-&gt;pointer</strong> string -&gt; <p><strong>string-&gt;c-bytevector</strong> string -&gt;
pointer</p> pointer</p>
<p>Makes pointer out of a given string.</p> <p>Makes pointer out of a given string.</p>
<h4 id="pffi-pointer-string">pffi-pointer-&gt;string</h4> <h4 id="c-bytevector-string">c-bytevector-&gt;string</h4>
<p><a name="pffi-pointer->string"></a></p> <p><a name="c-bytevector-into-string"></a></p>
<p><strong>pffi-pointer-&gt;string</strong> pointer -&gt; <p><strong>c-bytevector-&gt;sring</strong> pointer -&gt;
string</p> string</p>
<p>Makes string out of a given pointer.</p> <p>Makes string out of a given pointer.</p>
<h4 id="pffi-struct-make">pffi-struct-make</h4> <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><strong>pffi-array-&gt;list</strong> type list length</p>
<p>Converts given C array into list of given type and <p>Converts given C array into list of given type and
length.</p> length.</p>
<h4 id="pffi-define-function">pffi-define-function</h4> <h4 id="define-c-procedure">define-c-procedure</h4>
<p><a name="pffi-define-function"></a></p> <p><a name="define-c-procedure"></a></p>
<p><strong>pffi-define-function</strong> scheme-name <p><strong>define-c-procedure</strong> scheme-name shared-object
shared-object c-name return-type argument-types</p> c-name return-type argument-types</p>
<p>Defines a new foreign function to be used from Scheme code. <p>Defines a new foreign function to be used from Scheme code.
For example:</p> For example:</p>
<pre><code>(cond-expand <pre><code>(cond-expand
(windows (pffi-define-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;(&quot;&quot;))) (windows (define-c-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;)))) (else (define-c-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)) (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> (c-puts &quot;Message brought to you by FFI!&quot;)</code></pre>
<h4 id="pffi-define-callback">pffi-define-callback</h4> <h4 id="pffi-define-callback">pffi-define-callback</h4>
<p><a name="pffi-define-callback"></a></p> <p><a name="pffi-define-callback"></a></p>
@ -823,11 +759,11 @@ make &lt;SCHEME&gt;</code></pre>
code. For example:</p> code. For example:</p>
<pre><code>; Load the shared library <pre><code>; Load the shared library
(cond-expand (cond-expand
(windows (pffi-define-library libc-stdlib &#39;(&quot;stdlib.h&quot;) &quot;ucrtbase&quot; &#39;())) (windows (define-c-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;)))) (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 ; 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 ; Define our callback
(pffi-define-callback compare (pffi-define-callback compare
@ -841,17 +777,17 @@ make &lt;SCHEME&gt;</code></pre>
((&lt; a b) -1))))) ((&lt; a b) -1)))))
; Create new array of ints to be sorted ; Create new array of ints to be sorted
(define array (pffi-pointer-allocate (* (pffi-size-of &#39;int) 3))) (define array (make-c-bytevector (* (c-size-of &#39;int) 3)))
(pffi-pointer-set! array &#39;int (* (pffi-size-of &#39;int) 0) 3) (pffi-pointer-set! array &#39;int (* (c-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 (* (c-size-of &#39;int) 1) 2)
(pffi-pointer-set! array &#39;int (* (pffi-size-of &#39;int) 2) 1) (pffi-pointer-set! array &#39;int (* (c-size-of &#39;int) 2) 1)
(display array) (display array)
(newline) (newline)
;&gt; (3 2 1) ;&gt; (3 2 1)
; Sort the array ; Sort the array
(qsort array 3 (pffi-size-of &#39;int) compare) (qsort array 3 (c-size-of &#39;int) compare)
(display array) (display array)
(newline) (newline)

BIN
documentation/R7RS-PFFI.pdf
View File

Binary file not shown.

208
retropikzel/pffi.sld
View File

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

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

@ -4,7 +4,7 @@
(c-system-include "dlfcn.h") (c-system-include "dlfcn.h")
(c-system-include "ffi.h") (c-system-include "ffi.h")
;; pffi-size-of ;; c-size-of
(c-declare " (c-declare "
int size_of_int8_t() { return sizeof(int8_t); } int size_of_int8_t() { return sizeof(int8_t); }
int size_of_uint8_t() { return sizeof(uint8_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-double size_of_double) ())
(define-c int (size-of-pointer size_of_pointer) ()) (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-const int (RTLD-NOW "RTLD_NOW"))
(define-c (maybe-null pointer void*) dlopen (string int)) (define-c (maybe-null pointer void*) dlopen (string int))
(define-c (maybe-null pointer void*) dlerror ()) (define-c (maybe-null pointer void*) dlerror ())
@ -70,10 +70,10 @@
}") }")
(define-c sexp (pointer? is_pointer) (sexp)) (define-c sexp (pointer? is_pointer) (sexp))
(c-declare "intptr_t pointer_address(struct sexp_struct* pointer) { (c-declare "void* pointer_address(struct sexp_struct* pointer) {
return (intptr_t)&sexp_cpointer_value(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); }") (c-declare "void pointer_free(void* pointer) { free(pointer); }")
(define-c void (pointer-free pointer_free) ((maybe-null pointer void*))) (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; }") (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)) (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; }") (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 char)) (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; }") (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)) (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); }") (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)) (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); }") (c-declare "int8_t 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)) (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); }") (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)) (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; }") (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)) (define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
;; pffi-string->pointer ;; define-c-procedure
;(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
(c-declare "ffi_cif cif;") (c-declare "ffi_cif cif;")
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) (define-c (pointer void*) dlsym ((maybe-null pointer void*) string))

52
retropikzel/pffi/chibi.scm
View File

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

34
retropikzel/pffi/chicken.scm
View File

@ -25,11 +25,11 @@
((equal? type 'struct) 'c-pointer) ((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))) ) (else (error "pffi-type->native-type -- No such pffi type" type)))) )
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((pffi-type->native-type ; Chicken has this procedure in three places (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 'string) (foreign-value "sizeof(void*)" int))
((equal? type 'callback) (foreign-value "sizeof(void*)" int))))) ((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
#;(define pffi-pointer-allocate (define make-c-null
(lambda (size)
(allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer->address pointer)))
(define pffi-pointer-null
(lambda () (lambda ()
(address->pointer 0))) (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 (define-syntax pffi-shared-object-load
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
@ -158,13 +157,7 @@
`(foreign-declare ,(string-append "#include <" header ">"))) `(foreign-declare ,(string-append "#include <" header ">")))
headers)))))) headers))))))
#;(define pffi-pointer-free (define c-null?
(lambda (pointer)
(if (not (pointer? pointer))
(error "pffi-pointer-free -- Argument is not pointer" pointer))
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
(if (and (not (pointer? pointer)) (if (and (not (pointer? pointer))
pointer) pointer)
@ -215,8 +208,3 @@
((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
((equal? type 'pointer) (address->pointer (pointer-u64-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) ((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(opaque? object))) (opaque? object)))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((pffi-type->native-type (let* ((pffi-type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'byte) (cond ((equal? type 'int8) 'int)
((equal? type 'uint8) 'unsigned-byte) ((equal? type 'uint8) 'int)
((equal? type 'int16) 'int16_t) ((equal? type 'int16) 'int)
((equal? type 'uint16) 'uint16_t) ((equal? type 'uint16) 'int)
((equal? type 'int32) 'int32) ((equal? type 'int32) 'int)
((equal? type 'uint32) 'unsigned-int32) ((equal? type 'uint32) 'int)
((equal? type 'int64) 'integer-64) ((equal? type 'int64) 'int)
((equal? type 'uint64) 'unsigned-integer64) ((equal? type 'uint64) 'int)
((equal? type 'char) 'char) ((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char) ((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short) ((equal? type 'short) 'short)
@ -50,22 +50,21 @@
((equal? type 'unsigned-long) 'unsigned-long) ((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float) ((equal? type 'float) 'float)
((equal? type 'double) 'double) ((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer) ((equal? type 'pointer) 'opaque)
((equal? type 'void) 'void) ((equal? type 'void) 'c-void)
((equal? type 'struct) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (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)))))))) (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))))))))) (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types (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) (if (null? types)
'() '()
(map pffi-type->native-type (map car (map cdr types))))))) (map pffi-type->native-type types)))))
(if (null? argument-types) (if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name) `(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name `(c-define ,scheme-name
,return-type ,c-name ,@ argument-types)))))) ,return-type ,c-name ,@argument-types))))))
(define pffi-define-callback (define pffi-define-callback
(lambda (scheme-name return-type argument-types procedure) (lambda (scheme-name return-type argument-types procedure)
@ -93,38 +92,31 @@
((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int))))) ((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
#;(define-c pffi-pointer-allocate (define-c pffi-pointer-address
"(void *data, int argc, closure _, object k, object size)" "(void *data, int argc, closure _, object k, object pointer)"
"make_c_opaque(opq, malloc(obj_obj2int(size))); "make_c_opaque(opq, &(void*)opaque_ptr(pointer));
return_closcall1(data, k, &opq);") return_closcall1(data, k, &opq);")
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(make-opaque))) (make-opaque)))
#;(define-c pffi-string->pointer (define-syntax define-c-library
"(void *data, int argc, closure _, object k, object s)" (syntax-rules ()
"make_c_opaque(opq, string_str(s)); ((_ scheme-name headers object-name options)
return_closcall1(data, k, &opq);") (begin
(define scheme-name #t)
#;(define-c pffi-pointer->string (pffi-shared-object-load headers)))))
"(void *data, int argc, closure _, object k, object p)"
"make_string(s, opaque_ptr(p));
return_closcall1(data, k, &s);")
(define-syntax pffi-shared-object-load (define-syntax pffi-shared-object-load
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
`(begin (let* ((headers (cadr (cadr expr)))
,@ (map (includes (map
(lambda (header) (lambda (header)
`(include-c-header ,(string-append "<" header ">"))) `(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr)))))))) headers)))
`(,@includes)))))
#;(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));")
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)

119
retropikzel/pffi/gambit.scm
View File

@ -1,11 +1,6 @@
(c-declare "#include <stdlib.h>") (c-declare "#include <stdlib.h>")
(c-declare "#include <stdint.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-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_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));")) (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))))) (else (error "Can not get size of unknown type" type)))))
(define-macro (define-macro
(pffi-define-library name headers object-name . options) (define-c-library name headers object-name . options)
`(begin (define ,name #t) (begin
(c-declare ,(apply string-append (let ((c-code (apply string-append
(map (map
(lambda (header) (lambda (header)
(string-append "#include <" header ">" (string #\newline))) (string-append "#include <" header ">" (string #\newline)))
(cdr headers)))))) (car (cdr headers))))))
`(begin (define ,name #t) (c-declare ,c-code)))))
(define pointer? (c-lambda ((pointer void)) bool "___return(1);")) (define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(call-with-current-continuation (call-with-current-continuation
(lambda (k) (lambda (k)
@ -69,20 +66,6 @@
(lambda (x) #f) (lambda (x) #f)
(lambda () (pointer? object))))))) (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-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-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;")) (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))))) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define-macro (define-macro
(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)
(letrec* ((native-argument-types (begin
(if (equal? '(list) argument-types) (letrec* ((pffi-type->native-type
(list) (lambda (type)
(let ((types (map cdr (cdr argument-types)))) (cond ((equal? type 'int8) 'byte)
(if (null? types) types (map car types))))) ((equal? type 'uint8) 'unsigned-int8)
(native-return-type (car (cdr return-type))) ((equal? type 'int16) 'int16_t)
(c-arguments (lambda (index argument-count result) ((equal? type 'uint16) 'uint16_t)
(if (> index argument-count) ((equal? type 'int32) 'int32)
result ((equal? type 'uint32) 'unsigned-int32)
(c-arguments (+ index 1) ((equal? type 'int64) 'int64)
argument-count ((equal? type 'uint64) 'unsigned-int64)
(string-append result ((equal? type 'char) 'char)
"___arg" ((equal? type 'unsigned-char) 'unsigned-char)
(number->string index) ((equal? type 'short) 'short)
(if (< index argument-count) ((equal? type 'unsigned-short) 'unsigned-short)
", " ((equal? type 'int) 'int)
"")))))) ((equal? type 'unsigned-int) 'unsigned-int)
(c-code (string-append ((equal? type 'long) 'long)
(if (equal? 'void (cadr return-type)) "" "___return(") ((equal? type 'unsigned-long) 'unsigned-long)
(symbol->string (cadr c-name)) ((equal? type 'float) 'float)
"(" (c-arguments 1 (- (length argument-types) 1) "") ")" ((equal? type 'double) 'double)
(if (equal? 'void (cadr return-type)) "" ")") ((equal? type 'pointer) '(pointer void))
";"))) ((equal? type 'void) 'void)
`(define ,scheme-name ((equal? type 'callback) 'c-pointer)
(c-lambda ,native-argument-types ((equal? type 'struct) 'c-pointer)
,native-return-type (else (error "pffi-type->native-type -- No such pffi type" type)))))
,c-code)))) (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-double (pointer offset::<int>) pointer_get_double)
(define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer) (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 dlerror () pffi_dlerror)
(define-cproc dlsym (shared-object c-name) pffi_dlsym) (define-cproc dlsym (shared-object c-name) pffi_dlsym)
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) (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 (define-module retropikzel.pffi.gauche
(export size-of-type (export size-of-type
pffi-shared-object-load pffi-shared-object-load
pffi-pointer-null ;pffi-pointer-null
pffi-pointer-null? ;pffi-pointer-null?
pffi-pointer-allocate make-c-bytevector
pffi-pointer-address pffi-pointer-address
pffi-pointer? c-bytevector?
pffi-pointer-free c-free
pffi-pointer-set! pffi-pointer-set!
pffi-pointer-get pffi-pointer-get
pffi-string->pointer define-c-procedure))
pffi-pointer->string
pffi-define-function))
(select-module retropikzel.pffi.gauche) (select-module retropikzel.pffi.gauche)
(dynamic-load "retropikzel/pffi/gauche-pffi") (dynamic-load "retropikzel/pffi/gauche-pffi")
@ -45,27 +43,15 @@
(lambda (path options) (lambda (path options)
(shared-object-load path))) (shared-object-load path)))
(define pffi-pointer-null (define make-c-bytevector
(lambda ()
(pointer-null)))
(define pffi-pointer-null?
(lambda (pointer)
(pointer-null? pointer)))
(define pffi-pointer-allocate
(lambda (size) (lambda (size)
(pointer-allocate size))) (pointer-allocate size)))
(define pffi-pointer-address (define c-bytevector?
(lambda (object)
(pointer-address object)))
(define pffi-pointer?
(lambda (pointer) (lambda (pointer)
(pointer? pointer))) (pointer? pointer)))
(define pffi-pointer-free (define c-free
(lambda (pointer) (lambda (pointer)
(pointer-free pointer))) (pointer-free pointer)))
@ -141,7 +127,7 @@
(define argument->pointer (define argument->pointer
(lambda (value type) (lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value)) (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) (pffi-pointer-set! pointer type 0 value)
pointer))))) pointer)))))
@ -150,10 +136,10 @@
(dlerror) ;; Clean all previous errors (dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name)) (let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror))) (maybe-dlerror (dlerror)))
(when (not (pffi-pointer-null? maybe-dlerror)) #;(when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror))) (error (c-bytevector->string maybe-dlerror)))
(lambda arguments (lambda arguments
(let ((return-value (pffi-pointer-allocate (let ((return-value (make-c-bytevector
(if (equal? return-type 'void) (if (equal? return-type 'void)
0 0
(size-of-type return-type))))) (size-of-type return-type)))))
@ -168,7 +154,7 @@
(cond ((not (equal? return-type 'void)) (cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0)))))))) (pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name

32
retropikzel/pffi/gerbil.scm
View File

@ -2,11 +2,11 @@
(lambda (type) (lambda (type)
(error "Not defined"))) (error "Not defined")))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(error "Not defined"))) (error "Not defined")))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(error "Not defined")))) (error "Not defined"))))
@ -15,34 +15,10 @@
(lambda (type) (lambda (type)
(error "Not defined"))) (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 (define pffi-shared-object-load
(lambda (header path) (lambda (header path)
(error "Not defined"))) (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! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(let ((p pointer)) (let ((p pointer))
@ -51,7 +27,3 @@
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(error "Not defined"))) (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) '*) ((equal? type 'struct) '*)
(else #f)))) (else #f))))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
@ -53,39 +53,10 @@
(native-type (sizeof native-type)) (native-type (sizeof native-type))
(else #f))))) (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 (define pffi-shared-object-load
(lambda (path options) (lambda (path options)
(load-foreign-library path))) (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! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100)))) (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 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-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 '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 '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)))))))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -129,9 +99,4 @@
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness))) ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-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 '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 '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))))

32
retropikzel/pffi/kawa.scm
View File

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

43
retropikzel/pffi/larceny.scm
View File

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

46
retropikzel/pffi/mosh.scm
View File

@ -25,33 +25,13 @@
(else #f)))) (else #f))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (path . options) (lambda (path options)
(open-shared-library path))) (open-shared-library path)))
(define pffi-pointer-null (define c-bytevector?
(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?
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
#;(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer 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 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (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 (define pffi-type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'int8_t) (cond ((equal? type 'int8) 'int8_t)
@ -139,7 +103,7 @@
((equal? type 'struct) 'void*) ((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
@ -155,7 +119,3 @@
(make-c-callback (pffi-type->native-type return-type) (make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types) (map pffi-type->native-type argument-types)
procedure))))) 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 'pointer) _pointer)
((equal? type 'void) _void) ((equal? type 'void) _void)
((equal? type 'callback) _pointer) ((equal? type 'callback) _pointer)
((equal? type 'string) _pointer)
((equal? type 'struct) _pointer) ((equal? type 'struct) _pointer)
(else #f)))) (else #f))))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(cpointer? object))) (cpointer? object)))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
@ -53,31 +52,6 @@
(ctype-sizeof native-type) (ctype-sizeof native-type)
#f)))) #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 (define pffi-shared-object-load
(lambda (path options) (lambda (path options)
(if (and (not (null? options)) (if (and (not (null? options))
@ -87,14 +61,6 @@
(list #f)))) (list #f))))
(ffi-lib path)))) (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! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(ptr-set! pointer (ptr-set! pointer
@ -114,7 +80,3 @@
(if (equal? type 'char) (if (equal? type 'char)
(integer->char r) (integer->char r)
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 (define pffi-type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'int8_t) (cond ((equal? type 'int8) 'int8_t)
@ -25,11 +55,7 @@
((and (pair? type) (equal? 'struct (car type))) 'void*) ((and (pair? type) (equal? 'struct (car type))) 'void*)
(else #f)))) (else #f))))
(define pffi-pointer? (define-syntax define-c-procedure
(lambda (object)
(pointer? object)))
(define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
@ -46,72 +72,9 @@
(map pffi-type->native-type argument-types) (map pffi-type->native-type argument-types)
procedure))))) procedure)))))
(define size-of-type (define c-bytevector?
(lambda (type) (lambda (object)
(cond ((eq? type 'int8) size-of-int8_t) (pointer? object)))
((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 pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
@ -156,3 +119,4 @@
((equal? type 'double) (pointer-ref-c-double pointer offset)) ((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (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 (define pffi-list->array
(lambda (type list-arg) (lambda (type list-arg)
(let* ((array-size (length list-arg)) (let* ((array-size (length list-arg))
(type-size (pffi-size-of type)) (type-size (c-size-of type))
(array (pffi-pointer-allocate (* type-size array-size))) (array (make-c-bytevector (* type-size array-size)))
(offset 0)) (offset 0))
(for-each (for-each
(lambda (item) (lambda (item)
@ -25,7 +25,7 @@
(define pffi-array->list (define pffi-array->list
(lambda (array) (lambda (array)
(letrec* ((type (pffi-array-type 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))) (max-offset (* type-size (pffi-array-size array)))
(array-pointer (pffi-array-pointer array)) (array-pointer (pffi-array-pointer array))
(looper (lambda (offset result) (looper (lambda (offset result)
@ -40,19 +40,19 @@
(define pffi-array-allocate (define pffi-array-allocate
(lambda (type size) (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 (define pffi-array-get
(lambda (array index) (lambda (array index)
(let ((type (pffi-array-type array))) (let ((type (pffi-array-type array)))
(pffi-pointer-get (pffi-array-pointer array) (pffi-pointer-get (pffi-array-pointer array)
type type
(* (pffi-size-of type) index))))) (* (c-size-of type) index)))))
(define pffi-array-set! (define pffi-array-set!
(lambda (array index value) (lambda (array index value)
(let ((type (pffi-array-type array))) (let ((type (pffi-array-type array)))
(pffi-pointer-set! (pffi-array-pointer array) (pffi-pointer-set! (pffi-array-pointer array)
type type
(* (pffi-size-of type) index) (* (c-size-of type) index)
value)))) value))))

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

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

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

@ -1,75 +1,105 @@
(cond-expand (cond-expand
(windows (pffi-define-library pffi-libc-stdlib (windows (define-c-library libc
'("stdlib.h") '("stdlib.h" "string.h")
"ucrtbase" "ucrtbase"
'((additional-versions ("0" "6"))))) '((additional-versions ("0" "6")))))
(else (pffi-define-library pffi-libc-stdlib (else (define-c-library libc
'("stdlib.h") '("stdlib.h" "string.h")
"c" "c"
'((additional-versions ("0" "6")))))) '((additional-versions ("0" "6"))))))
(cond-expand (define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(windows (pffi-define-library pffi-libc-stdio (define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int))
'("stdio.h") (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
"ucrtbase" (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
'((additional-versions ("0" "6"))))) (define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
(else (pffi-define-library pffi-libc-stdio (define-c-procedure c-malloc libc 'malloc 'pointer '(int))
'("stdio") (define-c-procedure c-strlen libc 'strlen 'int '(pointer))
"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))
(cond-expand (cond-expand
(chibi #t) ; FIXME (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 (cond-expand
(chibi #t) ; FIXME (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 (define bytevector->c-bytevector
(lambda () (lambda (bytes)
(let ((pointer (pffi-pointer-allocate (pffi-size-of 'pointer)))) (letrec* ((bytes-length (bytevector-length bytes))
(pffi-pointer-set! pointer 'int 0 0) (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))) pointer)))
#;(define pffi-pointer-null? (define c-bytevector->bytevector
(lambda (pointer) (lambda (pointer size)
(let ((address (letrec* ((bytes (make-bytevector size))
(let ((str (pffi-pointer-allocate 512))) (looper (lambda (index)
(c-snprintf str 512 (pffi-string->pointer "%p") pointer) (let ((byte (pffi-pointer-get pointer 'uint8 index)))
(display "Scheme: p1 address: ") (if (= index size)
(write (pffi-pointer->string str)) bytes
(newline) (begin
(display "Scheme: p1 address int: ") (bytevector-u8-set! bytes index byte)
(write (c-strtol str (pffi-pointer-null) 16)) (looper (+ index 1))))))))
(newline) (looper 0))))
(c-strtol str (pffi-pointer-null) 16))))
(= address 0))))
#;(define pffi-pointer-address (define c-bytevector-string-length
(lambda (bytevector)
(c-strlen bytevector)))
(define c-bytevector->string
(lambda (pointer) (lambda (pointer)
(let* ((address-number (when (not (c-bytevector? pointer))
(let ((str (pffi-pointer-allocate 512))) (error "c-bytevector->string argument not c-bytevector" pointer))
(c-snprintf str 512 (pffi-string->pointer "%p") pointer) (let ((size (c-strlen pointer)))
(display "Scheme: p1 address: ") (utf8->string (c-bytevector->bytevector pointer size)))))
(write (pffi-pointer->string str))
(newline) (define string->c-bytevector
(display "Scheme: p1 address int: ") (lambda (text)
(write (c-strtol str (pffi-pointer-null) 16)) (when (not (string? text))
(newline) (error "string->bytevector argument not string" text))
(c-strtol str (pffi-pointer-null) 16))) (bytevector->c-bytevector (string->utf8 (string-append text (string #\null))))))
(address (pffi-pointer-allocate (pffi-size-of 'uint64))))
(display "Scheme: p2 address: ") (cond-expand
(write address) (kawa #t) ; FIXME
(newline) (chicken #t) ; FIXME
;address-number (else (define make-c-null
(pffi-pointer-set! address 'uint64 0 address-number) (lambda ()
;address-number (cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
;(pffi-pointer-get address 'pointer 0) (free-bytes pointer)
address 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))) (size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets))) (offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (if (and (not (null? arguments)) (pointer (if (and (not (null? arguments))
(pffi-pointer? (car arguments))) (c-bytevector? (car arguments)))
(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)))) (c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type-string size pointer offsets))))))) (struct-make c-type-string size pointer offsets)))))))
#;(define pffi-struct-dereference (define c-align-of
(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
(lambda (type) (lambda (type)
(cond-expand (cond-expand
;(guile (alignof (pffi-type->native-type type))) ;(guile (alignof (pffi-type->native-type type)))
@ -60,7 +40,7 @@
(offsets (map (lambda (member) (offsets (map (lambda (member)
(let* ((name (cdr member)) (let* ((name (cdr member))
(type (car member)) (type (car member))
(type-alignment (pffi-align-of type))) (type-alignment (c-align-of type)))
(when (> (size-of-type type) largest-member-size) (when (> (size-of-type type) largest-member-size)
(set! largest-member-size (size-of-type type))) (set! largest-member-size (size-of-type type)))
(if (or (= size 0) (if (or (= size 0)
@ -97,7 +77,7 @@
(let* ((size-and-offsets (calculate-struct-size-and-offsets members)) (let* ((size-and-offsets (calculate-struct-size-and-offsets members))
(size (cdr (assoc 'size size-and-offsets))) (size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets 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)))) (c-type (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type size pointer offsets)))) (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 (define pffi-type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) :int) (cond ((equal? type 'int8) :char)
((equal? type 'uint8) :uint) ((equal? type 'uint8) :char)
((equal? type 'int16) :int) ((equal? type 'int16) :short)
((equal? type 'uint16) :uint) ((equal? type 'uint16) :ushort)
((equal? type 'int32) :int) ((equal? type 'int32) :int)
((equal? type 'uint32) :uint) ((equal? type 'uint32) :uint)
((equal? type 'int64) :int) ((equal? type 'int64) :long)
((equal? type 'uint64) :uint) ((equal? type 'uint64) :ulong)
((equal? type 'char) :char) ((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar) ((equal? type 'unsigned-char) :uchar)
((equal? type 'short) :short) ((equal? type 'short) :short)
@ -19,21 +19,15 @@
((equal? type 'float) :float) ((equal? type 'float) :float)
((equal? type 'double) :double) ((equal? type 'double) :double)
((equal? type 'pointer) :pointer) ((equal? type 'pointer) :pointer)
((equal? type 'string) :string)
((equal? type 'void) :void) ((equal? type 'void) :void)
((equal? type 'struct) :void) ((equal? type 'struct) :void)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer? (define c-bytevector?
(lambda (object) (lambda (object)
(display "HERE: ")
(write object)
(newline)
(write (cpointer? object))
(newline)
(cpointer? object))) (cpointer? object)))
(define-syntax pffi-define-function (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(begin (begin
@ -76,53 +70,25 @@
; FIXME ; FIXME
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(cond (cond ((equal? type 'int8) 1)
((equal? type 'int8) 1) ((equal? type 'uint8) 1)
((equal? type 'uint8) 1) ((equal? type 'int16) 2)
((equal? type 'int16) 2) ((equal? type 'uint16) 2)
((equal? type 'uint16) 2) ((equal? type 'int32) 4)
((equal? type 'int32) 4) ((equal? type 'uint32) 4)
((equal? type 'uint32) 4) ((equal? type 'int64) 8)
((equal? type 'int64) 8) ((equal? type 'uint64) 8)
((equal? type 'uint64) 8) ((equal? type 'char) 1)
((equal? type 'char) 1) ((equal? type 'unsigned-char) 1)
((equal? type 'unsigned-char) 1) ((equal? type 'short) 2)
((equal? type 'short) 2) ((equal? type 'unsigned-short) 2)
((equal? type 'unsigned-short) 2) ((equal? type 'int) 4)
((equal? type 'int) 4) ((equal? type 'unsigned-int) 4)
((equal? type 'unsigned-int) 4) ((equal? type 'long) 8)
((equal? type 'long) 8) ((equal? type 'unsigned-long) 8)
((equal? type 'unsigned-long) 8) ((equal? type 'float) 4)
((equal? type 'float) 4) ((equal? type 'double) 8)
((equal? type 'double) 8) ((equal? type 'pointer) 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))))
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)

159
retropikzel/pffi/ypsilon.scm
View File

@ -25,52 +25,13 @@
((eq? type 'void) 0) ((eq? type 'void) 0)
(else #f)))) (else #f))))
;(define c-malloc (c-function void* malloc (size_t))) (define c-bytevector?
;(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?
(lambda (object) (lambda (object)
(number? 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! (define pffi-pointer-set!
(lambda (pointer type offset value) (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)) (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
((equal? type 'uint8) (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)) ((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
@ -93,7 +54,7 @@
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (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)) (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
((equal? type 'uint8) (bytevector-c-uint8-ref bv 0)) ((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
((equal? type 'int16) (bytevector-c-int16-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)))))) ((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (headers path options) (lambda (path options)
(load-shared-object path))) (load-shared-object path)))
(define-macro (pffi-type->native-type type) #;(define-macro
`(cond ((equal? ,type int8) int8_t) (pffi-type->native-type type)
((equal? ,type uint8) uint8_t) `(cond ((equal? ,type 'int8) 'int8_t)
((equal? ,type int16) int16_t) ((equal? ,type 'uint8) 'uint8_t)
((equal? ,type uint16) uint16_t) ;((equal? ,type 'int16) 'int16_t)
((equal? ,type int32) int32_t) ;((equal? ,type 'uint16) 'uint16_t)
((equal? ,type uint32) uint32_t) ;((equal? ,type 'int32) 'int32_t)
((equal? ,type int64) int64_t) ;((equal? ,type 'uint32) 'uint32_t)
((equal? ,type uint64) uint64_t) ;((equal? ,type 'int64) 'int64_t)
((equal? ,type char) char) ;((equal? ,type 'uint64) 'uint64_t)
((equal? ,type unsigned-char) char) ;((equal? ,type 'char) 'char)
((equal? ,type short) short) ;((equal? ,type 'unsigned-char) 'char)
((equal? ,type unsigned-short) unsigned-short) ;((equal? ,type 'short) 'short)
((equal? ,type int) int) ;((equal? ,type 'unsigned-short) 'unsigned-short)
((equal? ,type unsigned-int) unsigned-int) ((equal? ,type 'int) 'int)
((equal? ,type long) long) ;((equal? ,type 'unsigned-int) 'unsigned-int)
((equal? ,type unsigned-long) unsigned-long) ;((equal? ,type 'long) 'long)
((equal? ,type float) float) ;((equal? ,type 'unsigned-long) 'unsigned-long)
((equal? ,type double) double) ;((equal? ,type 'float) 'float)
((equal? ,type pointer) void*) ;((equal? ,type 'double) 'double)
((equal? ,type string) void*) ((equal? ,type 'pointer) 'void*)
((equal? ,type void) void) ;((equal? ,type 'string) 'void*)
((equal? ,type callback) void*) ((equal? ,type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" ,type)))) ;((equal? ,type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
(define-macro (define-macro
(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)
`(define ,scheme-name (begin
(c-function ,(pffi-type->native-type return-type) (let ((pffi-type->native-type
,(cadr c-name) (lambda (type)
,(map pffi-type->native-type (cdr argument-types))))) (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 (define-macro
(pffi-define-callback scheme-name return-type argument-types procedure) (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 `(define ,scheme-name
(c-callback ,(pffi-type->native-type return-type) (c-callback ,(pffi-type->native-type return-type)
,(map pffi-type->native-type (cdr argument-types)) ,(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