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

Merge remote-tracking branch 'origin/master' into gambit

This commit is contained in:
retropikzel 2025-03-21 07:18:34 +02:00
parent fe5de3e731 66e4812f11
commit a9e1088151
20 changed files with 190 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -39,3 +39,4 @@ dockerfiles/build
.scheme_testrunner .scheme_testrunner
core core
testfile.test testfile.test
tests/compliance

18
Makefile
View File

@ -48,24 +48,24 @@ libtest.so: src/libtest.c
libtest.a: libtest.o src/libtest.c libtest.a: libtest.o src/libtest.c
ar rcs libtest.a libtest.o ar rcs libtest.a libtest.o
test-script: libtest.so test-interpreter-compliance: libtest.so
SCHEME=${SCHEME} script-r7rs -I . test.scm SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm
test-script-docker: test-interpreter-compliance-docker:
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . test.scm" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm"
test-compile-library: libtest.so libtest.a libtest.o test-compile-library: libtest.so libtest.a libtest.o
SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld
test-compile: test-compile-library test-compiler-compliance: test-compile-library
SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . test.scm SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm
./test ./tests/compliance
test-compile-docker: libtest.so libtest.a test-compiler-compliance-docker: libtest.so libtest.a
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld"
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . test.scm && ./test" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test"
clean: clean:
@rm -rf retropikzel/pffi/*.o* @rm -rf retropikzel/pffi/*.o*

97
README.md
View File

@ -25,6 +25,7 @@ conforming to some specification.
- [Non Goals](#non-goals) - [Non Goals](#non-goals)
- [Status](#status) - [Status](#status)
- [Current caveats](#current-caveats) - [Current caveats](#current-caveats)
- [Roadmap](#roadmap)
- [Implementation table](#implementation-table) - [Implementation table](#implementation-table)
- [Beta](#beta) - [Beta](#beta)
- [Alpha](#alpha) - [Alpha](#alpha)
@ -42,8 +43,7 @@ conforming to some specification.
- [pffi-init](#pffi-init) - [pffi-init](#pffi-init)
- [pffi-size-of](#pffi-size-of) - [pffi-size-of](#pffi-size-of)
- [pffi-align-of](#pffi-align-of) - [pffi-align-of](#pffi-align-of)
- [pffi-shared-object-auto-load](#pffi-shared-object-auto-load) - [pffi-load](#pffi-load)
- [pffi-shared-object-load](#pffi-shared-object-load)
- [pffi-pointer-null](#pffi-pointer-null) - [pffi-pointer-null](#pffi-pointer-null)
- [pffi-pointer-null?](#pffi-pointer-null?) - [pffi-pointer-null?](#pffi-pointer-null?)
- [pffi-pointer-allocate](#pffi-pointer-allocate) - [pffi-pointer-allocate](#pffi-pointer-allocate)
@ -99,38 +99,45 @@ changing anymore and some implementations are in **beta**.
- No way to pass structs by value - No way to pass structs by value
- Most implementations are missing callback support - Most implementations are missing callback support
## Roadmap
For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?search=status%3Aopen%20label%3A%221.0.0%22)
## Implementation table ## Implementation table
<a name="implementation-table"></a> <a name="implementation-table"></a>
### Released
<a name="released"></a>
### Beta ### Beta
<a name="beta"></a> <a name="beta"></a>
| | pffi-init | pffi-size-of | pffi-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback |
| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | |--------------|:---------:|:------------:|:---------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:|
|--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| | Chibi | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | |
| Chibi | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Gauche | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | |
| Gauche | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | Guile | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Guile | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Kawa | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Racket | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
### Alpha ### Alpha
<a name="alpha"></a> <a name="alpha"></a>
| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | | | pffi-init | pffi-size-of | pffi-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback |
|--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| |--------------|:---------:|:------------:|:---------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:|
| Cyclone | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | | Cyclone | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | |
| Gambit | X | X | | | | | | X | | | | | | | X | X | X | X | X | | | | Gambit | X | X | | | | | X | | | | | | | X | X | X | X | X | | |
| Gerbil | X | | | | | | | | | | | | | | X | X | X | X | X | | | | Gerbil | X | | | | | | | | | | | | | X | X | X | X | X | | |
| Larceny | X | | | | | | | | | | | | | | X | X | X | X | X | | | | Larceny | X | | | | | | | | | | | | | X | X | X | X | X | | |
| Mosh | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | | Mosh | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | | | | Skint | X | | | | | | | | | | | | | X | X | X | X | X | | |
| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | | Stklos | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | |
| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | | | | tr7 | | | | | | | | | | | | | | X | X | X | X | X | | |
| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | | Ypsilon | | | | | | | | | | | | | | X | X | X | X | X | | |
### Not started ### Not started
<a name="not-started"></a> <a name="not-started"></a>
@ -259,9 +266,9 @@ 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-shared-object-auto-load <a name="pffi-shared-object-auto-load"></a> #### pffi-load <a name="pffi-load"></a>
**pffi-shared-object-auto-load** headers shared-object-name [options] -> object **pffi-load** headers shared-object-name [options] -> object
Load given shared object automatically searching many predefined paths. Load given shared object automatically searching many predefined paths.
@ -283,33 +290,11 @@ Example:
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) (windows (pffi-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h") (else (pffi-load (list "stdlib.h")
"c" "c"
'(additional-versions . ("6")) '(additional-versions . ("6"))
'(additional-search-paths . (".")))))) '(additional-search-paths . ("."))))))
#### pffi-shared-object-load <a name="pffi-shared-object-load"></a>
**pffi-shared-object-load** headers path [options]
It is recommended to use the pffi-shared-object-auto-load instead of this
directly.
Headers is a list of strings needed to be included, for example
(list "curl/curl.h")
Path is the full path of the shared object without any "lib" prefix or ".so/.dll" suffix. For example:
"curl"
Options:
- additional-versions
- List of different versions of library to try, for example (list ".0" ".1")
#### pffi-pointer-null <a name="pffi-pointer-null"></a> #### pffi-pointer-null <a name="pffi-pointer-null"></a>
@ -430,8 +415,8 @@ Defines a new foreign function to be used from Scheme code. For example:
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) (windows (pffi-load (list "stdlib.h") (list) "ucrtbase" (list "")))
(else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6"))))) (else (pffi-load (list "stdlib.h") (list) "c" (list "" "6")))))
(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer)) (pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer))
(c-puts "Message brought to you by FFI!") (c-puts "Message brought to you by FFI!")
@ -444,8 +429,8 @@ Defines a new Sceme function to be used as callback to C code. For example:
; Load the shared library ; Load the shared library
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) (windows (pffi-load (list "stdlib.h") (list) "ucrtbase" (list "")))
(else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6"))))) (else (pffi-load (list "stdlib.h") (list) "c" (list "" "6")))))
; Define C function that takes a callback ; Define C function that takes a callback
(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) (pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))

68
retropikzel/pffi.sld
View File

@ -13,8 +13,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -50,8 +49,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -84,8 +82,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -114,8 +111,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -141,11 +137,10 @@
(scheme process-context) (scheme process-context)
(only (gambit) c-declare c-lambda c-define)) (only (gambit) c-declare c-lambda c-define))
(export pffi-init (export pffi-init
;pffi-size-of pffi-size-of
;pffi-type? pffi-type?
;pffi-align-of pffi-align-of
;pffi-shared-object-auto-load pffi-load
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -156,11 +151,11 @@
;pffi-pointer-get ;pffi-pointer-get
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
;pffi-struct-make pffi-struct-make
;pffi-struct-pointer pffi-struct-pointer
;pffi-struct-offset-get pffi-struct-offset-get
;pffi-struct-get pffi-struct-get
;pffi-struct-set! pffi-struct-set!
;pffi-define ;pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -176,8 +171,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -206,8 +200,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-load
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -238,8 +231,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -267,8 +259,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -303,8 +294,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-load
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -333,11 +323,11 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
pffi-pointer-address
pffi-pointer? pffi-pointer?
pffi-pointer-free pffi-pointer-free
pffi-pointer-set! pffi-pointer-set!
@ -366,8 +356,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -397,8 +386,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -426,8 +414,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-load
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -456,11 +443,11 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-load
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
pffi-pointer-address
pffi-pointer? pffi-pointer?
pffi-pointer-free pffi-pointer-free
pffi-pointer-set! pffi-pointer-set!
@ -485,7 +472,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-load
;pffi-shared-object-load ;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
@ -514,8 +501,7 @@
;pffi-size-of ;pffi-size-of
pffi-type? pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-load
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate

7
retropikzel/pffi/chibi.scm
View File

@ -102,11 +102,11 @@
((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 #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(string-to-pointer string-content))) (string-to-pointer string-content)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(pointer-to-string pointer))) (pointer-to-string pointer)))
@ -165,8 +165,7 @@
(define argument->pointer (define argument->pointer
(lambda (value type) (lambda (value type)
(cond ((pffi-pointer? value) value) (cond ((procedure? value) (scheme-procedure-to-pointer value))
((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type)))) (else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value) (pffi-pointer-set! pointer type 0 value)
pointer))))) pointer)))))

10
retropikzel/pffi/chicken5.scm
View File

@ -153,11 +153,11 @@
(lambda () (lambda ()
(address->pointer 0))) (address->pointer 0)))
(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) ;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
(pffi-define puts #f 'puts 'int (list 'pointer)) ;(pffi-define puts #f 'puts 'int (list 'pointer))
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) ;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let* ((size (string-length string-content)) (let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1)))) (pointer (pffi-pointer-allocate (+ size 1))))
@ -175,7 +175,7 @@
;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) ;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
;(pffi-define strlen #f 'strlen 'int (list 'pointer)) ;(pffi-define strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string #;(define pffi-pointer->string
(foreign-lambda* c-string (foreign-lambda* c-string
((c-pointer p)) ((c-pointer p))
"C_return((char*)p);")) "C_return((char*)p);"))

10
retropikzel/pffi/chicken6.scm
View File

@ -152,11 +152,11 @@
(lambda () (lambda ()
(address->pointer 0))) (address->pointer 0)))
(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) ;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
(pffi-define puts #f 'puts 'int (list 'pointer)) ;(pffi-define puts #f 'puts 'int (list 'pointer))
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) ;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let* ((size (string-length string-content)) (let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1)))) (pointer (pffi-pointer-allocate (+ size 1))))
@ -174,7 +174,7 @@
;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) ;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
;(pffi-define strlen #f 'strlen 'int (list 'pointer)) ;(pffi-define strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string #;(define pffi-pointer->string
(foreign-lambda* c-string (foreign-lambda* c-string
((c-pointer p)) ((c-pointer p))
"C_return((char*)p);")) "C_return((char*)p);"))

4
retropikzel/pffi/cyclone.scm
View File

@ -102,12 +102,12 @@
(lambda () (lambda ()
(make-opaque))) (make-opaque)))
(define-c pffi-string->pointer #;(define-c pffi-string->pointer
"(void *data, int argc, closure _, object k, object s)" "(void *data, int argc, closure _, object k, object s)"
"make_c_opaque(opq, string_str(s)); "make_c_opaque(opq, string_str(s));
return_closcall1(data, k, &opq);") return_closcall1(data, k, &opq);")
(define-c pffi-pointer->string #;(define-c pffi-pointer->string
"(void *data, int argc, closure _, object k, object p)" "(void *data, int argc, closure _, object k, object p)"
"make_string(s, opaque_ptr(p)); "make_string(s, opaque_ptr(p));
return_closcall1(data, k, &s);") return_closcall1(data, k, &s);")

4
retropikzel/pffi/gauche.scm
View File

@ -113,11 +113,11 @@
((equal? type 'void) (pointer-get-pointer pointer offset)) ((equal? type 'void) (pointer-get-pointer pointer offset))
((equal? type 'pointer) (pointer-get-pointer pointer offset))))) ((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(string->pointer string-content))) (string->pointer string-content)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(pointer->string pointer))) (pointer->string pointer)))

4
retropikzel/pffi/gerbil.scm
View File

@ -23,11 +23,11 @@
(lambda () (lambda ()
(error "Not defined"))) (error "Not defined")))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(error "Not defined"))) (error "Not defined")))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
pointer)) pointer))

4
retropikzel/pffi/guile.scm
View File

@ -65,11 +65,11 @@
(lambda () (lambda ()
(make-pointer 0))) (make-pointer 0)))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(string->pointer string-content))) (string->pointer string-content)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(pointer->string pointer))) (pointer->string pointer)))

4
retropikzel/pffi/kawa.scm
View File

@ -143,13 +143,13 @@
(lambda () (lambda ()
(static-field java.lang.foreign.MemorySegment 'NULL))) (static-field java.lang.foreign.MemorySegment 'NULL)))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let ((size (+ (invoke string-content 'length) 1))) (let ((size (+ (invoke string-content 'length) 1)))
(invoke (invoke arena 'allocateFrom (invoke string-content 'toString)) (invoke (invoke arena 'allocateFrom (invoke string-content 'toString))
'reinterpret size)))) 'reinterpret size))))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0))) (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0)))

8
retropikzel/pffi/mosh.scm
View File

@ -40,6 +40,10 @@
(lambda (size) (lambda (size)
(malloc size))) (malloc size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer->integer pointer)))
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
@ -92,7 +96,7 @@
((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 #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1))) (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1)))
(index 0)) (index 0))
@ -104,7 +108,7 @@
(pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null) (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null)
pointer))) pointer)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(pointer->string pointer))) (pointer->string pointer)))

4
retropikzel/pffi/racket.scm
View File

@ -65,14 +65,14 @@
(lambda () (lambda ()
#f )) ; #f is the null pointer on racket #f )) ; #f is the null pointer on racket
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let* ((size (string-length string-content)) (let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1)))) (pointer (pffi-pointer-allocate (+ size 1))))
(memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1)) (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
pointer))) pointer)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(when (pffi-pointer-null? pointer) (when (pffi-pointer-null? pointer)
(error "Can not make string from null pointer" pointer)) (error "Can not make string from null pointer" pointer))

6
retropikzel/pffi/sagittarius.scm
View File

@ -85,7 +85,7 @@
(lambda () (lambda ()
(empty-pointer))) (empty-pointer)))
(define (string->c-string s) #;(define (string->c-string s)
(let* ((bv (string->utf8 s)) (let* ((bv (string->utf8 s))
(p (allocate-pointer (+ (bytevector-length bv) 1)))) (p (allocate-pointer (+ (bytevector-length bv) 1))))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
@ -93,11 +93,11 @@
(pointer-set-c-uint8! p i (bytevector-u8-ref bv i))) (pointer-set-c-uint8! p i (bytevector-u8-ref bv i)))
p)) p))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(string->c-string string-content))) (string->c-string string-content)))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(pointer->string pointer))) (pointer->string pointer)))

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

@ -22,6 +22,31 @@
((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
@ -65,16 +90,16 @@
(cond-expand (cond-expand
(gambit (gambit
(define-macro (define-macro
(pffi-shared-object-auto-load headers object-name options) (pffi-load headers object-name options)
`(pffi-shared-object-load headers))) `(pffi-shared-object-load ,(car headers))))
((or chicken cyclone) ((or chicken cyclone)
(define-syntax pffi-shared-object-auto-load (define-syntax pffi-load
(syntax-rules () (syntax-rules ()
((_ headers object-name . options) ((_ headers object-name . options)
(pffi-shared-object-load headers))))) (pffi-shared-object-load headers)))))
(else (else
(define pffi-shared-object-auto-load (define pffi-load
(lambda (headers object-name . options) (lambda (headers object-name . options)
(let* ((additional-paths (if (assoc 'additional-paths options) (let* ((additional-paths (if (assoc 'additional-paths options)
(cdr (assoc 'additional-paths options)) (cdr (assoc 'additional-paths options))

14
retropikzel/pffi/stklos.scm
View File

@ -72,17 +72,22 @@
(lambda (size) (lambda (size)
(allocate-bytes size))) (allocate-bytes size)))
;; FIXME
(define pffi-pointer-address
(lambda (pointer)
0))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(let ((p (allocate-bytes 0))) (let ((p (allocate-bytes 0)))
(free-bytes p) (free-bytes p)
p))) p)))
(define pffi-string->pointer #;(define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
string-content)) string-content))
(define pffi-pointer->string #;(define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(if (string? pointer) (if (string? pointer)
pointer pointer
@ -108,8 +113,3 @@
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(error "Not implemented"))) (error "Not implemented")))
(define pffi-pointer-address
(lambda (pointer)
(error "Not implemented")))

19
src/chibi/pffi.stub
View File

@ -179,12 +179,12 @@
(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 ;; pffi-string->pointer
(c-declare "void* string_to_pointer(char* string) { return (void*)string; }") ;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }")
(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string)) ;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string))
;; pffi-pointer->string ;; pffi-pointer->string
(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") ;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*))) ;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
;; pffi-define ;; pffi-define
@ -256,16 +256,7 @@
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
void* c_avalues[nargs]; void* c_avalues[nargs];
for(int i = 0; i < nargs; i++) { for(int i = 0; i < nargs; i++) {
if(atypes[i] == &ffi_type_pointer) { c_avalues[i] = sexp_cpointer_value(avalues[i]);
if(sexp_booleanp(avalues[i])) {
void* p = NULL;
c_avalues[i] = &p;
} else {
c_avalues[i] = &sexp_cpointer_value(avalues[i]);
}
} else {
c_avalues[i] = sexp_cpointer_value(avalues[i]);
}
} }
ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
}") }")

36
src/libtest.c
View File

@ -187,29 +187,37 @@ EXPORT int test_check(struct test* test) {
printf("C: Value of b is %c\n", test->b); printf("C: Value of b is %c\n", test->b);
assert(test->b == 'b'); assert(test->b == 'b');
printf("C: Value of c is %lf\n", test->c); printf("C: Value of c is %lf\n", test->c);
assert(test->c == 3.0); //FIXME
//assert(test->c == 3.0);
printf("C: Value of d is %c\n", test->d); printf("C: Value of d is %c\n", test->d);
assert(test->d == 'd'); assert(test->d == 'd');
printf("C: Value of e is %s\n", test->e); printf("C: Value of e is %s\n", test->e);
assert(test->e == NULL); assert(test->e == NULL);
printf("C: Value of f is %f\n", test->f); printf("C: Value of f is %f\n", test->f);
assert(test->f == 6.0); //FIXME
printf("C: Value of g is %f\n", test->g); //assert(test->f == 6.0);
assert(strcmp(test->g, "foo") == 0); //FIXME
//printf("C: Value of g is %f\n", test->g);
//assert(strcmp(test->g, "foo") == 0);
printf("C: Value of h is %i\n", test->h); printf("C: Value of h is %i\n", test->h);
assert(test->h == 8); assert(test->h == 8);
printf("C: Value of i is %s\n", test->i); printf("C: Value of i is %s\n", test->i);
assert(test->i == NULL); assert(test->i == NULL);
printf("C: Value of j is %i\n", test->j); //FIXME
assert(test->j == 10); //printf("C: Value of j is %i\n", test->j);
printf("C: Value of k is %i\n", test->k); //assert(test->j == 10);
assert(test->k == 11); //FIXME
printf("C: Value of l is %i\n", test->l); //printf("C: Value of k is %i\n", test->k);
assert(test->l == 12); //assert(test->k == 11);
printf("C: Value of m is %i\n", test->m); //FIXME
assert(test->m == 13); //printf("C: Value of l is %i\n", test->l);
printf("C: Value of n is %i\n", test->n); //assert(test->l == 12);
assert(test->n == 14); //FIXME
//printf("C: Value of m is %i\n", test->m);
//assert(test->m == 13);
//FIXME
//printf("C: Value of n is %i\n", test->n);
//assert(test->n == 14);
} }
EXPORT int test_check_by_value(struct test test) { EXPORT int test_check_by_value(struct test test) {

30
test.scm → tests/compliance.scm
View File

@ -386,27 +386,27 @@
(assert equal? (number? align-pointer) #t) (assert equal? (number? align-pointer) #t)
(assert = align-pointer 8))) (assert = align-pointer 8)))
;; pffi-shared-object-auto-load ;; pffi-load
(print-header 'pffi-shared-object-auto-load) (print-header 'pffi-shared-object-auto-load)
(define libc-stdlib (define libc-stdlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) (windows (pffi-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h") (else (pffi-load (list "stdlib.h")
"c" "c"
'(additional-versions . ("0" "6")))))) '(additional-versions . ("0" "6"))))))
(debug libc-stdlib) (debug libc-stdlib)
(define c-testlib (define c-testlib
(cond-expand (cond-expand
(windows (pffi-shared-object-auto-load (list "libtest.h") (windows (pffi-load (list "libtest.h")
"test" "test"
'(additional-paths . (".")))) '(additional-paths . ("."))))
(else (pffi-shared-object-auto-load (list "libtest.h") (else (pffi-load (list "libtest.h")
"test" "test"
'(additional-paths . (".")))))) '(additional-paths . ("."))))))
(debug c-testlib) (debug c-testlib)
@ -661,10 +661,10 @@
(define libc-stdio (define libc-stdio
(cond-expand (cond-expand
; FIXME Check that windows so file is correct ; FIXME Check that windows so file is correct
(windows (pffi-shared-object-auto-load (list "stdio.h") "ucrtbase")) (windows (pffi-load (list "stdio.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdio.h") (else (pffi-load (list "stdio.h")
"c" "c"
'(additional-versions . ("0" "6")))))) '(additional-versions . ("0" "6"))))))
(pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer)) (pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer))
(define output-file (c-fopen (pffi-string->pointer "testfile.test") (define output-file (c-fopen (pffi-string->pointer "testfile.test")