diff --git a/Makefile b/Makefile index efbcf8b..a2e41ab 100644 --- a/Makefile +++ b/Makefile @@ -32,39 +32,30 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi. test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so libtest.so ${CHIBI} test.scm -CHICKEN5=SCMC=csc CSCFLAGS='-I. -L. -L -ltest' compile-r7rs -I . main.scm -#CHICKEN5=csc -X r7rs -R r7rs -uses scheme.base -I. -#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -I. -include-path ./retropikzel -s -J -#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -unit retropikzel.r7rs-pffi -include-path ./retropikzel -s -J -test-chicken5-podman-amd65: clean libtest.a - #cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - #podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" +CHICKEN5=SCMC=csc CSC_FLAGS='-I. -L. -L -ltest' compile-r7rs -I . main.scm +test-chicken-5-podman-amd65: clean libtest.a podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" -test-chicken5-docker: clean libtest.a - #cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - #docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" +test-chicken-5-docker: clean libtest.a ${DOCKER} schemers/chicken:5 bash -c "${DOCKER_INIT} && cd /workdir && ${CHICKEN5} test.scm && ./test" -test-chicken5: clean libtest.a - #cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - #${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld +test-chicken-5: clean libtest.a ${CHICKEN5} test.scm ./test CHICKEN6=csc -I. CHICKEN6_LIB=csc -I. -include-path ./retropikzel -s -J -test-chicken6-podman-amd65: clean libtest.so +test-chicken-6-podman-amd65: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" -test-chicken6-docker: clean libtest.so +test-chicken-6-docker: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" -test-chicken6: clean libtest.so +test-chicken-6: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld ${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld ${CHICKEN6} test.scm && ./test diff --git a/README.md b/README.md index 1adf4e5..ba89fd0 100644 --- a/README.md +++ b/README.md @@ -68,56 +68,33 @@ guarantees are being made just yet. Due to supporting many different Scheme implementations, different parts of this software are in different stage. As a whole it is still in **alpha** stage. That said the interface should not be -changing anymore and support for some implementations are in **beta**. - -## Implementation status - -### Alpha - -Anything not in beta or done, not recommended to use. - -### Beta - -Usage can be started but might still be quite buggy. - -- Guile -- Sagittarius -- Racket - -### Done - -Usage recommended. - -- None yet +changing anymore and some implementations are in **beta**. ## Implementation table -| | Chibi | Chicken 5 | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon | -| ------------------------------- | ----- | --------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- | -| pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | | -| pffi-size-of | X | X | X | X | | | X | X | | X | X | X | | X | | | -| pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | | -| pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-pointer->string | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-struct-make | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-size | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-pointer | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-offset-get | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-get | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-set! | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| pffi-struct-dereference | | X | | | | | X | | | X | X | X | | | | | -| pffi-define | X | X | X | | | | X | X | | X | X | X | | | | | -| pffi-define-callback | | X | | | | | X | | | X | X | X | | | | | +### Beta -## Other implementations +| | 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? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-size | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-struct-dereference | pffi-define | pffi-define-callback | +| Guile | X | 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 | X | X | +| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | + +### Alpha + +| 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 | X | +| Cyclone | X | X | 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 | | | | +| Gauche | X | | | | | | | | | | | | | X | X | X | X | X | X | | | | +| Gerbil | X | | | | | | | | | | | | | X | X | X | X | X | X | | | | +| Larceny | 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 | X | X | X | +| Skint | X | | | | | | | | | | | | | X | X | X | X | X | X | | | | +| Stklos | X | X | X | X | X | X | X | X | X | | | | | X | X | X | X | X | X | | | | +| tr7 | | | | | | | | | | | | | | X | X | X | X | X | X | | | | +| Ypsilon | | | | | | | | | | | | | | X | X | X | X | X | X | | | | + +### Not started - [LIPS](https://lips.js.org/) - Will work on nodejs by using some C FFI library from npm @@ -127,8 +104,6 @@ Usage recommended. - Javascript side needs design - [MIT-Scheme](https://www.gnu.org/software/mit-scheme/) - Need to study the implementation more -- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html) - - Propably does not need FFI? - [Airship](https://gitlab.com/mbabich/airship-scheme) - Need to study the implementation more - [Other gambit targets](https://gambitscheme.org/) @@ -139,6 +114,11 @@ Usage recommended. - Need to study the implementation more - [prescheme](https://codeberg.org/prescheme/prescheme) - Need to study the implementation more + +### Other + +- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html) + - Propably does not need FFI as it is embeddable only - [Loko](https://scheme.fail/) - Desires no C interop, I can respect that @@ -297,12 +277,15 @@ Makes pointer out of a given string. Makes string out of a given pointer. -##### **pffi-struct-make** name members . pointer -> pffi-struct +##### **pffi-struct-make** c-type members . pointer -> pffi-struct Creates a new pffi-struct and allocates pointer for it. The members argument is a list of member names and types. For example: - (define s (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) + (define color (pffi-struct-make 'color '((int8 . r) (int8 . g) (int8 . b) (int8 .a )))) + (define test (pffi-struct-make "struct test" '((int8 . r) (int8 . g) (int8 . b) (int8 .a )))) + +C-type argument can be symbol or a string. ##### **pffi-struct-size** pffi-struct -> number diff --git a/libtest.c b/libtest.c index 9d0f2f6..a05debc 100644 --- a/libtest.c +++ b/libtest.c @@ -182,6 +182,38 @@ EXPORT int test_check(struct test* test) { assert(test->n == 14); } +EXPORT int test_check_by_value(struct test test) { + print_offsets(); + printf("C: Value of a is %c\n", test.a); + assert(test.a == 1); + printf("C: Value of b is %c\n", test.b); + assert(test.b == 'b'); + printf("C: Value of c is %lf\n", test.c); + assert(test.c == 3.0); + printf("C: Value of d is %c\n", test.d); + assert(test.d == 'd'); + printf("C: Value of e is %s\n", test.e); + assert(test.e == NULL); + printf("C: Value of f is %f\n", test.f); + assert(test.f == 6.0); + printf("C: Value of g is %f\n", test.g); + assert(strcmp(test.g, "foo") == 0); + printf("C: Value of g is %i\n", test.h); + assert(test.h == 8); + printf("C: Value of i is %s\n", test.i); + assert(test.i == NULL); + printf("C: Value of j is %i\n", test.j); + assert(test.j == 10); + printf("C: Value of k is %i\n", test.k); + assert(test.k == 11); + printf("C: Value of l is %i\n", test.l); + assert(test.l == 12); + printf("C: Value of m is %i\n", test.m); + assert(test.m == 13); + printf("C: Value of n is %i\n", test.n); + assert(test.n == 14); +} + EXPORT struct test* test_new() { print_offsets(); struct test* t = malloc(sizeof(struct test)); diff --git a/libtest.h b/libtest.h index bb1042b..ec77554 100644 --- a/libtest.h +++ b/libtest.h @@ -3,4 +3,5 @@ void print_offsets(); void check_offset(int member_index, int offset); struct test* init_struct(struct test* test); int test_check(struct test* test); +int test_check_by_value(struct test test); struct test* test_new(); diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm index ae9cb73..96725b5 100644 --- a/retropikzel/r7rs-pffi/struct.scm +++ b/retropikzel/r7rs-pffi/struct.scm @@ -1,8 +1,8 @@ (define-record-type - (struct-make name size pointer members) + (struct-make c-type size pointer members) pffi-struct? - (name pffi-struct-name) + (c-type pffi-struct-c-type) (size pffi-struct-size) (pointer pffi-struct-pointer) (members pffi-struct-members)) @@ -48,22 +48,22 @@ (cons 'offsets offsets)))) (define pffi-struct-make - (lambda (name members . pointer) + (lambda (c-type members . pointer) (for-each (lambda (member) (when (not (pair? member)) - (error "All struct members must be pairs" (list name member))) + (error "All struct members must be pairs" (list c-type member))) (when (not (symbol? (car member))) - (error "All struct member types must be symbols" (list name member))) + (error "All struct member types must be symbols" (list c-type member))) (when (not (symbol? (cdr member))) - (error "All struct member names must be symbols" (list name member)))) + (error "All struct member names must be symbols" (list c-type member)))) members) (let* ((size-and-offsets (calculate-struct-size-and-offsets members)) (size (cdr (assoc 'size size-and-offsets))) (offsets (cdr (assoc 'offsets size-and-offsets))) (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer))) - (name (if (string? name) name (symbol->string name)))) - (struct-make name size pointer offsets)))) + (c-typr (if (string? c-type) c-type (symbol->string c-type)))) + (struct-make c-type size pointer offsets)))) (define (pffi-struct-offset-get struct member-name) (when (not (assoc member-name (pffi-struct-members struct))) diff --git a/test.scm b/test.scm index 72f3c14..a350438 100755 --- a/test.scm +++ b/test.scm @@ -781,4 +781,45 @@ (debug sorted) (assert equal? sorted (list 1 2 3)) +;; pffi-struct-dereference + +(print-header 'pffi-struct-dereference) + + +;; pffi-struct-set! + +(print-header 'pffi-struct-set!) + +(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct)) +(define struct-test3 (pffi-struct-make 'test + '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)))) +(pffi-struct-set! struct-test3 'a 1) +(pffi-struct-set! struct-test3 'b #\b) +(pffi-struct-set! struct-test3 'c 3.0) +(pffi-struct-set! struct-test3 'd #\d) +(pffi-struct-set! struct-test3 'e (pffi-pointer-null)) +(pffi-struct-set! struct-test3 'f 6.0) +(pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo")) +(pffi-struct-set! struct-test3 'h 8) +(pffi-struct-set! struct-test3 'i (pffi-pointer-null)) +(pffi-struct-set! struct-test3 'j 10) +(pffi-struct-set! struct-test3 'k 11) +(pffi-struct-set! struct-test3 'l 12) +(pffi-struct-set! struct-test3 'm 13.0) +(pffi-struct-set! struct-test3 'n 14.0) +(c-test-check-by-value (pffi-struct-dereference struct-test3)) + (exit 0)