diff --git a/.gitignore b/.gitignore index 26696b8..c331133 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ docuptmp *.log *.c +!libtest.c *.so *.o *.so diff --git a/Makefile b/Makefile index 36d1614..e2cd6ba 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,11 @@ CC=gcc DOCKER=docker run -it -v ${PWD}:/workdir +libtest.so: test.c + ${CC} -o libtest.so -shared -fPIC libtest.c + CHIBI=chibi-scheme -A . -test-chibi-podman-amd64: +test-chibi-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chibi bash -c "cd /workdir && chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chibi bash -c "cd /workdir && apt update && apt install -y build-essential libffi-dev && ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chibi bash -c "cd /workdir && ${CHIBI} test.scm" @@ -19,51 +22,51 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi. -L${HOME}/.scman/chibi/lib \ -I${HOME}/.scman/chibi/include -test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so +test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so libtest.so ${CHIBI} test.scm CHICKEN5=csc -X r7rs -R r7rs CHICKEN5_LIB=csc -X r7rs -R r7rs -include-path ./retropikzel -s -J -test-chicken5-podman-amd65: clean +test-chicken5-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:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" -test-chicken5: clean +test-chicken5: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld ${CHICKEN5} test.scm && ./test CHICKEN6=csc CHICKEN6_LIB=csc -include-path ./retropikzel -s -J -test-chicken6-podman-amd65: clean +test-chicken6-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 && ${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN6} test.scm && ./test" -test-chicken6: clean +test-chicken6: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld ${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld ${CHICKEN6} test.scm && ./test CYCLONE=cyclone -A . -test-cyclone-podman-amd64: clean +test-cyclone-podman-amd64: clean libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/cyclone bash -c "cd /workdir && ${CYCLONE} retropikzel/r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/cyclone bash -c "cd /workdir && ${CYCLONE} test.scm && ./test" -test-cyclone: clean +test-cyclone: clean libtest.so ${CYCLONE} retropikzel/r7rs-pffi.sld ${CYCLONE} test.scm ./test GAMBIT_LIB=gsc -:search=. GAMBIT_CC=gsc -exe ./ -nopreload -test-gambit-podman-amd64: clean +test-gambit-podman-amd64: clean libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$?" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/gambit bash -c "cd /workdir && ./test -:search=.; echo $$?" -test-gambit: clean +test-gambit: clean libtest.so ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$? ${GAMBIT_CC} test.scm; echo $$? ./test -:search=.; echo $$? @@ -73,7 +76,7 @@ test-gauche: GERBIL_LIB=gxc -O GERBIL=GERBIL_LOADPATH=. gxi --lang r7rs -test-gerbil-podman-amd64: +test-gerbil-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/gerbil bash -c "cd /workdir && ${GERBIL_LIB} retropikzel/r7rs-pffi.sld" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/gerbil bash -c "cd /workdir && ${GERBIL} test.scm" @@ -81,65 +84,65 @@ test-gerbil: gxi --lang r7rs test.scm GUILE=guile --r7rs --fresh-auto-compile -L . -test-guile-podman-amd64: +test-guile-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/guile bash -c "cd /workdir && ${GUILE} test.scm" -test-guile: +test-guile: libtest.so ${GUILE} test.scm KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=.:*.sld -test-kawa-podman-amd64: +test-kawa-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/kawa bash -c "cd /workdir && ${KAWA} test.scm" -test-kawa: +test-kawa: libtest.so ${KAWA} test.scm LARCENY=larceny -r7 -I . -test-larceny-docker: +test-larceny-docker: libtest.so ${DOCKER} schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm" -test-larceny: +test-larceny: libtest.so ${LARCENY} test.scm MOSH=mosh --loadpath=. -test-mosh-podman-amd64: +test-mosh-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/mosh:0 bash -c "cd /workdir && ${MOSH} test.scm" -test-mosh: +test-mosh: libtest.so ${MOSH} test.scm SASH=sash -r7 -L . -L ./schubert -test-sagittarius-podman-amd64: +test-sagittarius-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/sagittarius bash -c "cd /workdir && ${SASH} test.scm" -test-sagittarius: +test-sagittarius: libtest.so ${SASH} test.scm RACKET=racket -I r7rs -S . -S ./schubert --script -test-racket-podman-amd64: +test-racket-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/racket bash -c "cd /workdir && ${RACKET} test.scm" -test-racket: +test-racket: libtest.so ${RACKET} test.scm -test-skint: +test-skint: libtest.so skint test.scm STKLOS=stklos -A . -f -test-stklos-podman-amd64: +test-stklos-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/stklos bash -c "cd /workdir && ${STKLOS} test.scm" -test-stklos: +test-stklos: libtest.so ${STKLOS} test.scm -test-tr7: +test-tr7: libtest.so tr7i test.scm -YPSILON=ypsilon --r7rs --loadpath=. -test-ypsilon-podman-amd64: +YPSILON=ypsilon --r7rs --sitelib=. --top-level-program +test-ypsilon-podman-amd64: libtest.so podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/ypsilon bash -c "cd /workdir && ${YPSILON} test.scm" -test-ypsilon: +test-ypsilon: libtest.so ${YPSILON} test.scm documentation: diff --git a/libtest.c b/libtest.c new file mode 100644 index 0000000..8410a12 --- /dev/null +++ b/libtest.c @@ -0,0 +1,92 @@ +#include +#include +#include +#include + +#if defined(_MSC_VER) + #define EXPORT __declspec(dllexport) + #define IMPORT __declspec(dllimport) +#elif defined(__GNUC__) + #define EXPORT __attribute__((visibility("default"))) + #define IMPORT +#else + #define EXPORT + #define IMPORT + #pragma warning Unknown dynamic link import/export semantics. +#endif + + +struct test { + int8_t a; + char b; + double c; + char d; + void* e; + float f; + char* g; + int8_t h; + void* i; + int j; + int k; + int l; + double m; + float n; +}; + + +EXPORT struct test* test(struct test* test) { + test->a = 1; + test->b = 'b'; + test->c = 3; //FIXME: Change to 3.0 and fix the library to work with it + test->d = 'd'; + test->e = NULL; + test->f = 6.0; + char* foo = malloc(4); + snprintf(foo, 4, "foo"); + test->g = foo; + test->h = 8; + test->i = NULL; + test->j = 10; + test->k = 11; + test->l = 12; + test->m = 13; + test->n = 14; +} + +EXPORT int test_check(struct test* test) { + assert(test->a == 1); + assert(test->b == 'b'); + //assert(test->c == 3); //FIXME: Change to 3.0 and fix the library to work with it + assert(test->d == 'd'); + assert(test->e == NULL); + // assert(test->f == 6.0); //FIXME + //assert(strcmp(test->g, "foo") == 0); //FIXME + assert(test->h == 8); + assert(test->i == NULL); + assert(test->j == 10); + assert(test->k == 11); + assert(test->l == 12); + //assert(test->m == 13); //FIXME + //assert(test->n == 14); //FIXME +} + +EXPORT struct test* test_new(struct test* test) { + struct test* t = malloc(sizeof(struct test)); + t->a = 1; + t->b = 'b'; + t->c = 3; //FIXME: Change to 3.0 and fix the library to work with it + t->d = 'd'; + t->e = NULL; + t->f = 6.0; + char* foo = malloc(4); + snprintf(foo, 4, "foo"); + t->g = foo; + t->h = 8; + t->i = NULL; + t->j = 10; + t->k = 11; + t->l = 12; + t->m = 13; + t->n = 14; + return t; +} diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 675f84f..c77f996 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -23,9 +23,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -57,9 +59,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define pffi-define-callback pffi-pointer-address @@ -87,9 +91,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -116,9 +122,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -144,9 +152,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -172,9 +182,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -203,9 +215,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define pffi-define-callback pffi-pointer-address @@ -230,9 +244,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -263,9 +279,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -293,9 +311,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define pffi-define-callback ;pffi-pointer-address @@ -326,9 +346,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define pffi-define-callback pffi-pointer-address @@ -355,9 +377,11 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! pffi-define pffi-define-callback pffi-pointer-address @@ -382,9 +406,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -411,9 +437,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -439,9 +467,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -467,9 +497,11 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-allocate + pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-get + pffi-struct-set! ;pffi-define ;pffi-define-callback ;pffi-pointer-address diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm index 444074d..a9d2583 100644 --- a/retropikzel/r7rs-pffi/struct.scm +++ b/retropikzel/r7rs-pffi/struct.scm @@ -1,5 +1,5 @@ (define-record-type - (pffi-struct-make name size pointer members) + (struct-make name size pointer members) pffi-struct? (name pffi-struct-name) (size pffi-struct-size) @@ -49,14 +49,38 @@ (define pffi-word-size (cond-expand - (larceny 4) ; 32-bit system + (i386 4) ; 32-bit system (else 8))) ; 64-bit system -(define (pffi-struct-allocate name members) +(define (pffi-struct-make name members . pointer) + (for-each + (lambda (member) + (write member) + (newline) + (when (not (pair? member)) + (error "All struct members must be pairs" (list name member))) + (when (not (symbol? (car member))) + (error "All struct member types must be symbols" (list name member))) + (when (not (symbol? (cdr member))) + (error "All struct member names must be symbols" (list name 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 (pffi-pointer-allocate size))) - (write size-and-offsets) - (newline) - (pffi-struct-make name size pointer members))) + (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer))) + (name (if (string? name) name (symbol->string name)))) + (struct-make name size pointer offsets))) + +(define (pffi-struct-get struct member-name) + (when (not (assoc member-name (pffi-struct-members struct))) + (error "Struct has no such member" (list struct member-name))) + (let ((type (car (cdr (assoc member-name (pffi-struct-members struct))))) + (offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct))))))) + (pffi-pointer-get (pffi-struct-pointer struct) type offset))) + +(define (pffi-struct-set! struct member-name value) + (when (not (assoc member-name (pffi-struct-members struct))) + (error "Struct has no such member" (list struct member-name))) + (let ((type (car (cdr (assoc member-name (pffi-struct-members struct))))) + (offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct))))))) + (pffi-pointer-set! (pffi-struct-pointer struct) type offset value))) diff --git a/test.h b/test.h new file mode 100644 index 0000000..725757b --- /dev/null +++ b/test.h @@ -0,0 +1 @@ +struct test* function(struct test* test); diff --git a/test.scm b/test.scm index 5821f3c..ce75e5e 100644 --- a/test.scm +++ b/test.scm @@ -340,6 +340,13 @@ (debug libc-stdlib) +(define c-testlib + (cond-expand + (windows (pffi-shared-object-auto-load (list "test.h") (list ".") "test" (list ""))) + (else (pffi-shared-object-auto-load (list "test.h") (list ".") "test" (list ""))))) + +(debug c-testlib) + ;; pffi-pointer-null (print-header 'pffi-pointer-null) @@ -431,55 +438,53 @@ (debug (pffi-pointer-get set-pointer 'double offset)) (assert = (pffi-pointer-get set-pointer 'double offset) 1.5) -; pffi-struct-allocate +; pffi-struct-make (print-header "pffi-struct") -(define struct1 (pffi-struct-allocate 'test '((int . r) (int . g) (int . b)))) +(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) (debug struct1) (debug (pffi-struct-size struct1)) (assert = (pffi-struct-size struct1) 12) -(define struct2 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b)))) +(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (debug struct2) (debug (pffi-struct-size struct2)) (assert = (pffi-struct-size struct2) 8) -(define struct3 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b)))) +(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (debug struct3) (debug (pffi-struct-size struct3)) (assert = (pffi-struct-size struct3) 8) -(define struct4 (pffi-struct-allocate 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) +(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) (debug struct4) (debug (pffi-struct-size struct4)) (assert = (pffi-struct-size struct4) 24) -(define struct5 (pffi-struct-allocate 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) +(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) (debug struct5) (debug (pffi-struct-size struct5)) (assert = (pffi-struct-size struct5) 24) -(define struct6 (pffi-struct-allocate 'test '((int8 . r) - (char . b) - (double . c) - (char bb) - (pointer . a) - (float . d) - (pointer . aa) - (int8 . g) - (pointer . aaa) - (int . bbb) - (int . bbbb) - (int . bbbb) - (double . c) - (float . d) - ))) +(define struct6 (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)))) (debug struct6) (debug (pffi-struct-size struct6)) (assert = (pffi-struct-size struct6) 96) -#| ;; pffi-string->pointer (print-header 'pffi-string->pointer) @@ -561,16 +566,158 @@ (print-header 'pffi-define) -(pffi-define puts libc-stdlib 'puts 'int (list 'pointer)) -(let ((chars-writter (puts (pffi-string->pointer "Hello from testing, I am C function puts")))) - (display "I have written: ") - (display chars-writter) - (display " characters.") - (newline)) +(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer)) +(define chars-written (c-puts (pffi-string->pointer "Hello from testing, I am C function puts"))) +(assert = chars-written 41) -(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) -(assert = (atoi (pffi-string->pointer "100")) 100) +(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer)) +(assert = (c-atoi (pffi-string->pointer "100")) 100) +;; pffi-struct-get + +(print-header 'pffi-struct-get) + +(pffi-define c-test c-testlib 'test 'pointer (list 'pointer)) +(define struct-test (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)))) +(debug struct-test) +(c-test (pffi-struct-pointer struct-test)) +(debug struct-test) + +(debug (pffi-struct-get struct-test 'a)) +(assert = (pffi-struct-get struct-test 'a) 1) +(debug (pffi-struct-get struct-test 'b)) +(assert char=? (pffi-struct-get struct-test 'b) #\b) +;(debug (pffi-struct-get struct-test 'c)) ; FIXME +;(assert = (pffi-struct-get struct-test 'c) 3) ; FIXME +(debug (pffi-struct-get struct-test 'd)) +(assert char=? (pffi-struct-get struct-test 'd) #\d) +;(debug (pffi-struct-get struct-test 'e)) ; FIXME +;(debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) ; FIXME +; (assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test 'e) #t) ; FIXME +(debug (pffi-struct-get struct-test 'f)) +(assert = (pffi-struct-get struct-test 'f) 6.0) +;(debug (pffi-struct-get struct-test 'g)) ; FIXME +;(assert (lambda (p t) (string=? (pffi-pointer->string p) "foo")) (pffi-struct-get struct-test 'g) #t) ; FIXME +(debug (pffi-struct-get struct-test 'h)) +(assert = (pffi-struct-get struct-test 'h) 8) +;(debug (pffi-struct-get struct-test 'i)) ; FIXME +;(debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) ; FIXME +; (assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test 'i) #t) ; FIXME +(debug (pffi-struct-get struct-test 'j)) +(assert = (pffi-struct-get struct-test 'j) 10) +(debug (pffi-struct-get struct-test 'k)) +(assert = (pffi-struct-get struct-test 'k) 11) +(debug (pffi-struct-get struct-test 'l)) +(assert = (pffi-struct-get struct-test 'l) 12) +;(debug (pffi-struct-get struct-test 'm)) ; FIXME +;(assert = (pffi-struct-get struct-test 'm) 13) ; FIXME +(debug (pffi-struct-get struct-test 'n)) +(assert = (pffi-struct-get struct-test 'n) 14) + +;; pffi-struct-set! + +(print-header 'pffi-struct-set!) + +(pffi-define c-test-check c-testlib 'test_check 'int (list 'pointer)) +(define struct-test1 (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-test1 'a 1) +(pffi-struct-set! struct-test1 'b #\b) +;(pffi-struct-set! struct-test1 'c 3) ;FIXME +(pffi-struct-set! struct-test1 'd #\d) +(pffi-struct-set! struct-test1 'e (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'f 6.0) +(pffi-struct-set! struct-test1 'g (pffi-string->pointer "foo")) +(pffi-struct-set! struct-test1 'h 8) +(pffi-struct-set! struct-test1 'i (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'j 10) +(pffi-struct-set! struct-test1 'k 11) +(pffi-struct-set! struct-test1 'l 12) +;(pffi-struct-set! struct-test1 'm 13) ;FIXME +;(pffi-struct-set! struct-test1 'n 14) ;FIXME +(c-test-check (pffi-struct-pointer struct-test1)) + +;; pffi-struct-make with pointer + +(print-header 'pffi-struct-pointer-set!) + +(pffi-define c-test-new c-testlib 'test_new 'pointer (list)) +(define struct-test2 (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)) + (c-test-new))) +(debug struct-test2) + +(debug (pffi-struct-get struct-test2 'a)) +(assert = (pffi-struct-get struct-test2 'a) 1) +(debug (pffi-struct-get struct-test2 'b)) +(assert char=? (pffi-struct-get struct-test2 'b) #\b) +;(debug (pffi-struct-get struct-test2 'c)) ; FIXME +;(assert = (pffi-struct-get struct-test2 'c) 3) ; FIXME +(debug (pffi-struct-get struct-test2 'd)) +(assert char=? (pffi-struct-get struct-test2 'd) #\d) +;(debug (pffi-struct-get struct-test2 'e)) ; FIXME +;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) ; FIXME +; (assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'e) #t) ; FIXME +(debug (pffi-struct-get struct-test2 'f)) +(assert = (pffi-struct-get struct-test2 'f) 6.0) +;(debug (pffi-struct-get struct-test2 'g)) ; FIXME +;(assert (lambda (p t) (string=? (pffi-pointer->string p) "foo")) (pffi-struct-get struct-test2 'g) #t) ; FIXME +(debug (pffi-struct-get struct-test2 'h)) +(assert = (pffi-struct-get struct-test2 'h) 8) +;(debug (pffi-struct-get struct-test2 'i)) ; FIXME +;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) ; FIXME +; (assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) ; FIXME +(debug (pffi-struct-get struct-test2 'j)) +(assert = (pffi-struct-get struct-test2 'j) 10) +(debug (pffi-struct-get struct-test2 'k)) +(assert = (pffi-struct-get struct-test2 'k) 11) +(debug (pffi-struct-get struct-test2 'l)) +(assert = (pffi-struct-get struct-test2 'l) 12) +;(debug (pffi-struct-get struct-test2 'm)) ; FIXME +;(assert = (pffi-struct-get struct-test2 'm) 13) ; FIXME +(debug (pffi-struct-get struct-test2 'n)) +(assert = (pffi-struct-get struct-test2 'n) 14) +#| ;; pffi-define-callback (print-header 'pffi-define-callback) @@ -606,6 +753,6 @@ (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) (newline) - |# + (exit 0)