From a6f9de2e6b2d8efd5599e7613b928be6483c65c5 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 2 Mar 2025 14:28:08 +0200 Subject: [PATCH] Cleaning up --- .gitignore | 7 +- Makefile | 183 +--- README.md | 38 +- libtest.c | 267 ----- libtest.h | 9 - retropikzel/pffi.sld | 106 +- retropikzel/{r7rs-pffi => pffi}/chibi.scm | 10 - retropikzel/{r7rs-pffi => pffi}/chicken5.scm | 0 retropikzel/{r7rs-pffi => pffi}/chicken6.scm | 0 retropikzel/{r7rs-pffi => pffi}/cyclone.scm | 0 retropikzel/{r7rs-pffi => pffi}/gambit.scm | 0 retropikzel/pffi/gauche.scm | 7 + retropikzel/{r7rs-pffi => pffi}/gerbil.scm | 0 retropikzel/{r7rs-pffi => pffi}/guile.scm | 0 retropikzel/{r7rs-pffi => pffi}/kawa.scm | 0 retropikzel/{r7rs-pffi => pffi}/larceny.scm | 0 retropikzel/{r7rs-pffi => pffi}/main.scm | 6 +- retropikzel/{r7rs-pffi => pffi}/mosh.scm | 0 retropikzel/{r7rs-pffi => pffi}/racket.scm | 0 .../{r7rs-pffi => pffi}/sagittarius.scm | 4 - retropikzel/pffi/shared/main.scm | 206 ++++ .../{r7rs-pffi => pffi/shared}/struct.scm | 0 .../{r7rs-pffi => pffi/shared}/union.scm | 0 retropikzel/{r7rs-pffi => pffi}/skint.scm | 0 retropikzel/{r7rs-pffi => pffi}/stklos.scm | 0 retropikzel/{r7rs-pffi => pffi}/tr7.scm | 0 retropikzel/{r7rs-pffi => pffi}/ypsilon.scm | 0 retropikzel/r7rs-pffi/gauche.scm | 3 - snow/arvyy/mustache-test.rkt | 3 + snow/arvyy/mustache.rkt | 3 + snow/arvyy/mustache/collection.rkt | 3 + snow/arvyy/mustache/executor.rkt | 3 + snow/arvyy/mustache/lookup.rkt | 3 + snow/arvyy/mustache/parser.rkt | 3 + snow/arvyy/mustache/tokenizer.rkt | 3 + .../r7rs-pffi-chibi.stub => src/chibi.stub | 7 +- src/gauche.scm | 27 + src/pffi-gauche.scm | 6 + test.rkt | 914 ++++++++++++++++++ test.scm | 81 +- 40 files changed, 1323 insertions(+), 579 deletions(-) delete mode 100644 libtest.c delete mode 100644 libtest.h rename retropikzel/{r7rs-pffi => pffi}/chibi.scm (97%) rename retropikzel/{r7rs-pffi => pffi}/chicken5.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/chicken6.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/cyclone.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/gambit.scm (100%) create mode 100644 retropikzel/pffi/gauche.scm rename retropikzel/{r7rs-pffi => pffi}/gerbil.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/guile.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/kawa.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/larceny.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/main.scm (99%) rename retropikzel/{r7rs-pffi => pffi}/mosh.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/racket.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/sagittarius.scm (98%) create mode 100644 retropikzel/pffi/shared/main.scm rename retropikzel/{r7rs-pffi => pffi/shared}/struct.scm (100%) rename retropikzel/{r7rs-pffi => pffi/shared}/union.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/skint.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/stklos.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/tr7.scm (100%) rename retropikzel/{r7rs-pffi => pffi}/ypsilon.scm (100%) delete mode 100644 retropikzel/r7rs-pffi/gauche.scm create mode 100644 snow/arvyy/mustache-test.rkt create mode 100644 snow/arvyy/mustache.rkt create mode 100644 snow/arvyy/mustache/collection.rkt create mode 100644 snow/arvyy/mustache/executor.rkt create mode 100644 snow/arvyy/mustache/lookup.rkt create mode 100644 snow/arvyy/mustache/parser.rkt create mode 100644 snow/arvyy/mustache/tokenizer.rkt rename retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub => src/chibi.stub (98%) create mode 100644 src/gauche.scm create mode 100644 src/pffi-gauche.scm create mode 100644 test.rkt diff --git a/.gitignore b/.gitignore index 1307159..039ee15 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,14 @@ +!src/libtest.c +!src/pffi-gauche.c +!src/pffi-gauche.h +!include/libtest.h +!include/pffi-gauche.h +*.h *.swp *.swo docuptmp *.log *.c -!libtest.c *.a *.so *.o diff --git a/Makefile b/Makefile index f2d05d2..937884b 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY=libtest.so libtest.a +.PHONY=libtest.o libtest.so libtest.a CC=gcc DOCKER=docker run -it -v ${PWD}:/workdir DOCKER_INIT=cd /workdir && make clean && @@ -6,21 +6,31 @@ DOCKER_INIT=cd /workdir && make clean && all: chibi chibi: - chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub - ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so \ - retropikzel/r7rs-pffi/r7rs-pffi-chibi.c \ + chibi-ffi src/chibi.stub && mv src/chibi.c src/pffi-chibi.c + ${CC} -Werror -g3 -o retropikzel/pffi/pffi-chibi.so \ + src/pffi-chibi.c \ -fPIC \ -lffi \ -shared +gauche: + ${CC} -Werror -g3 -o retropikzel/pffi/pffi-gauche.so \ + src/pffi-gauche.c \ + -fPIC \ + -lffi \ + -shared \ + -I./include + jenkinsfile: gosh -r7 -I ./snow build.scm -libtest.so: libtest.c - ${CC} -o libtest.so -shared -fPIC libtest.c +libtest.o: src/libtest.c + ${CC} -o libtest.o -fPIC -c src/libtest.c -I./include -libtest.a: libtest.c - ${CC} -fPIC -c libtest.c +libtest.so: libtest.c + ${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include + +libtest.a: libtest.o src/libtest.c ar rcs libtest.a libtest.o test-script: libtest.so @@ -30,168 +40,17 @@ test-script-docker: 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" -test-compile-library: libtest.so libtest.a +test-compile-library: libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld test-compile: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I." LDFLAGS="-ltest" compile-r7rs -I . test.scm && ./test + SCHEME=${SCHEME} CFLAGS="-I./include" LDFLAGS="-ltest" compile-r7rs -I . test.scm && ./test test-compile-docker: libtest.so libtest.a 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 -I . test.scm && ./test" -CHIBI=chibi-scheme -A . -test-chibi-docker: - docker build -f Dockerfile --build-arg SCHEME=chibi --tag=r7rs-pffi-chibi . - ${DOCKER} r7rs-pffi-chibi bash -c \ - "${DOCKER_INIT} chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub \ - && ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi \ - && ${CHIBI} test.scm" - -test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so libtest.so - ${CHIBI} test.scm - -CHICKEN5=SCMC=csc CSC_FLAGS='-I. -L. -L -ltest' compile-r7rs -I . main.scm -test-chicken-5-docker: - docker build --build-arg SCHEME=chicken:5 -f Dockerfile --tag=r7rs-pffi-chicken-5 . - ${DOCKER} r7rs-pffi-chicken-5 bash -c "${DOCKER_INIT} ${CHICKEN5} test.scm && ./test" - -test-chicken-5: clean libtest.a - ${CHICKEN5} test.scm - ./test - -CHICKEN6=SCMC=csc CSC_FLAGS='-I. -L. -L -ltest' compile-r7rs -I . main.scm -test-chicken-6-docker: - docker build --build-arg SCHEME=chicken:6 -f Dockerfile --tag=r7rs-pffi-chicken-6 . - cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - ${DOCKER} r7rs-pffi-chicken-6 bash -c "${DOCKER_INIT} ${CHICKEN6} test.scm && ./test" - -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 - -CYCLONE=cyclone -COPT -I. -A . -test-cyclone-docker: - docker build --build-arg SCHEME=cyclone -f Dockerfile --tag=r7rs-pffi-cyclone . - ${DOCKER} r7rs-pffi-cyclone bash -c "${DOCKER_INIT} ${CYCLONE} retropikzel/r7rs-pffi.sld && ${CYCLONE} test.scm && ./test" - -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-docker: - docker build --build-arg SCHEME=gambit -f Dockerfile --tag=r7rs-pffi-gambit . - ${DOCKER} r7rs-pffi-gambit bash -c "${DOCKER_INIT} ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$? && ${GAMBIT_CC} test.scm; echo $$? && ./test -:search=.; echo $$?" - -test-gambit: clean libtest.so - ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$? - ${GAMBIT_CC} test.scm; echo $$? - ./test -:search=.; echo $$? - -test-gauche: - gosh -r7 -A . test.scm - -GERBIL_LIB=gxc -O -GERBIL=GERBIL_LOADPATH=. gxc r7rs -test-gerbil-docker: - docker build --build-arg SCHEME=gerbil -f Dockerfile --tag=r7rs-pffi-gerbil . - ${DOCKER} r7rs-pffi-gerbil bash -c "${DOCKER_INIT} ${GERBIL_LIB} retropikzel/r7rs-pffi.sld && ${GERBIL} test.scm" - -test-gerbil: - ${GERBIL} test.scm - -GUILE=guile --r7rs --fresh-auto-compile -L . -test-guile-docker: - docker build --build-arg SCHEME=guile:head -f Dockerfile --tag=r7rs-pffi-guile . - ${DOCKER} r7rs-pffi-guile bash -c "${DOCKER_INIT} ${GUILE} test.scm" - -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-docker: - docker build --build-arg SCHEME=kawa -f Dockerfile --tag=r7rs-pffi-kawa . - ${DOCKER} r7rs-pffi-kawa bash -c "${DOCKER_INIT} ${KAWA} test.scm" - -test-kawa: libtest.so - ${KAWA} test.scm - -LARCENY=larceny -r7 -I . -test-larceny-docker: - docker build --build-arg SCHEME=larceny -f Dockerfile --tag=r7rs-pffi-larceny . - ${DOCKER} r7rs-pffi-larceny bash -c "${DOCKER_INIT} ${LARCENY} test.scm" - -test-larceny: libtest.so - ${LARCENY} test.scm - -MOSH=mosh --loadpath=. -test-mosh-docker: - docker build --build-arg SCHEME=mosh -f Dockerfile --tag=r7rs-pffi-mosh . - ${DOCKER} r7rs-pffi-mosh bash -c "${DOCKER_INIT} ${MOSH} test.scm" - -test-mosh: libtest.so - ${MOSH} test.scm - -SASH=sash --clean-cache -r7 -L . -test-sagittarius-docker: - docker build --build-arg SCHEME=sagittarius:head -f Dockerfile --tag=r7rs-pffi-sagittarius . - ${DOCKER} r7rs-pffi-sagittarius bash -c "${DOCKER_INIT} ${SASH} test.scm" - -test-sagittarius: libtest.so - ${SASH} test.scm - -RACKET=racket -I r7rs -S . --script -test-racket-docker: - docker build --build-arg SCHEME=racket -f Dockerfile --tag=r7rs-pffi-racket . - ${DOCKER} r7rs-pffi-racket bash -c "${DOCKER_INIT} ${RACKET} test.scm" - -test-racket: libtest.so - ${RACKET} test.scm - -SKINT=skint -test-skint-docker: - docker build --build-arg SCHEME=skint:head -f Dockerfile --tag=r7rs-pffi-skint . - ${DOCKER} r7rs-pffi-skint bash -c "${DOCKER_INIT} ${SKINT} test.scm" - -test-skint: libtest.so - ${SKINT} test.scm - -STKLOS=stklos -A . -f -test-stklos-docker: - docker build --build-arg SCHEME=stklos:head -f Dockerfile --tag=r7rs-pffi-stklos . - ${DOCKER} r7rs-pffi-stklos bash -c "${DOCKER_INIT} ${STKLOS} test.scm" - -test-stklos: libtest.so - ${STKLOS} test.scm - -TR7=tr7i -test-tr7-docker: - docker build --build-arg SCHEME=tr7:head -f Dockerfile --tag=r7rs-pffi-tr7 . - ${DOCKER} r7rs-pffi-tr7 bash -c "${DOCKER_INIT} ${TR7} test.scm" - -test-tr7: libtest.so - ${TR7} test.scm - -YPSILON=ypsilon --r7rs --sitelib=. --top-level-program -test-ypsilon-docker: - docker build --build-arg SCHEME=ypsilon -f Dockerfile --tag=r7rs-pffi-ypsilon . - ${DOCKER} r7rs-pffi-ypsilon bash -c "${DOCKER_INIT} ${YPSILON} test.scm" - -test-ypsilon: libtest.so - ${YPSILON} test.scm - -documentation: - cat README.md > docs/index.md - mkdocs build - -tmp: - mkdir -p tmp - clean: @rm -rf docutmp @rm -rf retropikzel/r7rs-pffi/*.o* @@ -204,7 +63,7 @@ clean: @rm -rf test/pffi-define @rm -rf test/*gambit* find . -name "*.link" -delete - find . -name "*.c" -not -name "libtest.c" -delete + find . -name "*.c" -not -name "libtest.c" -and -not -name "pffi-gauche.c" -delete find . -name "*.o" -delete find . -name "*.o[1-9]" -delete find . -name "*.so" -delete diff --git a/README.md b/README.md index 2e80acf..0cb0323 100644 --- a/README.md +++ b/README.md @@ -79,28 +79,28 @@ changing anymore and some implementations are in **beta**. ### Beta -| | 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-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 | -| 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 | X | +| | 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 | +|--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------|----------------------| +| Guile | 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 | ### Alpha -| | 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-struct-dereference | 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 | | -| Chicken-5 | 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 | | -| Gambit | X | X | | | | | | | | | | | | | X | X | X | X | X | | | | -| Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | | | | -| Gerbil | 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 | X | -| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | | | | -| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | | -| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | | | | -| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | | +| | 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 | | +| Chicken-5 | 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 | | +| Gambit | X | X | | | | | | | | | | | | | X | X | X | X | X | | | +| Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | | | +| Gerbil | 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 | +| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | | | +| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | +| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | | | +| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | ### Not started diff --git a/libtest.c b/libtest.c deleted file mode 100644 index 43b3bf6..0000000 --- a/libtest.c +++ /dev/null @@ -1,267 +0,0 @@ -#include -#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 color { - int8_t r; - int8_t g; - int8_t b; - int8_t a; -}; - -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; -}; - -void print_string_pointer(char* p) { - printf("C print_string_pointer: %s\n", p); -} - -void print_offsets() { - printf("C: Offset of a = %u\n", offsetof(struct test, a)); - printf("C: Offset of b = %u\n", offsetof(struct test, b)); - printf("C: Offset of c = %u\n", offsetof(struct test, c)); - printf("C: Offset of d = %u\n", offsetof(struct test, d)); - printf("C: Offset of e = %u\n", offsetof(struct test, e)); - printf("C: Offset of f = %u\n", offsetof(struct test, f)); - printf("C: Offset of g = %u\n", offsetof(struct test, g)); - printf("C: Offset of h = %u\n", offsetof(struct test, h)); - printf("C: Offset of i = %u\n", offsetof(struct test, i)); - printf("C: Offset of j = %u\n", offsetof(struct test, j)); - printf("C: Offset of k = %u\n", offsetof(struct test, k)); - printf("C: Offset of l = %u\n", offsetof(struct test, l)); - printf("C: Offset of m = %u\n", offsetof(struct test, m)); - printf("C: Offset of n = %u\n", offsetof(struct test, n)); -} - -void check_offset(int member_index, int offset) { - if (member_index == 1) { - int true_offset = offsetof(struct test, a); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 2) { - int true_offset = offsetof(struct test, b); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 3) { - int true_offset = offsetof(struct test, c); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 4) { - int true_offset = offsetof(struct test, d); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 5) { - int true_offset = offsetof(struct test, e); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 6) { - int true_offset = offsetof(struct test, f); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 7) { - int true_offset = offsetof(struct test, g); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 8) { - int true_offset = offsetof(struct test, h); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 9) { - int true_offset = offsetof(struct test, i); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 10) { - int true_offset = offsetof(struct test, j); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 11) { - int true_offset = offsetof(struct test, k); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 12) { - int true_offset = offsetof(struct test, l); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 13) { - int true_offset = offsetof(struct test, m); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } else if (member_index == 14) { - int true_offset = offsetof(struct test, n); - printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); - fflush(stdout); - assert(true_offset == offset); - } -} - - -EXPORT struct test* init_struct(struct test* test) { - print_offsets(); - test->a = 1; - test->b = 'b'; - test->c = 3.0; - test->d = 'd'; - test->e = NULL; - test->f = 6.0; - char* foo = malloc(sizeof("FOOBAR")); - snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); - 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 color_check(struct color* color) { - printf("C: Value of r is %c\n", color->r); - assert(color->r == 100); - printf("C: Value of g is %c\n", color->g); - assert(color->g == 100); - printf("C: Value of b is %c\n", color->b); - assert(color->b == 100); - printf("C: Value of a is %c\n", color->a); - assert(color->a == 100); - return 0; -} - -EXPORT int color_check_by_value(struct color color) { - printf("C: Value of r is %i\n", color.r); - assert(color.r == 100); - printf("C: Value of g is %i\n", color.g); - assert(color.g == 101); - printf("C: Value of b is %i\n", color.b); - assert(color.b == 102); - printf("C: Value of a is %i\n", color.a); - assert(color.a == 103); - return 0; -} - -EXPORT int test_check(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 h 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 int test_check_by_value(struct test test) { - print_offsets(); - printf("C: Value of a is %i\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 h 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)); - t->a = 1; - t->b = 'b'; - t->c = 3.0; - t->d = 'd'; - t->e = NULL; - t->f = 6.0; - char* foo = malloc(sizeof("FOOBAR")); - snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); - 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/libtest.h b/libtest.h deleted file mode 100644 index 243f12d..0000000 --- a/libtest.h +++ /dev/null @@ -1,9 +0,0 @@ -void print_string_pointer(char* p); -void print_offsets(); -void check_offset(int member_index, int offset); -struct test* init_struct(struct test* test); -int color_check(struct color* test); -int color_check_by_value(struct color color); -int test_check(struct test* test); -int test_check_by_value(struct test test); -struct test* test_new(); diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 5088984..d2fd6dd 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -30,10 +30,12 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define - pffi-define-callback) - (include-shared "r7rs-pffi/r7rs-pffi-chibi")) + pffi-define-callback + scheme-procedure-to-pointer + + ) + (include-shared "pffi/pffi-chibi")) (chicken-5 (import (scheme base) (scheme write) @@ -66,10 +68,9 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback)) - (chicken6 + (chicken6 (import (scheme base) (scheme write) (scheme char) @@ -130,7 +131,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - ;pffi-struct-dereference pffi-define ;pffi-define-callback )) @@ -169,7 +169,8 @@ (scheme write) (scheme char) (scheme file) - (scheme process-context)) + (scheme process-context) + (gauche base)) (export pffi-init ;pffi-size-of pffi-type? @@ -252,7 +253,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback)) (kawa @@ -282,7 +282,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback )) @@ -348,7 +347,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback)) (racket @@ -383,7 +381,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback)) (sagittarius @@ -415,7 +412,6 @@ pffi-struct-offset-get pffi-struct-get pffi-struct-set! - pffi-struct-dereference pffi-define pffi-define-callback)) (skint @@ -513,54 +509,48 @@ (scheme file) (scheme process-context)) (export ;pffi-init - ;pffi-size-of - pffi-type? - ;pffi-align-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-pointer - pffi-struct-offset-get - pffi-struct-get - pffi-struct-set! - ;pffi-define - ;pffi-define-callback + ;pffi-size-of + pffi-type? + ;pffi-align-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-pointer + pffi-struct-offset-get + pffi-struct-get + pffi-struct-set! + ;pffi-define + ;pffi-define-callback )) (else (error "Unsupported implementation"))) (cond-expand - (chibi (include "r7rs-pffi/chibi.scm")) - (chicken-5 (include "r7rs-pffi/chicken5.scm")) + (chibi (include "pffi/chibi.scm")) + (chicken-5 (include "pffi/chicken5.scm")) (chicken-6 (include "chicken6.scm")) - (cyclone (include "r7rs-pffi/cyclone.scm")) - (gambit (include "r7rs-pffi/gambit.scm")) - (gauche (include "r7rs-pffi/gauche.scm")) - (gerbil (include "r7rs-pffi/gerbil.scm")) - (guile (include "r7rs-pffi/guile.scm")) - (kawa (include "r7rs-pffi/kawa.scm")) - (larceny (include "r7rs-pffi/larceny.scm")) - (mosh (include "r7rs-pffi/mosh.scm")) - (racket (include "r7rs-pffi/racket.scm")) - (sagittarius (include "r7rs-pffi/sagittarius.scm")) - (skint (include "r7rs-pffi/skint.scm")) - (stklos (include "retropikzel/r7rs-pffi/stklos.scm")) - (tr7 (include "r7rs-pffi/tr7.scm")) - (ypsilon (include "r7rs-pffi/ypsilon.scm")) + (cyclone (include "pffi/cyclone.scm")) + (gambit (include "pffi/gambit.scm")) + (gauche (include "pffi/gauche.scm")) + (gerbil (include "pffi/gerbil.scm")) + (guile (include "pffi/guile.scm")) + (kawa (include "pffi/kawa.scm")) + (larceny (include "pffi/larceny.scm")) + (mosh (include "pffi/mosh.scm")) + (racket (include "pffi/racket.scm")) + (sagittarius (include "pffi/sagittarius.scm")) + (skint (include "pffi/skint.scm")) + (stklos (include "pffi/stklos.scm")) + (tr7 (include "pffi/tr7.scm")) + (ypsilon (include "pffi/ypsilon.scm")) (else #t)) - (cond-expand - (stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10 - (else (include "r7rs-pffi/struct.scm"))) - (cond-expand - (stklos (include "retropikzel/r7rs-pffi/union.scm")) ; FIXME temporarily for stklos 2.10 - (else (include "r7rs-pffi/union.scm"))) - (cond-expand - (stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10 - (else (include "r7rs-pffi/main.scm")))) + (include "pffi/shared/struct.scm") + (include "pffi/shared/union.scm") + (include "pffi/shared/main.scm")) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/pffi/chibi.scm similarity index 97% rename from retropikzel/r7rs-pffi/chibi.scm rename to retropikzel/pffi/chibi.scm index 7f69048..d88959c 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -177,11 +177,6 @@ (define make-c-function (lambda (shared-object return-type c-name argument-types) - (display "Argument types: ") - (write argument-types) - (newline) - (write (length argument-types)) - (newline) (dlerror) ;; Clean all previous errors (let ((func (dlsym shared-object c-name)) (maybe-dlerror (dlerror)) @@ -212,7 +207,6 @@ (symbol->string c-name) argument-types))))) - (define make-c-callback (lambda (return-type argument-types procedure) (scheme-procedure-to-pointer procedure))) @@ -222,7 +216,3 @@ ((pffi-define scheme-name return-type argument-types procedure) (define scheme-name (make-c-callback return-type argument-types procedure))))) - -(define pffi-struct-dereference - (lambda (struct) - (pffi-pointer-address (pffi-struct-pointer struct)))) diff --git a/retropikzel/r7rs-pffi/chicken5.scm b/retropikzel/pffi/chicken5.scm similarity index 100% rename from retropikzel/r7rs-pffi/chicken5.scm rename to retropikzel/pffi/chicken5.scm diff --git a/retropikzel/r7rs-pffi/chicken6.scm b/retropikzel/pffi/chicken6.scm similarity index 100% rename from retropikzel/r7rs-pffi/chicken6.scm rename to retropikzel/pffi/chicken6.scm diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm similarity index 100% rename from retropikzel/r7rs-pffi/cyclone.scm rename to retropikzel/pffi/cyclone.scm diff --git a/retropikzel/r7rs-pffi/gambit.scm b/retropikzel/pffi/gambit.scm similarity index 100% rename from retropikzel/r7rs-pffi/gambit.scm rename to retropikzel/pffi/gambit.scm diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm new file mode 100644 index 0000000..2c38266 --- /dev/null +++ b/retropikzel/pffi/gauche.scm @@ -0,0 +1,7 @@ +(dynamic-load "retropikzel/pffi/pffi-gauche" :init-function "Scm__Init_pffi_gauche") + +(foo 10) + +(define size-of-type + (lambda (type) + (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/gerbil.scm b/retropikzel/pffi/gerbil.scm similarity index 100% rename from retropikzel/r7rs-pffi/gerbil.scm rename to retropikzel/pffi/gerbil.scm diff --git a/retropikzel/r7rs-pffi/guile.scm b/retropikzel/pffi/guile.scm similarity index 100% rename from retropikzel/r7rs-pffi/guile.scm rename to retropikzel/pffi/guile.scm diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/pffi/kawa.scm similarity index 100% rename from retropikzel/r7rs-pffi/kawa.scm rename to retropikzel/pffi/kawa.scm diff --git a/retropikzel/r7rs-pffi/larceny.scm b/retropikzel/pffi/larceny.scm similarity index 100% rename from retropikzel/r7rs-pffi/larceny.scm rename to retropikzel/pffi/larceny.scm diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/pffi/main.scm similarity index 99% rename from retropikzel/r7rs-pffi/main.scm rename to retropikzel/pffi/main.scm index 73a0e91..dd7cffd 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/pffi/main.scm @@ -4,10 +4,10 @@ (er-macro-transformer (lambda (expr rename compare) '(import (chicken foreign) - (chicken memory)))))) + (chicken memory)) + #t)))) (else - (define pffi-init - (lambda () #t)))) + (define (pffi-init) #t))) (define (pffi-type? object) (if (equal? (size-of-type object) #f) diff --git a/retropikzel/r7rs-pffi/mosh.scm b/retropikzel/pffi/mosh.scm similarity index 100% rename from retropikzel/r7rs-pffi/mosh.scm rename to retropikzel/pffi/mosh.scm diff --git a/retropikzel/r7rs-pffi/racket.scm b/retropikzel/pffi/racket.scm similarity index 100% rename from retropikzel/r7rs-pffi/racket.scm rename to retropikzel/pffi/racket.scm diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm similarity index 98% rename from retropikzel/r7rs-pffi/sagittarius.scm rename to retropikzel/pffi/sagittarius.scm index 46b30b3..0bcb8ac 100644 --- a/retropikzel/r7rs-pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -81,10 +81,6 @@ (lambda (pointer) (pointer-address pointer))) -(define pffi-struct-dereference - (lambda (struct) - (deref (pffi-struct-pointer struct) 0))) - (define pffi-pointer-null (lambda () (empty-pointer))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm new file mode 100644 index 0000000..dd7cffd --- /dev/null +++ b/retropikzel/pffi/shared/main.scm @@ -0,0 +1,206 @@ +(cond-expand + ((or chicken-5 chicken-6) + (define-syntax pffi-init + (er-macro-transformer + (lambda (expr rename compare) + '(import (chicken foreign) + (chicken memory)) + #t)))) + (else + (define (pffi-init) #t))) + +(define (pffi-type? object) + (if (equal? (size-of-type object) #f) + #f + #t)) + +(define (pffi-size-of object) + (cond ((pffi-struct? object) (pffi-struct-size object)) + ((pffi-union? object) (pffi-union-size object)) + ((pffi-type? object) (size-of-type object)) + (else (error "Not pffi-struct, pffi-enum of pffi-type" object)))) + +(define pffi-types + '(int8 + uint8 + int16 + uint16 + int32 + uint32 + int64 + uint64 + char + unsigned-char + short + unsigned-short + int + unsigned-int + long + unsigned-long + float + double + string + pointer + void)) + +(define string-split + (lambda (str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter (lambda (c) + (cond ((char=? c mark) + (begin + (set! res (append res (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (string-copy str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) + +(cond-expand + (gambit + (define-macro + (pffi-shared-object-auto-load headers object-name options) + `(pffi-shared-object-load ,(car headers)))) + + ((or chicken cyclone) + (define-syntax pffi-shared-object-auto-load + (syntax-rules () + ((_ headers object-name . options) + (pffi-shared-object-load headers))))) + (else + (define pffi-shared-object-auto-load + (lambda (headers object-name . options) + (let* ((additional-paths (if (assoc 'additional-paths options) + (cdr (assoc 'additional-paths options)) + (list))) + (additional-versions (if (assoc 'additional-versions options) + (map (lambda (version) + (if (number? version) + (number->string version) + version)) + (cdr (assoc 'additional-versions options))) + (list))) + (slash (cond-expand (windows (string #\\)) (else "/"))) + (auto-load-paths + (cond-expand + (windows + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (if (get-environment-variable "WINEDLLDIR0") + (list (get-environment-variable "WINEDLLDIR0")) + (list)) + (if (get-environment-variable "SystemRoot") + (list (string-append + (get-environment-variable "SystemRoot") + slash + "system32")) + (list)) + (list ".") + (if (get-environment-variable "PATH") + (string-split (get-environment-variable "PATH") #\;) + (list)) + (if (get-environment-variable "PWD") + (list (get-environment-variable "PWD")) + (list)))) + (else + (append + ; Guix + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") + "") + "/run/current-system/profile/lib") + ; Debian + (if (get-environment-variable "LD_LIBRARY_PATH") + (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) + (list)) + (list + ;;; x86-64 + ; Debian + "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ;;; aarch64 + ; Debian + "/lib/aarch64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ; NetBSD + "/usr/pkg/lib"))))) + (auto-load-versions (list "")) + (paths (append auto-load-paths additional-paths)) + (versions (append additional-versions auto-load-versions)) + (platform-lib-prefix + (cond-expand + ;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) + (windows "") + (else "lib"))) + (platform-file-extension + (cond-expand + ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) + (windows ".dll") + (else ".so"))) + (shared-object #f) + (searched-paths (list))) + (for-each + (lambda (path) + (for-each + (lambda (version) + (let ((library-path + (string-append path + slash + platform-lib-prefix + object-name + (cond-expand + (windows "") + (else platform-file-extension)) + (if (string=? version "") + "" + (string-append + (cond-expand (windows "-") + (else ".")) + version)) + (cond-expand + (windows platform-file-extension) + (else "")))) + (library-path-without-suffixes (string-append path + slash + platform-lib-prefix + object-name))) + (set! searched-paths (append searched-paths (list library-path))) + (when (and (not shared-object) + (file-exists? library-path)) + (set! shared-object + (cond-expand (racket library-path-without-suffixes) + (else library-path)))))) + versions)) + paths) + (if (not shared-object) + (begin + (display "Could not load shared object: ") + (write (list (cons 'object object-name) + (cons 'paths paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (newline) + (display "Searched paths: ") + (write searched-paths) + (newline) + (exit 1)) + (pffi-shared-object-load headers + shared-object + `((additional-versions ,versions))))))))) diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/pffi/shared/struct.scm similarity index 100% rename from retropikzel/r7rs-pffi/struct.scm rename to retropikzel/pffi/shared/struct.scm diff --git a/retropikzel/r7rs-pffi/union.scm b/retropikzel/pffi/shared/union.scm similarity index 100% rename from retropikzel/r7rs-pffi/union.scm rename to retropikzel/pffi/shared/union.scm diff --git a/retropikzel/r7rs-pffi/skint.scm b/retropikzel/pffi/skint.scm similarity index 100% rename from retropikzel/r7rs-pffi/skint.scm rename to retropikzel/pffi/skint.scm diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/pffi/stklos.scm similarity index 100% rename from retropikzel/r7rs-pffi/stklos.scm rename to retropikzel/pffi/stklos.scm diff --git a/retropikzel/r7rs-pffi/tr7.scm b/retropikzel/pffi/tr7.scm similarity index 100% rename from retropikzel/r7rs-pffi/tr7.scm rename to retropikzel/pffi/tr7.scm diff --git a/retropikzel/r7rs-pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm similarity index 100% rename from retropikzel/r7rs-pffi/ypsilon.scm rename to retropikzel/pffi/ypsilon.scm diff --git a/retropikzel/r7rs-pffi/gauche.scm b/retropikzel/r7rs-pffi/gauche.scm deleted file mode 100644 index 88f9efc..0000000 --- a/retropikzel/r7rs-pffi/gauche.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) 1)))) diff --git a/snow/arvyy/mustache-test.rkt b/snow/arvyy/mustache-test.rkt new file mode 100644 index 0000000..8fc6f94 --- /dev/null +++ b/snow/arvyy/mustache-test.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "mustache-test.sld") diff --git a/snow/arvyy/mustache.rkt b/snow/arvyy/mustache.rkt new file mode 100644 index 0000000..6fc0ec6 --- /dev/null +++ b/snow/arvyy/mustache.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "mustache.sld") diff --git a/snow/arvyy/mustache/collection.rkt b/snow/arvyy/mustache/collection.rkt new file mode 100644 index 0000000..7318926 --- /dev/null +++ b/snow/arvyy/mustache/collection.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "collection.sld") diff --git a/snow/arvyy/mustache/executor.rkt b/snow/arvyy/mustache/executor.rkt new file mode 100644 index 0000000..c0b4d57 --- /dev/null +++ b/snow/arvyy/mustache/executor.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "executor.sld") diff --git a/snow/arvyy/mustache/lookup.rkt b/snow/arvyy/mustache/lookup.rkt new file mode 100644 index 0000000..12fe7c9 --- /dev/null +++ b/snow/arvyy/mustache/lookup.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "lookup.sld") diff --git a/snow/arvyy/mustache/parser.rkt b/snow/arvyy/mustache/parser.rkt new file mode 100644 index 0000000..0197f4b --- /dev/null +++ b/snow/arvyy/mustache/parser.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "parser.sld") diff --git a/snow/arvyy/mustache/tokenizer.rkt b/snow/arvyy/mustache/tokenizer.rkt new file mode 100644 index 0000000..7a0e152 --- /dev/null +++ b/snow/arvyy/mustache/tokenizer.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (scheme base)) +(include "tokenizer.sld") diff --git a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub b/src/chibi.stub similarity index 98% rename from retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub rename to src/chibi.stub index 7e035f1..e0b64f3 100644 --- a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub +++ b/src/chibi.stub @@ -61,7 +61,7 @@ (c-declare "void* pointer_allocate(int size) { return malloc(size); }") (define-c (maybe-null void*) (pointer-allocate pointer_allocate) (int)) -(c-declare "int pointer_address(void* pointer) { return (int)&pointer; }") +(c-declare "int pointer_address(void* pointer) { return (intptr_t)&pointer; }") (define-c int (pointer-address pointer_address) ((maybe-null void*))) (c-declare "void pointer_free(void* pointer) { free(pointer); }") @@ -257,8 +257,9 @@ (c-declare "void* scheme_procedure_to_pointer(sexp proc) { if(sexp_procedurep(proc) == 1) { - puts(\"ITS A PROCEDURE\"); + sexp debug1 = sexp_procedure_code(proc); + printf(\"HERE: %u\\n\", sexp_bytecode_length(debug1)); } - return (void*)proc; //FIXME + return (void*)proc; }") (define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/src/gauche.scm b/src/gauche.scm new file mode 100644 index 0000000..66e4f0f --- /dev/null +++ b/src/gauche.scm @@ -0,0 +1,27 @@ +(use gauche.cgen) + +(define unit (make :name "pffi-gauche")) +(cgen-current-unit unit) + + +(cgen-decl "#include ") +(cgen-decl "#include ") + +(cgen-init "printf(\"initialization function\\n\");") + +(cgen-body "void foo(int n) { printf(\"got %u\\n\", n); }") + +(cgen-extern "void foo(int n);") + +;(cgen-extern "void foo(int n);") + +#;(parameterize ([cgen-current-unit *unit*]) + (cgen-decl "#include ") + (cgen-decl "#include ") + (cgen-body "void foo(int n) { printf(\"got %u\\n\", n); }") + (cgen-extern "void foo(int n);") + (cgen-init "printf(\"initialization function\\n\");") + ) + +(cgen-emit-c unit) +(cgen-emit-h unit) diff --git a/src/pffi-gauche.scm b/src/pffi-gauche.scm new file mode 100644 index 0000000..506af5f --- /dev/null +++ b/src/pffi-gauche.scm @@ -0,0 +1,6 @@ +(in-module pffi) + +(inline-stub + (.include "pffi-gauche.h") + (define-cproc foo (x::) foo)) + diff --git a/test.rkt b/test.rkt new file mode 100644 index 0000000..995d424 --- /dev/null +++ b/test.rkt @@ -0,0 +1,914 @@ +#lang r7rs +(import (scheme base) + (scheme write) + (scheme char) + (scheme process-context) + (retropikzel pffi)) + +(define header-count 1) + +(define print-header + (lambda (title) + (set-tag title) + (display "=========================================") + (newline) + (display header-count) + (display " ") + (display title) + (newline) + (display "=========================================") + (newline) + (set! header-count (+ header-count 1)))) + +(define count 0) +(define assert-tag 'none) + +(define set-tag + (lambda (tag) + (set! assert-tag tag) + (set! count 0))) + +(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 + (syntax-rules () + ((_ value) + (begin + (display 'value) + (display ": ") + (write value) + (newline))))) + +;; pffi-init + +(print-header 'pffi-init) + +(pffi-init) + +;; pffi-type? + +(print-header 'pffi-type?) + +(debug (pffi-type? 'int8)) +(assert equal? (pffi-type? 'int8) #t) +(debug (pffi-type? 'uint8)) +(assert equal? (pffi-type? 'uint8) #t) +(debug (pffi-type? 'int16)) +(assert equal? (pffi-type? 'int16) #t) +(debug (pffi-type? 'uint16)) +(assert equal? (pffi-type? 'uint16) #t) +(debug (pffi-type? 'int32)) +(assert equal? (pffi-type? 'int32) #t) +(debug (pffi-type? 'uint32)) +(assert equal? (pffi-type? 'uint32) #t) +(debug (pffi-type? 'int64)) +(assert equal? (pffi-type? 'int64) #t) +(debug (pffi-type? 'uint64)) +(assert equal? (pffi-type? 'uint64) #t) +(debug (pffi-type? 'char)) +(assert equal? (pffi-type? 'char) #t) +(debug (pffi-type? 'unsigned-char)) +(assert equal? (pffi-type? 'unsigned-char) #t) +(debug (pffi-type? 'short)) +(assert equal? (pffi-type? 'short) #t) +(debug (pffi-type? 'unsigned-short)) +(assert equal? (pffi-type? 'unsigned-short) #t) +(debug (pffi-type? 'int)) +(assert equal? (pffi-type? 'int) #t) +(debug (pffi-type? 'unsigned-int)) +(assert equal? (pffi-type? 'unsigned-int) #t) +(debug (pffi-type? 'long)) +(assert equal? (pffi-type? 'long) #t) +(debug (pffi-type? 'unsigned-long)) +(assert equal? (pffi-type? 'unsigned-long) #t) +(debug (pffi-type? 'float)) +(assert equal? (pffi-type? 'float) #t) +(debug (pffi-type? 'double)) +(assert equal? (pffi-type? 'double) #t) +(debug (pffi-type? 'string)) +(assert equal? (pffi-type? 'string) #t) +(debug (pffi-type? 'pointer)) +(assert equal? (pffi-type? 'pointer) #t) +(debug (pffi-type? 'void)) +(assert equal? (pffi-type? 'void) #t) +(debug (pffi-type? 'callback)) +(assert equal? (pffi-type? 'callback) #t) + +(pffi-init) + +;; pffi-size-of + +(print-header 'pffi-size-of) + +(define size-int8 (pffi-size-of 'int8)) +(debug size-int8) +(assert equal? (number? size-int8) #t) +(assert = size-int8 1) + +(define size-uint8 (pffi-size-of 'uint8)) +(debug size-uint8) +(assert equal? (number? size-uint8) #t) +(assert = size-uint8 1) + +(assert equal? (number? (pffi-size-of 'uint8)) #t) +(define size-int16 (pffi-size-of 'int16)) +(debug size-int16) +(assert equal? (number? size-int16) #t) +(assert = size-int16 2) + +(assert equal? (number? (pffi-size-of 'int16)) #t) +(define size-uint16 (pffi-size-of 'uint16)) +(debug size-uint16) +(assert equal? (number? size-uint16) #t) +(assert = size-uint16 2) + +(assert equal? (number? (pffi-size-of 'uint16)) #t) +(define size-int32 (pffi-size-of 'int32)) +(debug size-int32) +(assert equal? (number? size-int32) #t) +(assert = size-int32 4) + +(assert equal? (number? (pffi-size-of 'int32)) #t) +(define size-uint32 (pffi-size-of 'uint32)) +(debug size-uint32) +(assert equal? (number? size-uint32) #t) +(assert = size-uint32 4) + +(assert equal? (number? (pffi-size-of 'uint32)) #t) +(define size-int64 (pffi-size-of 'int64)) +(debug size-int64) +(assert equal? (number? size-int64) #t) +(assert = size-int64 8) + +(assert equal? (number? (pffi-size-of 'int64)) #t) +(define size-uint64 (pffi-size-of 'uint64)) +(debug size-uint64) +(assert equal? (number? size-uint64) #t) +(assert = size-uint64 8) + +(assert equal? (number? (pffi-size-of 'uint64)) #t) +(define size-char (pffi-size-of 'char)) +(debug size-char) +(assert equal? (number? size-char) #t) +(assert = size-char 1) + +(assert equal? (number? (pffi-size-of 'char)) #t) +(define size-unsigned-char (pffi-size-of 'unsigned-char)) +(debug size-unsigned-char) +(assert equal? (number? size-unsigned-char) #t) +(assert = size-unsigned-char 1) + +(assert equal? (number? (pffi-size-of 'unsigned-char)) #t) +(define size-short (pffi-size-of 'short)) +(debug size-short) +(assert equal? (number? size-short) #t) +(assert = size-short 2) + +(assert equal? (number? (pffi-size-of 'short)) #t) +(define size-unsigned-short (pffi-size-of 'unsigned-short)) +(debug size-unsigned-short) +(assert equal? (number? size-unsigned-short) #t) +(assert = size-unsigned-short 2) + +(assert equal? (number? (pffi-size-of 'unsigned-short)) #t) +(define size-int (pffi-size-of 'int)) +(debug size-int) +(assert equal? (number? size-int) #t) +(assert = size-int 4) + +(assert equal? (number? (pffi-size-of 'int)) #t) +(define size-unsigned-int (pffi-size-of 'unsigned-int)) +(debug size-unsigned-int) +(assert equal? (number? size-unsigned-int) #t) +(assert = size-unsigned-int 4) + +(cond-expand + (i386 + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 8))) + +(cond-expand + (i386 + (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 8))) + +(assert equal? (number? (pffi-size-of 'float)) #t) +(define size-float (pffi-size-of 'float)) +(debug size-float) +(assert equal? (number? size-float) #t) +(assert = size-float 4) + +(assert equal? (number? (pffi-size-of 'double)) #t) +(define size-double (pffi-size-of 'double)) +(debug size-double) +(assert equal? (number? size-double) #t) +(assert = size-double 8) + +(cond-expand + (i386 + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 4)) + (else + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 8))) + +;; pffi-align-of + +(print-header 'pffi-align-of) + +(define align-int8 (pffi-align-of 'int8)) +(debug align-int8) +(assert equal? (number? align-int8) #t) +(assert = align-int8 1) + +(define align-uint8 (pffi-align-of 'uint8)) +(debug align-uint8) +(assert equal? (number? align-uint8) #t) +(assert = align-uint8 1) + +(assert equal? (number? (pffi-align-of 'uint8)) #t) +(define align-int16 (pffi-align-of 'int16)) +(debug align-int16) +(assert equal? (number? align-int16) #t) +(assert = align-int16 2) + +(assert equal? (number? (pffi-align-of 'int16)) #t) +(define align-uint16 (pffi-align-of 'uint16)) +(debug align-uint16) +(assert equal? (number? align-uint16) #t) +(assert = align-uint16 2) + +(assert equal? (number? (pffi-align-of 'uint16)) #t) +(define align-int32 (pffi-align-of 'int32)) +(debug align-int32) +(assert equal? (number? align-int32) #t) +(assert = align-int32 4) + +(assert equal? (number? (pffi-align-of 'int32)) #t) +(define align-uint32 (pffi-align-of 'uint32)) +(debug align-uint32) +(assert equal? (number? align-uint32) #t) +(assert = align-uint32 4) + +(assert equal? (number? (pffi-align-of 'uint32)) #t) +(define align-int64 (pffi-align-of 'int64)) +(debug align-int64) +(assert equal? (number? align-int64) #t) +(assert = align-int64 8) + +(assert equal? (number? (pffi-align-of 'int64)) #t) +(define align-uint64 (pffi-align-of 'uint64)) +(debug align-uint64) +(assert equal? (number? align-uint64) #t) +(assert = align-uint64 8) + +(assert equal? (number? (pffi-align-of 'uint64)) #t) +(define align-char (pffi-align-of 'char)) +(debug align-char) +(assert equal? (number? align-char) #t) +(assert = align-char 1) + +(assert equal? (number? (pffi-align-of 'char)) #t) +(define align-unsigned-char (pffi-align-of 'unsigned-char)) +(debug align-unsigned-char) +(assert equal? (number? align-unsigned-char) #t) +(assert = align-unsigned-char 1) + +(assert equal? (number? (pffi-align-of 'unsigned-char)) #t) +(define align-short (pffi-align-of 'short)) +(debug align-short) +(assert equal? (number? align-short) #t) +(assert = align-short 2) + +(assert equal? (number? (pffi-align-of 'short)) #t) +(define align-unsigned-short (pffi-align-of 'unsigned-short)) +(debug align-unsigned-short) +(assert equal? (number? align-unsigned-short) #t) +(assert = align-unsigned-short 2) + +(assert equal? (number? (pffi-align-of 'unsigned-short)) #t) +(define align-int (pffi-align-of 'int)) +(debug align-int) +(assert equal? (number? align-int) #t) +(assert = align-int 4) + +(assert equal? (number? (pffi-align-of 'int)) #t) +(define align-unsigned-int (pffi-align-of 'unsigned-int)) +(debug align-unsigned-int) +(assert equal? (number? align-unsigned-int) #t) +(assert = align-unsigned-int 4) + +(cond-expand + (i386 + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 8))) + +(cond-expand + (i386 + (assert equal? (number? (pffi-align-of 'unsigned-long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 8))) + +(assert equal? (number? (pffi-align-of 'float)) #t) +(define align-float (pffi-align-of 'float)) +(debug align-float) +(assert equal? (number? align-float) #t) +(assert = align-float 4) + +(assert equal? (number? (pffi-align-of 'double)) #t) +(define align-double (pffi-align-of 'double)) +(debug align-double) +(assert equal? (number? align-double) #t) +(assert = align-double 8) + +(cond-expand + (i386 + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 4)) + (else + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 8))) + +;; pffi-shared-object-auto-load + +(print-header 'pffi-shared-object-auto-load) + +(define libc-stdlib + (cond-expand + (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) + (else (pffi-shared-object-auto-load (list "stdlib.h") + "c" + '(additional-versions . ("0" "6")))))) + +(debug libc-stdlib) + +(define c-testlib + (cond-expand + (windows (pffi-shared-object-auto-load (list "libtest.h") + "test" + '(additional-paths . (".")))) + (else (pffi-shared-object-auto-load (list "libtest.h") + "test" + '(additional-paths . (".")))))) + +(debug c-testlib) + +;; pffi-pointer-null + +(print-header 'pffi-pointer-null) + +(define null-pointer (pffi-pointer-null)) +(debug null-pointer) +(assert equal? (pffi-pointer-null? null-pointer) #t) + +;; pffi-pointer-null? + +(print-header 'pffi-pointer-null?) + +(define is-null-pointer (pffi-pointer-null)) +(debug is-null-pointer) +(assert equal? (pffi-pointer-null? is-null-pointer) #t) +(assert equal? (pffi-pointer-null? 100) #f) +(assert equal? (pffi-pointer-null? 'bar) #f) + +;; pffi-pointer-allocate + +(print-header 'pffi-pointer-allocate) + +(define test-pointer (pffi-pointer-allocate 100)) +(debug test-pointer) +(assert equal? (pffi-pointer? test-pointer) #t) +(assert equal? (pffi-pointer-null? test-pointer) #f) + +;; pffi-pointer-address + +(print-header 'pffi-pointer-allocate) + +(define test-pointer1 (pffi-pointer-allocate 100)) +(debug test-pointer1) +(debug (pffi-pointer? test-pointer1)) +(assert equal? (pffi-pointer? test-pointer1) #t) +;(debug (pffi-pointer-address test-pointer1)) +;(assert equal? (number? (pffi-pointer-address test-pointer1)) #t) + +;; pffi-pointer? + +(print-header 'pffi-pointer?) + +(define is-pointer (pffi-pointer-allocate 100)) +(debug is-pointer) +(assert equal? (pffi-pointer? is-pointer) #t) +(assert equal? (pffi-pointer? 100) #f) +(assert equal? (pffi-pointer? 'bar) #f) + +;; pffi-pointer-free + +(print-header 'pffi-pointer-free) + +(define pointer-to-be-freed (pffi-pointer-allocate 100)) +(debug pointer-to-be-freed) +(pffi-pointer-free pointer-to-be-freed) +(debug pointer-to-be-freed) + +;; pffi-pointer-set! and pffi-pointer-get 1/2 + +(print-header "pffi-pointer-set! and pffi-pointer-get 1/2") + +(define set-pointer (pffi-pointer-allocate 256)) +(define offset 64) +(define value 1) +(debug set-pointer) +(debug offset) +(debug value) + +(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 'uint8) +(test-type 'int16) +(test-type 'uint16) +(test-type 'int32) +(test-type 'uint32) +(test-type 'int64) +(test-type 'uint64) +(test-type 'short) +(test-type 'unsigned-short) +(test-type 'int) +(test-type 'unsigned-int) +(test-type 'long) +(test-type 'unsigned-long) + +(pffi-pointer-set! set-pointer 'char offset #\X) +(debug (pffi-pointer-get set-pointer 'char offset)) +(assert char=? (pffi-pointer-get set-pointer 'char offset) #\X) + +(pffi-pointer-set! set-pointer 'float offset 1.5) +(debug (pffi-pointer-get set-pointer 'float offset)) +(assert = (pffi-pointer-get set-pointer 'float offset) 1.5) + +(pffi-pointer-set! set-pointer 'double offset 1.5) +(debug (pffi-pointer-get set-pointer 'double offset)) +(assert = (pffi-pointer-get set-pointer 'double offset) 1.5) + +; pffi-struct-make + +(print-header "pffi-struct") + +(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) +(debug struct1) +(debug (pffi-size-of struct1)) +(assert = (pffi-size-of struct1) 12) + +(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct2) +(debug (pffi-size-of struct2)) +(assert = (pffi-size-of struct2) 8) + +(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct3) +(debug (pffi-size-of struct3)) +(assert = (pffi-size-of struct3) 8) + +(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) +(debug struct4) +(debug (pffi-size-of struct4)) +(assert = (pffi-size-of struct4) 24) + +(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) +(debug struct5) +(debug (pffi-size-of struct5)) +(assert = (pffi-size-of struct5) 24) + +(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-size-of struct6)) +(assert = (pffi-size-of struct6) 96) + +;; pffi-string->pointer + +(print-header 'pffi-string->pointer) + +(define string-pointer (pffi-string->pointer "Hello world")) +(debug string-pointer) +(debug (pffi-pointer->string string-pointer)) +(assert equal? (pffi-pointer? string-pointer) #t) +(assert equal? (pffi-pointer-null? string-pointer) #f) +(debug (pffi-pointer-get string-pointer 'char 0)) +(assert char=? (pffi-pointer-get string-pointer 'char 0) #\H) +(debug (pffi-pointer-get string-pointer 'char 1)) +(assert char=? (pffi-pointer-get string-pointer 'char 1) #\e) +(debug (pffi-pointer-get string-pointer 'char 2)) +(assert char=? (pffi-pointer-get string-pointer 'char 2) #\l) +(debug (pffi-pointer-get string-pointer 'char 3)) +(assert char=? (pffi-pointer-get string-pointer 'char 3) #\l) +(debug (pffi-pointer-get string-pointer 'char 4)) +(assert char=? (pffi-pointer-get string-pointer 'char 4) #\o) +(debug (pffi-pointer-get string-pointer 'char 10)) +(assert char=? (pffi-pointer-get string-pointer 'char 10) #\d) + +;; pffi-pointer->string + +(print-header 'pffi-pointer->string) + +(define pointer-string (pffi-pointer->string string-pointer)) +(debug pointer-string) +(assert equal? (string? pointer-string) #t) +(assert string=? pointer-string "Hello world") +(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org") +(define test-url-string "https://scheme.org") +(debug test-url-string) +(define test-url (pffi-string->pointer test-url-string)) +(debug test-url) +(debug (pffi-pointer->string test-url)) +(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t) + +;; pffi-pointer-get + +(print-header "pffi-pointer-get") + +(define hello-string "hello") +(define hello-string-pointer (pffi-string->pointer hello-string)) + +(debug (pffi-pointer-get hello-string-pointer 'char 0)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h) +(debug (pffi-pointer-get hello-string-pointer 'char 1)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 1) #\e) +(debug (pffi-pointer-get hello-string-pointer 'char 4)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o) + +;; pffi-pointer-set! and pffi-pointer-get 2/2 + +(print-header "pffi-pointer-set! and pffi-pointer-get 2/2") + +(define pointer-to-be-set (pffi-string->pointer "FOOBAR")) +(debug pointer-to-be-set) +(debug (pffi-pointer->string pointer-to-be-set)) +(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set) + +(debug (pffi-pointer-get set-pointer 'pointer offset)) +(assert equal? + (pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset)) + #t) +(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(assert equal? + (string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) + #t) +(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(assert equal? + (string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") + #t) + +(define string-to-be-set "FOOBAR") +(debug string-to-be-set) +(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) +(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") + +;; pffi-define + +(print-header 'pffi-define) + +(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 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-init-struct c-testlib 'init_struct 'pointer (list 'pointer)) +(pffi-define c-check-offset c-testlib 'check_offset 'void (list 'int 'int)) +(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)))) +(c-check-offset 1 (pffi-struct-offset-get struct-test 'a)) +(c-check-offset 2 (pffi-struct-offset-get struct-test 'b)) +(c-check-offset 3 (pffi-struct-offset-get struct-test 'c)) +(c-check-offset 4 (pffi-struct-offset-get struct-test 'd)) +(c-check-offset 5 (pffi-struct-offset-get struct-test 'e)) +(c-check-offset 6 (pffi-struct-offset-get struct-test 'f)) +(c-check-offset 7 (pffi-struct-offset-get struct-test 'g)) +(c-check-offset 8 (pffi-struct-offset-get struct-test 'h)) +(c-check-offset 9 (pffi-struct-offset-get struct-test 'i)) +(c-check-offset 10 (pffi-struct-offset-get struct-test 'j)) +(c-check-offset 11 (pffi-struct-offset-get struct-test 'k)) +(c-check-offset 12 (pffi-struct-offset-get struct-test 'l)) +(c-check-offset 13 (pffi-struct-offset-get struct-test 'm)) +(c-check-offset 14 (pffi-struct-offset-get struct-test 'n)) +(debug struct-test) +(c-init-struct (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)) +(assert = (pffi-struct-get struct-test 'c) 3.0) +(debug (pffi-struct-get struct-test 'd)) +(assert char=? (pffi-struct-get struct-test 'd) #\d) +(debug (pffi-struct-get struct-test 'e)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t) +(debug (pffi-struct-get struct-test 'f)) +(assert = (pffi-struct-get struct-test 'f) 6.0) +(debug (pffi-struct-get struct-test 'g)) +(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) +(debug (pffi-struct-get struct-test 'h)) +(assert = (pffi-struct-get struct-test 'h) 8) +(debug (pffi-struct-get struct-test 'i)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) +(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)) +(assert = (pffi-struct-get struct-test 'm) 13.0) +(debug (pffi-struct-get struct-test 'n)) +(assert = (pffi-struct-get struct-test 'n) 14.0) + +;; pffi-struct-set! 1 + +(print-header "pffi-struct-set! 1") + +(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.0) +(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.0) +(pffi-struct-set! struct-test1 'n 14.0) +(c-test-check (pffi-struct-pointer struct-test1)) + +;; pffi-struct-make with pointer + +(print-header "pffi-struct-make with pointer") + +(pffi-define c-test-new c-testlib 'test_new 'pointer (list)) +(define struct-test2-pointer (c-test-new)) +(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)) + struct-test2-pointer)) +(debug struct-test2) + +(debug (pffi-pointer-get struct-test2-pointer 'int8 0)) +(debug (pffi-struct-get struct-test2 'a)) +(assert = (pffi-struct-get struct-test2 'a) 1) +(debug (pffi-pointer-get struct-test2-pointer 'char 1)) +(debug (pffi-struct-get struct-test2 'b)) +(assert char=? (pffi-struct-get struct-test2 'b) #\b) +(debug (pffi-struct-get struct-test2 'c)) +(assert = (pffi-struct-get struct-test2 'c) 3) +(debug (pffi-struct-get struct-test2 'd)) +(assert char=? (pffi-struct-get struct-test2 'd) #\d) +(debug (pffi-struct-get struct-test2 'e)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) +(debug (pffi-struct-get struct-test2 'f)) +(assert = (pffi-struct-get struct-test2 'f) 6.0) +(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) +(debug (pffi-struct-get struct-test2 'h)) +(assert = (pffi-struct-get struct-test2 'h) 8) +(debug (pffi-struct-get struct-test2 'i)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) +(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) +(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)) +(assert = (pffi-struct-get struct-test2 'm) 13.0) +(debug (pffi-struct-get struct-test2 'n)) +(assert = (pffi-struct-get struct-test2 'n) 14.0) + +;; pffi-struct-dereference + +(print-header "pffi-struct-dereference 1") +(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct)) +(define struct-color (pffi-struct-make 'color '((int8 . r) + (int8 . g) + (int8 . b) + (int8 . a)))) +(debug (pffi-struct-set! struct-color 'r 100)) +(debug (pffi-struct-set! struct-color 'g 101)) +(debug (pffi-struct-set! struct-color 'b 102)) +(debug (pffi-struct-set! struct-color 'a 103)) +(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) + +(print-header "pffi-struct-dereference 2") + +(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)))) +(debug (pffi-struct-set! struct-test3 'a 1)) +(debug (pffi-struct-set! struct-test3 'b #\b)) +(debug (pffi-struct-set! struct-test3 'c 3.0)) +(debug (pffi-struct-set! struct-test3 'd #\d)) +(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) +(debug (pffi-struct-set! struct-test3 'f 6.0)) +(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) +(debug (pffi-struct-set! struct-test3 'h 8)) +(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) +(debug (pffi-struct-set! struct-test3 'j 10)) +(debug (pffi-struct-set! struct-test3 'k 11)) +(debug (pffi-struct-set! struct-test3 'l 12)) +(debug (pffi-struct-set! struct-test3 'm 13.0)) +(debug (pffi-struct-set! struct-test3 'n 14.0)) +(debug (pffi-struct-get struct-test3 'a)) +(debug (pffi-struct-get struct-test3 'b)) +(debug (pffi-struct-get struct-test3 'c)) +(debug (pffi-struct-get struct-test3 'd)) +(debug (pffi-struct-get struct-test3 'e)) +(debug (pffi-struct-get struct-test3 'f)) +(debug (pffi-struct-get struct-test3 'g)) +(debug (pffi-struct-get struct-test3 'h)) +(debug (pffi-struct-get struct-test3 'i)) +(debug (pffi-struct-get struct-test3 'j)) +(debug (pffi-struct-get struct-test3 'k)) +(debug (pffi-struct-get struct-test3 'l)) +(debug (pffi-struct-get struct-test3 'm)) +(debug (pffi-struct-get struct-test3 'n)) +(c-test-check-by-value (pffi-struct-dereference struct-test3)) + +;; pffi-define-callback + +(print-header 'pffi-define-callback) + +(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) + +(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) + +(pffi-define-callback compare + 'int + (list 'pointer 'pointer) + (lambda (pointer-a pointer-b) + (let ((a (pffi-pointer-get pointer-a 'int 0)) + (b (pffi-pointer-get pointer-b 'int 0))) + (cond ((> a b) 1) + ((= a b) 0) + ((< a b) -1))))) +(write compare) +(newline) + +(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +(debug unsorted) +(assert equal? unsorted (list 3 2 1)) + +(qsort array 3 (pffi-size-of 'int) compare) + +(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +(debug sorted) +(assert equal? sorted (list 1 2 3)) +(exit 0) diff --git a/test.scm b/test.scm index e5228b0..dd1425b 100755 --- a/test.scm +++ b/test.scm @@ -58,6 +58,7 @@ (pffi-init) +(exit 0) ;; pffi-type? (print-header 'pffi-type?) @@ -814,22 +815,22 @@ ;; pffi-struct-dereference -(print-header "pffi-struct-dereference 1") -(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct)) -(define struct-color (pffi-struct-make 'color '((int8 . r) +;(print-header "pffi-struct-dereference 1") +;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct)) +#;(define struct-color (pffi-struct-make 'color '((int8 . r) (int8 . g) (int8 . b) (int8 . a)))) -(debug (pffi-struct-set! struct-color 'r 100)) -(debug (pffi-struct-set! struct-color 'g 101)) -(debug (pffi-struct-set! struct-color 'b 102)) -(debug (pffi-struct-set! struct-color 'a 103)) -(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) +;(debug (pffi-struct-set! struct-color 'r 100)) +;(debug (pffi-struct-set! struct-color 'g 101)) +;(debug (pffi-struct-set! struct-color 'b 102)) +;(debug (pffi-struct-set! struct-color 'a 103)) +;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) -(print-header "pffi-struct-dereference 2") +;(print-header "pffi-struct-dereference 2") -(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct)) -(define struct-test3 (pffi-struct-make 'test +;(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) @@ -844,35 +845,35 @@ (int . l) (double . m) (float . n)))) -(debug (pffi-struct-set! struct-test3 'a 1)) -(debug (pffi-struct-set! struct-test3 'b #\b)) -(debug (pffi-struct-set! struct-test3 'c 3.0)) -(debug (pffi-struct-set! struct-test3 'd #\d)) -(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) -(debug (pffi-struct-set! struct-test3 'f 6.0)) -(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) -(debug (pffi-struct-set! struct-test3 'h 8)) -(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) -(debug (pffi-struct-set! struct-test3 'j 10)) -(debug (pffi-struct-set! struct-test3 'k 11)) -(debug (pffi-struct-set! struct-test3 'l 12)) -(debug (pffi-struct-set! struct-test3 'm 13.0)) -(debug (pffi-struct-set! struct-test3 'n 14.0)) -(debug (pffi-struct-get struct-test3 'a)) -(debug (pffi-struct-get struct-test3 'b)) -(debug (pffi-struct-get struct-test3 'c)) -(debug (pffi-struct-get struct-test3 'd)) -(debug (pffi-struct-get struct-test3 'e)) -(debug (pffi-struct-get struct-test3 'f)) -(debug (pffi-struct-get struct-test3 'g)) -(debug (pffi-struct-get struct-test3 'h)) -(debug (pffi-struct-get struct-test3 'i)) -(debug (pffi-struct-get struct-test3 'j)) -(debug (pffi-struct-get struct-test3 'k)) -(debug (pffi-struct-get struct-test3 'l)) -(debug (pffi-struct-get struct-test3 'm)) -(debug (pffi-struct-get struct-test3 'n)) -(c-test-check-by-value (pffi-struct-dereference struct-test3)) +;(debug (pffi-struct-set! struct-test3 'a 1)) +;(debug (pffi-struct-set! struct-test3 'b #\b)) +;(debug (pffi-struct-set! struct-test3 'c 3.0)) +;(debug (pffi-struct-set! struct-test3 'd #\d)) +;(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'f 6.0)) +;(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) +;(debug (pffi-struct-set! struct-test3 'h 8)) +;(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'j 10)) +;(debug (pffi-struct-set! struct-test3 'k 11)) +;(debug (pffi-struct-set! struct-test3 'l 12)) +;(debug (pffi-struct-set! struct-test3 'm 13.0)) +;(debug (pffi-struct-set! struct-test3 'n 14.0)) +;(debug (pffi-struct-get struct-test3 'a)) +;(debug (pffi-struct-get struct-test3 'b)) +;(debug (pffi-struct-get struct-test3 'c)) +;(debug (pffi-struct-get struct-test3 'd)) +;(debug (pffi-struct-get struct-test3 'e)) +;(debug (pffi-struct-get struct-test3 'f)) +;(debug (pffi-struct-get struct-test3 'g)) +;(debug (pffi-struct-get struct-test3 'h)) +;(debug (pffi-struct-get struct-test3 'i)) +;(debug (pffi-struct-get struct-test3 'j)) +;(debug (pffi-struct-get struct-test3 'k)) +;(debug (pffi-struct-get struct-test3 'l)) +;(debug (pffi-struct-get struct-test3 'm)) +;(debug (pffi-struct-get struct-test3 'n)) +;(c-test-check-by-value (pffi-struct-dereference struct-test3)) ;; pffi-define-callback