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

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

This commit is contained in:
retropikzel 2025-03-22 19:07:38 +02:00
parent 45be7ae8c6 d5fd1eb953
commit 603e6e1a50
17 changed files with 518 additions and 364 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

36
Makefile
View File

@ -1,10 +1,10 @@
.PHONY=libtest.o libtest.so libtest.a documentation .PHONY=libtest.o tests/libtest.so libtest.a documentation
CC=gcc CC=gcc
DOCKER=docker run -it -v ${PWD}:/workdir 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];}')
all: chibi gauche libtest.so libtest.o libtest.a all: chibi gauche tests/libtest.so libtest.o libtest.a
# apt-get install pandoc weasyprint # apt-get install pandoc weasyprint
docs: docs:
@ -42,30 +42,33 @@ jenkinsfile:
libtest.o: src/libtest.c libtest.o: src/libtest.c
${CC} -o libtest.o -fPIC -c src/libtest.c -I./include ${CC} -o libtest.o -fPIC -c src/libtest.c -I./include
libtest.so: src/libtest.c tests/libtest.so: src/libtest.c
${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include ${CC} -o tests/libtest.so -shared -fPIC src/libtest.c -I./include
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: tests/libtest.so
SCHEME=${SCHEME} script-r7rs -I . test.scm SCHEME=${SCHEME} script-r7rs -I . -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 . -I .. tests/compliance.scm"
test-compile-library: libtest.so libtest.a libtest.o test-compile-library: tests/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-compile: 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 -L." compile-r7rs -I . tests/compliance.scm
./test ./tests/compliance
test-compile-docker: libtest.so libtest.a test-compiler-compliance: test-compiler-compliance-compile
./tests/compliance
test-compiler-compliance-docker: tests/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*
@ -87,3 +90,8 @@ clean:
@rm -rf test @rm -rf test
find . -name "core.1" -delete find . -name "core.1" -delete
find . -name "*@gambit*" -delete find . -name "*@gambit*" -delete
rm -rf retropikzel/pffi.c
rm -rf tests/compliance.c
rm -rf tests/compliance.o
rm -rf tests/compliance.so
rm -rf tests/compliance

101
README.md
View File

@ -43,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)
@ -116,31 +115,31 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear
### Beta ### Beta
<a name="beta"></a> <a name="beta"></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 |
|--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| |--------------|:---------:|:------------:|:---------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:|
| Chibi | X | 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 | |
| Chicken-5 | X | 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 |
| Gauche | 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 | |
| Guile | X | 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 |
| Kawa | 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 |
| Racket | 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 |
| Saggittarius | 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 |
| Ypsilon | 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 | | |
### Not started ### Not started
<a name="not-started"></a> <a name="not-started"></a>
@ -269,9 +268,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-define-library <a name="pffi-define-library"></a>
**pffi-shared-object-auto-load** headers shared-object-name [options] -> object **pffi-define-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.
@ -291,35 +290,25 @@ keyword. The options are:
Example: Example:
(define libc-stdlib (cond-expand
(cond-expand (windows (pffi-define-library libc-stdlib
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) (list "stdlib.h")
(else (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"
"c" '((additional-versions ("0" "6"))
'(additional-versions . ("6")) (additiona-paths (".")))))
'(additional-search-paths . (".")))))) (else (pffi-define-library libc-stdlib
(list "stdlib.h")
"c"
'((additional-versions ("0" "6"))
(additiona-paths ("."))))))
#### Notes
#### pffi-shared-object-load <a name="pffi-shared-object-load"></a> - Do not cond-expand inside the arguments, that might lead to problems on some
implementations.
**pffi-shared-object-load** headers path [options] - Do pass the headers using quote
- As '(... and not (list...
It is recommended to use the pffi-shared-object-auto-load instead of this - Do pass the options using quote
directly. - As '(... and not (list...
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>
@ -440,8 +429,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!")
@ -454,8 +443,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))

2
include/libtest.h
View File

@ -13,3 +13,5 @@ int color_check_by_value(struct color color);
int test_check(struct test* test); int test_check(struct test* test);
int test_check_by_value(struct test test); int test_check_by_value(struct test test);
struct test* test_new(); struct test* test_new();
void takes_no_args();
int takes_no_args_returns_int();

73
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-define-library
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-define-library
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-define-library
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-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -139,28 +135,28 @@
(scheme char) (scheme char)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(only (gambit) c-declare c-lambda c-define)) (only (gambit) c-declare c-lambda c-define define-macro))
(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-define-library
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!
;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
)) ))
(gauche (gauche
@ -175,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-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -205,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-define-library
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -237,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-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -266,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-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -302,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-define-library
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -332,8 +323,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -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-define-library
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-define-library
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-define-library
;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
;pffi-pointer-allocate ;pffi-pointer-allocate
@ -456,8 +443,7 @@
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-define-library
pffi-shared-object-load
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
@ -486,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-define-library
;pffi-shared-object-load ;pffi-shared-object-load
;pffi-pointer-null ;pffi-pointer-null
;pffi-pointer-null? ;pffi-pointer-null?
@ -558,4 +544,5 @@
(ypsilon (include "pffi/ypsilon.scm"))) (ypsilon (include "pffi/ypsilon.scm")))
(include "pffi/shared/struct.scm") (include "pffi/shared/struct.scm")
(include "pffi/shared/union.scm") (include "pffi/shared/union.scm")
(include "pffi/shared/main.scm")) (include "pffi/shared/main.scm")
)

3
retropikzel/pffi/chibi.scm
View File

@ -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)))))

2
retropikzel/pffi/chicken5.scm
View File

@ -183,7 +183,7 @@
(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)
(let* ((headers (cdr (car (cdr expr))))) (let* ((headers (cadr (car (cdr expr)))))
`(begin `(begin
,@ (map ,@ (map
(lambda (header) (lambda (header)

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);"))

160
retropikzel/pffi/gambit.scm
View File

@ -1,9 +1,10 @@
(c-declare "#include <stdlib.h>")
(c-declare "#include <stdint.h>") (c-declare "#include <stdint.h>")
;(c-declare "int size_of_int8() { return sizeof(int8_t);}") (define-macro
;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));")) (pffi-init)
;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));"))) `(begin (c-define-type pointer (pointer void))
;(define int8-size (c-lambda () int "__return(1);")) (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));"))
@ -25,7 +26,6 @@
(define size-of-double (c-lambda () int "___return(sizeof(double));")) (define size-of-double (c-lambda () int "___return(sizeof(double));"))
(define size-of-void* (c-lambda () int "___return(sizeof(void*));")) (define size-of-void* (c-lambda () int "___return(sizeof(void*));"))
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) (size-of-int8_t)) (cond ((eq? type 'int8) (size-of-int8_t))
@ -47,13 +47,151 @@
((eq? type 'float) (size-of-float)) ((eq? type 'float) (size-of-float))
((eq? type 'double) (size-of-double)) ((eq? type 'double) (size-of-double))
((eq? type 'pointer) (size-of-void*)) ((eq? type 'pointer) (size-of-void*))
((eq? type 'callback) (size-of-void*))
((eq? type 'void) (size-of-void*))
(else (error "Can not get size of unknown type" type))))) (else (error "Can not get size of unknown type" type)))))
(define-macro (pffi-shared-object-load header) (define-macro
`(c-declare ,(string-append "#include <" header ">"))) (pffi-define-library name headers object-name . options)
`(begin (define ,name #t)
(c-declare ,(apply string-append
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(cdr headers))))))
#;(define-syntax pffi-shared-object-load (define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
(syntax-rules () (define pffi-pointer?
((_ headers) (lambda (object)
(c-declare "#include <stdint.h>")))) (call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x) #f)
(lambda () (pointer? object)))))))
(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);"))
(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }"))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(pointer-null? pointer))))
(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }"))
(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 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 pointer-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);"))
(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) (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-macro
(pffi-define scheme-name shared-object c-name return-type argument-types)
(letrec* ((native-argument-types
(if (equal? '(list) argument-types)
(list)
(let ((types (map cdr (cdr argument-types))))
(if (null? types) types (map car types)))))
(native-return-type (car (cdr return-type)))
(c-arguments (lambda (index argument-count result)
(if (> index argument-count)
result
(c-arguments (+ index 1)
argument-count
(string-append result
"___arg"
(number->string index)
(if (< index argument-count)
", "
""))))))
(c-code (string-append
(if (equal? 'void (cadr return-type)) "" "___return(")
(symbol->string (cadr c-name))
"(" (c-arguments 1 (- (length argument-types) 1) "") ")"
(if (equal? 'void (cadr return-type)) "" ")")
";")))
`(define ,scheme-name
(c-lambda ,native-argument-types
,native-return-type
,c-code))))

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)))

9
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)))
@ -108,11 +112,6 @@
(lambda (pointer) (lambda (pointer)
(pointer->string pointer))) (pointer->string pointer)))
;; FIXME
(define pffi-pointer-address
(lambda (pointer)
0))
(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)

8
retropikzel/pffi/racket.scm
View File

@ -79,11 +79,13 @@
(string-copy (cast pointer _pointer _string)))) (string-copy (cast pointer _pointer _string))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (header path . options) (lambda (header path options)
(write (cadr (assoc 'additional-versions options)))
(newline)
(if (and (not (null? options)) (if (and (not (null? options))
(assoc 'additional-versions (car options))) (assoc 'additional-versions options))
(ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
(car options))) options))
(list #f)))) (list #f))))
(ffi-lib path)))) (ffi-lib path))))

4
retropikzel/pffi/sagittarius.scm
View File

@ -32,7 +32,7 @@
(define-syntax pffi-define (define-syntax pffi-define
(syntax-rules () (syntax-rules ()
((pffi-define 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
(make-c-function shared-object (make-c-function shared-object
(pffi-type->native-type return-type) (pffi-type->native-type return-type)
@ -102,7 +102,7 @@
(pointer->string pointer))) (pointer->string pointer)))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (headers path . options) (lambda (headers path options)
(open-shared-library path))) (open-shared-library path)))
(define pffi-pointer-free (define pffi-pointer-free

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

@ -6,13 +6,8 @@
'(import (chicken foreign) '(import (chicken foreign)
(chicken memory)) (chicken memory))
#t)))) #t))))
#;(ypsilon (gambit #t)
(define-syntax pffi-init (else (define pffi-init (lambda () #t))))
(lambda (x)
(syntax-case x ()
((_) '(import (ypsilon c-ffi)))))))
(else
(define pffi-init(lambda () #t))))
(define pffi-type? (define pffi-type?
(lambda (object) (lambda (object)
@ -71,7 +66,6 @@
unsigned-long unsigned-long
float float
double double
string
pointer pointer
void)) void))
@ -93,146 +87,141 @@
res))) res)))
(cond-expand (cond-expand
(gambit (gambit #t)
(define-macro
(pffi-shared-object-auto-load headers object-name options)
`(pffi-shared-object-load ,(car headers))))
((or chicken cyclone) ((or chicken cyclone)
(define-syntax pffi-shared-object-auto-load (define-syntax pffi-define-library
(syntax-rules () (syntax-rules ()
((_ headers object-name . options) ((_ scheme-name headers object-name options)
(pffi-shared-object-load headers))))) (begin
(define scheme-name #t)
(pffi-shared-object-load headers))))))
(else (else
(define pffi-shared-object-auto-load (define-syntax pffi-define-library
(lambda (headers object-name . options) (syntax-rules ()
(let* ((additional-paths (if (assoc 'additional-paths options) ((_ scheme-name headers object-name options)
(cdr (assoc 'additional-paths options)) (define scheme-name
(list))) (let* ((internal-options (if (null? 'options)
(additional-versions (if (assoc 'additional-versions options) (list)
(map (lambda (version) (cadr 'options)))
(if (number? version) (additional-paths (if (assoc 'additional-paths internal-options)
(number->string version) (cadr (assoc 'additional-paths internal-options))
version))
(cdr (assoc 'additional-versions options)))
(list))) (list)))
(slash (cond-expand (windows (string #\\)) (else "/"))) (additional-versions (if (assoc 'additional-versions internal-options)
(auto-load-paths (map (lambda (version)
(cond-expand (if (number? version)
(windows (number->string version)
(append version))
(if (get-environment-variable "SYSTEM") (cadr (assoc 'additional-versions internal-options)))
(list (get-environment-variable "SYSTEM")) (list)))
(list)) (slash (cond-expand (windows (string #\\)) (else "/")))
(if (get-environment-variable "WINDIR") (auto-load-paths
(list (get-environment-variable "WINDIR")) (cond-expand
(list)) (windows
(if (get-environment-variable "WINEDLLDIR0") (append
(list (get-environment-variable "WINEDLLDIR0")) (if (get-environment-variable "SYSTEM")
(list)) (list (get-environment-variable "SYSTEM"))
(if (get-environment-variable "SystemRoot") (list))
(list (string-append (if (get-environment-variable "WINDIR")
(get-environment-variable "SystemRoot") (list (get-environment-variable "WINDIR"))
slash (list))
"system32")) (if (get-environment-variable "WINEDLLDIR0")
(list)) (list (get-environment-variable "WINEDLLDIR0"))
(list ".") (list))
(if (get-environment-variable "PATH") (if (get-environment-variable "SystemRoot")
(string-split (get-environment-variable "PATH") #\;) (list (string-append
(list)) (get-environment-variable "SystemRoot")
(if (get-environment-variable "PWD") slash
(list (get-environment-variable "PWD")) "system32"))
(list)))) (list))
(else (list ".")
(append (if (get-environment-variable "PATH")
; Guix (string-split (get-environment-variable "PATH") #\;)
(list (if (get-environment-variable "GUIX_ENVIRONMENT") (list))
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") (if (get-environment-variable "PWD")
"") (list (get-environment-variable "PWD"))
"/run/current-system/profile/lib") (list))))
; Debian (else
(if (get-environment-variable "LD_LIBRARY_PATH") (append
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) ; Guix
(list)) (list (if (get-environment-variable "GUIX_ENVIRONMENT")
(list (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
;;; x86-64 "")
; Debian "/run/current-system/profile/lib")
"/lib/x86_64-linux-gnu" ; Debian
"/usr/lib/x86_64-linux-gnu" (if (get-environment-variable "LD_LIBRARY_PATH")
"/usr/local/lib" (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
; Fedora/Alpine (list))
"/usr/lib" (list
"/usr/lib64" ;;; x86-64
;;; aarch64 ; Debian
; Debian "/lib/x86_64-linux-gnu"
"/lib/aarch64-linux-gnu" "/usr/lib/x86_64-linux-gnu"
"/usr/lib/aarch64-linux-gnu" "/usr/local/lib"
"/usr/local/lib" ; Fedora/Alpine
; Fedora/Alpine "/usr/lib"
"/usr/lib" "/usr/lib64"
"/usr/lib64" ;;; aarch64
; NetBSD ; Debian
"/usr/pkg/lib"))))) "/lib/aarch64-linux-gnu"
(auto-load-versions (list "")) "/usr/lib/aarch64-linux-gnu"
(paths (append auto-load-paths additional-paths)) "/usr/local/lib"
(versions (append additional-versions auto-load-versions)) ; Fedora/Alpine
(platform-lib-prefix "/usr/lib"
(cond-expand "/usr/lib64"
;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) ; NetBSD
(windows "") "/usr/pkg/lib")))))
(else "lib"))) (auto-load-versions (list ""))
(platform-file-extension (paths (append auto-load-paths additional-paths))
(cond-expand (versions (append additional-versions auto-load-versions))
;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) (platform-lib-prefix (cond-expand (windows "") (else "lib")))
(windows ".dll") (platform-file-extension (cond-expand (windows ".dll") (else ".so")))
(else ".so"))) (shared-object #f)
(shared-object #f) (searched-paths (list)))
(searched-paths (list))) (for-each
(for-each (lambda (path)
(lambda (path) (for-each
(for-each (lambda (version)
(lambda (version) (let ((library-path
(let ((library-path (string-append path
(string-append path slash
slash platform-lib-prefix
platform-lib-prefix object-name
object-name (cond-expand
(cond-expand (windows "")
(windows "") (else platform-file-extension))
(else platform-file-extension)) (if (string=? version "")
(if (string=? version "") ""
"" (string-append
(string-append (cond-expand (windows "-")
(cond-expand (windows "-") (else "."))
(else ".")) version))
version)) (cond-expand
(cond-expand (windows platform-file-extension)
(windows platform-file-extension) (else ""))))
(else "")))) (library-path-without-suffixes (string-append path
(library-path-without-suffixes (string-append path slash
slash platform-lib-prefix
platform-lib-prefix object-name)))
object-name))) (set! searched-paths (append searched-paths (list library-path)))
(set! searched-paths (append searched-paths (list library-path))) (when (and (not shared-object)
(when (and (not shared-object) (file-exists? library-path))
(file-exists? library-path)) (set! shared-object
(set! shared-object (cond-expand (racket library-path-without-suffixes)
(cond-expand (racket library-path-without-suffixes) (else library-path))))))
(else library-path)))))) versions))
versions)) paths)
paths) (if (not shared-object)
(if (not shared-object) (begin
(begin (display "Could not load shared object: ")
(display "Could not load shared object: ") (write (list (cons 'object object-name)
(write (list (cons 'object object-name) (cons 'paths paths)
(cons 'paths paths) (cons 'platform-file-extension platform-file-extension)
(cons 'platform-file-extension platform-file-extension) (cons 'versions versions)))
(cons 'versions versions))) (newline)
(newline) (display "Searched paths: ")
(display "Searched paths: ") (write searched-paths)
(write searched-paths) (newline)
(newline) (exit 1))
(exit 1)) (pffi-shared-object-load headers
(pffi-shared-object-load headers shared-object
shared-object `((additional-versions ,additional-versions)))))))))))
`((additional-versions ,versions)))))))))

11
src/chibi/pffi.stub
View File

@ -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);
}") }")

44
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) {
@ -265,3 +273,11 @@ EXPORT struct test* test_new() {
t->n = 14; t->n = 14;
return t; return t;
} }
EXPORT void takes_no_args() {
puts("I take no arguments :)");
}
EXPORT int takes_no_args_returns_int() {
return 0;
}

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

@ -30,21 +30,38 @@
(set! assert-tag tag) (set! assert-tag tag)
(set! count 0))) (set! count 0)))
(define-syntax assert (cond-expand
(syntax-rules () (gambit
((_ check value-a value-b) (define assert
(let ((result (apply check (list value-a value-b)))) (lambda (check value-a value-b)
(set! count (+ count 1)) (let ((result (apply check (list value-a value-b))))
(if (not result) (display "FAIL ") (display "PASS ")) (set! count (+ count 1))
(display "[") (if (not result) (display "FAIL ") (display "PASS "))
(display assert-tag) (display "[")
(display " - ") (display assert-tag)
(display count) (display " - ")
(display "]") (display count)
(display ": ") (display "]")
(write (list 'check 'value-a 'value-b)) (display ": ")
(newline) (write (list 'check 'value-a 'value-b))
(when (not result) (exit 1)))))) (newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))))
(define-syntax debug (define-syntax debug
(syntax-rules () (syntax-rules ()
@ -101,8 +118,6 @@
(assert equal? (pffi-type? 'float) #t) (assert equal? (pffi-type? 'float) #t)
(debug (pffi-type? 'double)) (debug (pffi-type? 'double))
(assert equal? (pffi-type? 'double) #t) (assert equal? (pffi-type? 'double) #t)
(debug (pffi-type? 'string))
(assert equal? (pffi-type? 'string) #t)
(debug (pffi-type? 'pointer)) (debug (pffi-type? 'pointer))
(assert equal? (pffi-type? 'pointer) #t) (assert equal? (pffi-type? 'pointer) #t)
(debug (pffi-type? 'void)) (debug (pffi-type? 'void))
@ -110,8 +125,6 @@
(debug (pffi-type? 'callback)) (debug (pffi-type? 'callback))
(assert equal? (pffi-type? 'callback) #t) (assert equal? (pffi-type? 'callback) #t)
(pffi-init)
;; pffi-size-of ;; pffi-size-of
(print-header 'pffi-size-of) (print-header 'pffi-size-of)
@ -388,27 +401,38 @@
(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-define-library
(print-header 'pffi-shared-object-auto-load) (print-header 'pffi-define-library)
(define libc-stdlib (cond-expand
(cond-expand (windows (pffi-define-library libc-stdlib
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) '("stdlib.h")
(else (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"
"c" '((additional-versions ("0" "6")))))
'(additional-versions . ("0" "6")))))) (else (pffi-define-library libc-stdlib
'("stdlib.h")
"c"
'((additional-versions ("0" "6"))))))
(debug libc-stdlib) (debug libc-stdlib)
(define c-testlib (cond-expand
(cond-expand (windows (pffi-define-library libc-stdio
(windows (pffi-shared-object-auto-load (list "libtest.h") '("stdio.h")
"test" "ucrtbase"
'(additional-paths . (".")))) '((additional-versions ("0" "6")))))
(else (pffi-shared-object-auto-load (list "libtest.h") (else (pffi-define-library libc-stdio
"test" '("stdio.h")
'(additional-paths . (".")))))) "c"
'((additional-versions ("0" "6"))))))
(debug libc-stdio)
(pffi-define-library c-testlib
'("libtest.h")
"test"
'((additional-paths ("." "./tests"))))
(debug c-testlib) (debug c-testlib)
@ -484,12 +508,20 @@
(debug offset) (debug offset)
(debug value) (debug value)
(define-syntax test-type (cond-expand
(syntax-rules () (gambit
((_ type) (define test-type
(begin (lambda (type)
(pffi-pointer-set! set-pointer type offset value) (begin
(assert = (pffi-pointer-get set-pointer type offset) value))))) (pffi-pointer-set! set-pointer type offset value)
(assert = (pffi-pointer-get set-pointer type offset) value)))))
(else
(define-syntax test-type
(syntax-rules ()
((_ type)
(begin
(pffi-pointer-set! set-pointer type offset value)
(assert = (pffi-pointer-get set-pointer type offset) value)))))))
(test-type 'int8) (test-type 'int8)
(test-type 'uint8) (test-type 'uint8)
@ -663,14 +695,6 @@
(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer)) (pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (c-atoi (pffi-string->pointer "100")) 100) (assert = (c-atoi (pffi-string->pointer "100")) 100)
(define libc-stdio
(cond-expand
; FIXME Check that windows so file is correct
(windows (pffi-shared-object-auto-load (list "stdio.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdio.h")
"c"
'(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")
(pffi-string->pointer "w"))) (pffi-string->pointer "w")))
@ -689,6 +713,15 @@
(lambda () (read-line))) (lambda () (read-line)))
"Hello world") #t) "Hello world") #t)
(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void (list))
(debug c-takes-no-args)
(c-takes-no-args)
(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list))
(debug c-takes-no-args)
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t)
;; pffi-struct-get ;; pffi-struct-get
(print-header 'pffi-struct-get) (print-header 'pffi-struct-get)