From 9578cc9ee3d1ee3ebe811fcc44a15326ef8b2cfb Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 24 Jan 2025 20:30:34 +0200 Subject: [PATCH] Lots of improvements to Chibi. Started adding Chicken 6 support --- Makefile | 36 +-- libtest.c | 137 +++++++-- test.h => libtest.h | 1 + retropikzel/r7rs-pffi.sld | 60 +++- retropikzel/r7rs-pffi/chibi.scm | 3 +- retropikzel/r7rs-pffi/chibi.stub | 264 ------------------ .../r7rs-pffi/{chicken.scm => chicken5.scm} | 4 +- retropikzel/r7rs-pffi/chicken6.scm | 255 +++++++++++++++++ retropikzel/r7rs-pffi/cyclone.scm | 4 +- retropikzel/r7rs-pffi/main.scm | 6 +- retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub | 42 +-- retropikzel/r7rs-pffi/struct.scm | 25 +- test.scm | 78 ++++-- 13 files changed, 546 insertions(+), 369 deletions(-) rename test.h => libtest.h (97%) delete mode 100644 retropikzel/r7rs-pffi/chibi.stub rename retropikzel/r7rs-pffi/{chicken.scm => chicken5.scm} (98%) create mode 100644 retropikzel/r7rs-pffi/chicken6.scm diff --git a/Makefile b/Makefile index e2cd6ba..7791d93 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,8 @@ +.PHONY=libtest.so CC=gcc DOCKER=docker run -it -v ${PWD}:/workdir -libtest.so: test.c +libtest.so: libtest.c ${CC} -o libtest.so -shared -fPIC libtest.c CHIBI=chibi-scheme -A . @@ -10,7 +11,7 @@ test-chibi-podman-amd64: libtest.so 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" -retropikzel/r7rs-pffi/r7rs-pffi-chibi.c: +retropikzel/r7rs-pffi/r7rs-pffi-chibi.c: retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi.c @@ -20,13 +21,15 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi. -lchibi-scheme \ -lffi \ -L${HOME}/.scman/chibi/lib \ - -I${HOME}/.scman/chibi/include + -I${HOME}/.scman/chibi/include \ + -L${HOME}/.scman/chibi-git/lib \ + -I${HOME}/.scman/chibi-git/include 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 +CHICKEN5=csc -X r7rs -R r7rs -I. +CHICKEN5_LIB=csc -X r7rs -R r7rs -I. -include-path ./retropikzel -s -J 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" @@ -37,19 +40,19 @@ test-chicken5: clean libtest.so ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld ${CHICKEN5} test.scm && ./test -CHICKEN6=csc -CHICKEN6_LIB=csc -include-path ./retropikzel -s -J +CHICKEN6=csc -I. +CHICKEN6_LIB=csc -I. -include-path ./retropikzel -s -J 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" + podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" + podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:6 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" test-chicken6: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - ${CHICKEN6_LIB} retropikzel.r7rs-pffi.sld - ${CHICKEN6} test.scm && ./test + ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld + ${CHICKEN5} test.scm && ./test -CYCLONE=cyclone -A . +CYCLONE=cyclone -COPT -I. -A . 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" @@ -75,13 +78,13 @@ test-gauche: gosh -r7 -A . test.scm GERBIL_LIB=gxc -O -GERBIL=GERBIL_LOADPATH=. gxi --lang r7rs +GERBIL=GERBIL_LOADPATH=. gxc r7rs 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" test-gerbil: - gxi --lang r7rs test.scm + ${GERBIL} test.scm GUILE=guile --r7rs --fresh-auto-compile -L . test-guile-podman-amd64: libtest.so @@ -155,7 +158,6 @@ tmp: clean: @rm -rf docutmp - @rm -rf retropikzel/r7rs-pffi/*.c @rm -rf retropikzel/r7rs-pffi/*.o* @rm -rf retropikzel/r7rs-pffi/*.so @rm -rf retropikzel/r7rs-pffi/*.meta @@ -166,7 +168,7 @@ clean: @rm -rf test/pffi-define @rm -rf test/*gambit* find . -name "*.link" -delete - find . -name "*.c" -delete + find . -name "*.c" -not -name "libtest.c" -delete find . -name "*.o" -delete find . -name "*.o[1-9]" -delete find . -name "*.so" -delete @@ -175,3 +177,5 @@ clean: @rm -rf tmp find . -name "core.1" -delete find . -name "test@gambit*" -delete + rm -rf retropikzel/r7rs-pffi/r7rs-pffi-chibi.so + rm -rf retropikzel/r7rs-pffi/r7rs-pffi-chibi.c diff --git a/libtest.c b/libtest.c index 8410a12..90eb329 100644 --- a/libtest.c +++ b/libtest.c @@ -2,17 +2,18 @@ #include #include #include +#include #if defined(_MSC_VER) - #define EXPORT __declspec(dllexport) - #define IMPORT __declspec(dllimport) +#define EXPORT __declspec(dllexport) +#define IMPORT __declspec(dllimport) #elif defined(__GNUC__) - #define EXPORT __attribute__((visibility("default"))) - #define IMPORT +#define EXPORT __attribute__((visibility("default"))) +#define IMPORT #else - #define EXPORT - #define IMPORT - #pragma warning Unknown dynamic link import/export semantics. +#define EXPORT +#define IMPORT +#pragma warning Unknown dynamic link import/export semantics. #endif @@ -33,16 +34,112 @@ struct test { float n; }; +void print_string_pointer(char* p) { + printf("C print_string_pointer: %s\n", p); +} -EXPORT struct test* test(struct test* test) { +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; //FIXME: Change to 3.0 and fix the library to work with it + test->c = 3.0; test->d = 'd'; test->e = NULL; test->f = 6.0; - char* foo = malloc(4); - snprintf(foo, 4, "foo"); + char* foo = malloc(sizeof("FOOBAR")); + snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); test->g = foo; test->h = 8; test->i = NULL; @@ -54,32 +151,34 @@ EXPORT struct test* test(struct test* test) { } EXPORT int test_check(struct test* test) { + print_offsets(); 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->c == 3.0); assert(test->d == 'd'); assert(test->e == NULL); - // assert(test->f == 6.0); //FIXME - //assert(strcmp(test->g, "foo") == 0); //FIXME + assert(test->f == 6.0); + assert(strcmp(test->g, "foo") == 0); 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 + assert(test->m == 13); + assert(test->n == 14); } EXPORT struct test* test_new(struct test* test) { + print_offsets(); 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->c = 3.0; t->d = 'd'; t->e = NULL; t->f = 6.0; - char* foo = malloc(4); - snprintf(foo, 4, "foo"); + char* foo = malloc(sizeof("FOOBAR")); + snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); t->g = foo; t->h = 8; t->i = NULL; diff --git a/test.h b/libtest.h similarity index 97% rename from test.h rename to libtest.h index 725757b..6f22df3 100644 --- a/test.h +++ b/libtest.h @@ -1 +1,2 @@ struct test* function(struct test* test); + diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index c77f996..4af42e8 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -26,6 +26,8 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -34,7 +36,7 @@ ;pffi-pointer-dereference ) (include-shared "r7rs-pffi/r7rs-pffi-chibi")) - (chicken + (chicken5 (import (scheme base) (scheme write) (scheme char) @@ -62,12 +64,49 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define pffi-define-callback pffi-pointer-address - ;pffi-pointer-dereference + pffi-pointer-dereference + )) + (chicken6 + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (chicken foreign) + (chicken locative) + (chicken syntax) + (chicken memory) + (chicken random)) + (export pffi-init + pffi-size-of + 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-size + pffi-struct-pointer + pffi-struct-offset-get + pffi-struct-get + pffi-struct-set! + pffi-define + pffi-define-callback + pffi-pointer-address + pffi-pointer-dereference )) (cyclone (import (scheme base) @@ -94,6 +133,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -125,6 +165,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -155,6 +196,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -185,6 +227,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -218,6 +261,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -247,6 +291,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -282,6 +327,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -314,6 +360,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -349,6 +396,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -380,6 +428,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! pffi-define @@ -409,6 +458,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -440,6 +490,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -470,6 +521,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -500,6 +552,7 @@ pffi-struct-make pffi-struct-size pffi-struct-pointer + pffi-struct-offset-get pffi-struct-get pffi-struct-set! ;pffi-define @@ -511,7 +564,8 @@ (include "r7rs-pffi/struct.scm") (cond-expand (chibi (include "r7rs-pffi/chibi.scm")) - (chicken (include "r7rs-pffi/chicken.scm")) + (chicken5 (include "r7rs-pffi/chicken.scm")) + (chicken6 (include "chicken6.scm")) (cyclone (include "r7rs-pffi/cyclone.scm")) (gambit (include "r7rs-pffi/gambit.scm")) (gauche (include "r7rs-pffi/gauche.scm")) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm index 60bff8d..403b6cf 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/retropikzel/r7rs-pffi/chibi.scm @@ -41,7 +41,8 @@ (define pffi-pointer? (lambda (object) - (string=? (type-name (type-of object)) "Cpointer"))) + (or (not object) ; #f is null on Chibi + (string=? (type-name (type-of object)) "Cpointer")))) (define pffi-pointer-allocate (lambda (size) diff --git a/retropikzel/r7rs-pffi/chibi.stub b/retropikzel/r7rs-pffi/chibi.stub deleted file mode 100644 index e0781dc..0000000 --- a/retropikzel/r7rs-pffi/chibi.stub +++ /dev/null @@ -1,264 +0,0 @@ -; vim: ft=scheme - -(c-system-include "stdint.h") -(c-system-include "dlfcn.h") -(c-system-include "ffi.h") - -;; pffi-size-of -(c-declare " - int size_of_int8_t() { return sizeof(int8_t); } - int size_of_uint8_t() { return sizeof(uint8_t); } - int size_of_int16_t() { return sizeof(int16_t); } - int size_of_uint16_t() { return sizeof(uint16_t); } - int size_of_int32_t() { return sizeof(int32_t); } - int size_of_uint32_t() { return sizeof(uint32_t); } - int size_of_int64_t() { return sizeof(int64_t); } - int size_of_uint64_t() { return sizeof(uint64_t); } - int size_of_char() { return sizeof(char); } - int size_of_unsigned_char() { return sizeof(unsigned char); } - int size_of_short() { return sizeof(short); } - int size_of_unsigned_short() { return sizeof(unsigned short); } - int size_of_int() { return sizeof(int); } - int size_of_unsigned_int() { return sizeof(unsigned int); } - int size_of_long() { return sizeof(long); } - int size_of_unsigned_long() { return sizeof(unsigned long); } - int size_of_float() { return sizeof(float); } - int size_of_double() { return sizeof(double); } - int size_of_pointer() { return sizeof(void*); } -") - -(define-c int (size-of-int8_t size_of_int8_t) ()) -(define-c int (size-of-uint8_t size_of_uint8_t) ()) -(define-c int (size-of-int16_t size_of_int16_t) ()) -(define-c int (size-of-uint16_t size_of_uint16_t) ()) -(define-c int (size-of-int32_t size_of_int32_t) ()) -(define-c int (size-of-uint32_t size_of_uint32_t) ()) -(define-c int (size-of-int64_t size_of_int64_t) ()) -(define-c int (size-of-uint64_t size_of_uint64_t) ()) -(define-c int (size-of-char size_of_char) ()) -(define-c int (size-of-unsigned-char size_of_unsigned_char) ()) -(define-c int (size-of-short size_of_short) ()) -(define-c int (size-of-unsigned-short size_of_unsigned_short) ()) -(define-c int (size-of-int size_of_int) ()) -(define-c int (size-of-unsigned-int size_of_unsigned_int) ()) -(define-c int (size-of-long size_of_long) ()) -(define-c int (size-of-unsigned-long size_of_unsigned_long) ()) -(define-c int (size-of-float size_of_float) ()) -(define-c int (size-of-double size_of_double) ()) -(define-c int (size-of-pointer size_of_pointer) ()) - -;; pffi-shape-object-load -(define-c-const int (RTLD-NOW "RTLD_NOW")) -(define-c (maybe-null void*) dlopen (string int)) -(define-c (maybe-null void*) dlerror ()) - -(c-declare "void* pointer_null() { return NULL; }") -(define-c (maybe-null void*) (pointer-null pointer_null) ()) - -(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }") -(define-c bool (is-pointer-null is_pointer_null) ((maybe-null void*))) - -(c-declare "void* pointer_allocate(int size) { return malloc(size); }") -(define-c (maybe-null void*) (pointer-allocate pointer_allocate) (int)) - -(c-declare "void pointer_free(void* pointer) { free(pointer); }") -(define-c void (pointer-free pointer_free) ((maybe-null void*))) - -;; pffi-pointer-set! -(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { int8_t* p = (int8_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t)) -(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { uint8_t* p = (uint8_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t)) - -(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { int16_t* p = (int16_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t)) -(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { uint16_t* p = (uint16_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t)) - -(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { int32_t* p = (int32_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t)) -(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { uint32_t* p = (uint32_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t)) - -(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { int64_t* p = (int64_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t)) -(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { uint64_t* p = (uint64_t*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t)) - -(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { char* p = (char*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char)) -(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { unsigned char* p = (unsigned char*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char)) - -(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { short* p = (short*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short)) -(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { short* p = (unsigned short*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short)) - -(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { int* p = (int*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int)) -(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { int* p = (unsigned int*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int)) - -(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { long* p = (long*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long)) -(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { long* p = (unsigned long*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long)) - -(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { float* p = (float*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float)) - -(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { double* p = (double*)pointer; p[offset] = value; }") -(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double)) - -(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { void* p = &pointer + offset; p = value; }") -(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null void*))) - -;; pffi-pointer-get -(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { int8_t* p = (int8_t*)pointer; return p[offset]; }") -(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int)) -(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { uint8_t* p = (uint8_t*)pointer; return p[offset]; }") -(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int)) - -(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { int16_t* p = (int16_t*)pointer; return p[offset]; }") -(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int)) -(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { uint16_t* p = (uint16_t*)pointer; return p[offset]; }") -(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int)) - -(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { int32_t* p = (int32_t*)pointer; return p[offset]; }") -(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int)) -(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { uint32_t* p = (uint32_t*)pointer; return p[offset]; }") -(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int)) - -(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { int64_t* p = (int64_t*)pointer; return p[offset]; }") -(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int)) -(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { uint64_t* p = (uint64_t*)pointer; return p[offset]; }") -(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int)) - -(c-declare "char pointer_ref_c_char(void* pointer, int offset) { char* p = (char*)pointer; return p[offset]; }") -(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) -(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { unsigned char* p = (unsigned char*)pointer; return p[offset]; }") -(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int)) - -(c-declare "short pointer_ref_c_short(void* pointer, int offset) { short* p = (short*)pointer; return p[offset]; }") -(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int)) -(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { unsigned short* p = (unsigned short*)pointer; return p[offset]; }") -(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int)) - -(c-declare "int pointer_ref_c_int(void* pointer, int offset) { int* p = (int*)pointer; return p[offset]; }") -(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int)) -(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { unsigned int* p = (unsigned int*)pointer; return p[offset]; }") -(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int)) - -(c-declare "long pointer_ref_c_long(void* pointer, int offset) { long* p = (long*)pointer; return p[offset]; }") -(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long)) -(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { unsigned long* p = (unsigned long*)pointer; return p[offset]; }") -(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int)) - -(c-declare "float pointer_ref_c_float(void* pointer, int offset) { float* p = (float*)pointer; return p[offset]; }") -(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int)) - -(c-declare "double pointer_ref_c_double(void* pointer, int offset) { double* p = (double*)pointer; return p[offset]; }") -(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int)) - -(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { void* p = &pointer + offset; return p;}") -(define-c (maybe-null void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) - -;; pffi-string->pointer -(c-declare "void* string_to_pointer(char* string) { return (void*)string; }") -(define-c (maybe-null void*) (string-to-pointer string_to_pointer) (string)) - -;; pffi-pointer->string -(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") -(define-c string (pointer-to-string pointer_to_string) ((maybe-null void*))) - -;; pffi-define - -(c-declare "ffi_cif cif;") -(define-c (pointer void*) dlsym ((maybe-null void*) string)) - -(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }") -(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ()) -(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }") -(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ()) - -(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }") -(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ()) -(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }") -(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ()) - -(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }") -(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ()) -(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }") -(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ()) - -(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }") -(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ()) -(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }") -(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ()) - -(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }") -(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ()) -(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }") -(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ()) - -(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }") -(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ()) -(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }") -(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ()) - -(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }") -(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ()) -(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }") -(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ()) - -(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }") -(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ()) - -(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }") -(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ()) - -(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }") -(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ()) - -(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }") -(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ()) - -(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }") -(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ()) - -(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }") -(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ()) - -(define-c-const int (FFI-OK "FFI_OK")) -(c-declare - "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) { - printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs); - return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); - }") -(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*))) -(c-declare - "void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, void* avalues) { - ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); - char* s = \"MORO\"; - void* values[] = {&s}; - ffi_call(&cif, FFI_FN(fn), rvalue, &avalues); - }") -(define-c void - (internal-ffi-call internal_ffi_call) - (unsigned-int - (pointer void*) - (array void*) - (pointer void*) - (pointer void*) - (array void*))) - -(c-declare - "void* scheme_procedure_to_pointer(void* proc) { - if(sexp_procedurep(proc) == 1) { - puts(\"ITS A PROCEDURE\"); - } - return proc; - }") - -(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/retropikzel/r7rs-pffi/chicken.scm b/retropikzel/r7rs-pffi/chicken5.scm similarity index 98% rename from retropikzel/r7rs-pffi/chicken.scm rename to retropikzel/r7rs-pffi/chicken5.scm index 2a1e6db..3c0a784 100644 --- a/retropikzel/r7rs-pffi/chicken.scm +++ b/retropikzel/r7rs-pffi/chicken5.scm @@ -177,8 +177,8 @@ "C_return((void*)str);")) -(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) -(pffi-define strlen #f 'strlen 'int (list 'pointer)) +;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) +;(pffi-define strlen #f 'strlen 'int (list 'pointer)) (define pffi-pointer->string (foreign-lambda* c-string diff --git a/retropikzel/r7rs-pffi/chicken6.scm b/retropikzel/r7rs-pffi/chicken6.scm new file mode 100644 index 0000000..3c0a784 --- /dev/null +++ b/retropikzel/r7rs-pffi/chicken6.scm @@ -0,0 +1,255 @@ +(define-syntax pffi-init + (er-macro-transformer + (lambda (expr rename compare) + '(import (chicken foreign) + (chicken memory))))) + +(define pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'c-pointer) + (else (error "pffi-type->native-type -- No such pffi type" type)))) ) + +(define pffi-pointer? + (lambda (object) + (pointer? object))) + +(define-syntax pffi-define + (er-macro-transformer + (lambda (expr rename compare) + (let* ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'c-pointer) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + (scheme-name (car (cdr expr))) + (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) + (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) + (argument-types + (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) + (if (null? types) + '() + (map pffi-type->native-type (map car (map cdr types))))))) + (if (null? argument-types) + `(define ,scheme-name + (foreign-safe-lambda ,return-type ,c-name)) + `(define ,scheme-name + (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) + +(define-syntax pffi-define-callback + (er-macro-transformer + (lambda (expr rename compare) + (let* ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'c-pointer) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + (scheme-name (car (cdr expr))) + (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr))))))) + (argument-types + (let ((types (cdr (car (cdr (cdr (cdr expr))))))) + (if (null? types) + '() + (map pffi-type->native-type (map car (map cdr types)))))) + (argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))) + (arguments (map + (lambda (name type) + `(,name ,type)) + argument-types argument-names)) + (procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr))))))))) + `(begin (define-external ,(cons 'external_123456789 arguments) + ,return-type + (begin ,@ procedure-body)) + (define ,scheme-name (location external_123456789))))))) + +(define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int)) + ((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int)) + ((equal? type 'int16) (foreign-value "sizeof(int16_t)" int)) + ((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int)) + ((equal? type 'int32) (foreign-value "sizeof(int32_t)" int)) + ((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int)) + ((equal? type 'int64) (foreign-value "sizeof(int64_t)" int)) + ((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int)) + ((equal? type 'char) (foreign-value "sizeof(char)" int)) + ((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int)) + ((equal? type 'short) (foreign-value "sizeof(short)" int)) + ((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int)) + ((equal? type 'int) (foreign-value "sizeof(int)" int)) + ((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int)) + ((equal? type 'long) (foreign-value "sizeof(long)" int)) + ((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int)) + ((equal? type 'float) (foreign-value "sizeof(float)" int)) + ((equal? type 'double) (foreign-value "sizeof(double)" int)) + ((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) + (else (error "pffi-size-of -- No such pffi type" type))))) + +(define pffi-pointer-allocate + (lambda (size) + (allocate size))) + +(define pffi-pointer-address + (lambda (pointer) + (pointer->address pointer))) + +(define pffi-pointer-dereference + (lambda (pointer) + (pointer->address pointer))) + +(define pffi-pointer-null + (lambda () + (address->pointer 0))) + +(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) +(pffi-define puts #f 'puts 'int (list 'pointer)) +(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) + +(define pffi-string->pointer + (lambda (string-content) + (let* ((size (string-length string-content)) + (pointer (pffi-pointer-allocate (+ size 1)))) + (memset pointer 0 (+ size 1)) + (strncpy-ps pointer (location string-content) size) + ;(puts pointer) + pointer))) + +#;(define pffi-string->pointer + (foreign-lambda* c-pointer + ((c-string str)) + "C_return((void*)str);")) + + +;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) +;(pffi-define strlen #f 'strlen 'int (list 'pointer)) + +(define pffi-pointer->string + (foreign-lambda* c-string + ((c-pointer p)) + "C_return((char*)p);")) + +(define-syntax pffi-shared-object-load + (er-macro-transformer + (lambda (expr rename compare) + (let* ((headers (cdr (car (cdr expr))))) + `(begin + ,@ (map + (lambda (header) + `(foreign-declare ,(string-append "#include <" header ">"))) + headers)))))) + +(define pffi-pointer-free + (lambda (pointer) + (if (not (pointer? pointer)) + (error "pffi-pointer-free -- Argument is not pointer" pointer)) + (free pointer))) + +(define pffi-pointer-null? + (lambda (pointer) + (if (and (not (pointer? pointer)) + pointer) + #f + (or (not pointer) ; #f counts as null pointer on Chicken + (= (pointer->address pointer) 0))))) + +(define pffi-pointer-set! + (lambda (pointer type offset value) + (cond + ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) + ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) + ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value)) + ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value)) + ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value)) + ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value)) + ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value)) + ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value)) + ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value))) + ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value)) + ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value)) + ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value)) + ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value)) + ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value)) + ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) + ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value)) + ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) + ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))))) + +(define pffi-pointer-get + (lambda (pointer type offset) + (cond + ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) + ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) + ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset))) + ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset))) + ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset))) + ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset))) + ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset))) + ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset))) + ((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset)))) + ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset))) + ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset))) + ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset))) + ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset))) + ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset))) + ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) + ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) + ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) + ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) + diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/r7rs-pffi/cyclone.scm index 3ce8579..057f292 100644 --- a/retropikzel/r7rs-pffi/cyclone.scm +++ b/retropikzel/r7rs-pffi/cyclone.scm @@ -236,8 +236,8 @@ (define-c pffi-pointer-pointer-set! "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "char* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = &opaque_ptr(value); + "uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = (uintptr_t)&opaque_ptr(value); return_closcall1(data, k, make_boolean(boolean_t));") (define pffi-pointer-set! diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index c999e2d..f9fb1a9 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -47,12 +47,16 @@ (define-macro (pffi-shared-object-auto-load headers additional-paths object-name additional-versions) `(pffi-shared-object-load ,(car headers)))) + (cyclone + (define-syntax pffi-shared-object-auto-load + (syntax-rules () + ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) + (pffi-shared-object-load headers))))) (else (define-syntax pffi-shared-object-auto-load (syntax-rules () ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) (cond-expand - (cyclone (pffi-shared-object-load headers)) (chicken (pffi-shared-object-load headers)) (else (let* ((slash (cond-expand (windows (string #\\)) (else "/"))) diff --git a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub b/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub index 0d44b4c..89d1ae2 100644 --- a/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub +++ b/retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub @@ -108,60 +108,60 @@ (c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { float* p = (float*)pointer; p[offset] = value; }") (define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float)) -(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { double* p = (double*)pointer; p[offset] = value; }") +(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }") (define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double)) -(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { void* p = &pointer + offset; p = value; }") +(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") (define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null void*))) ;; pffi-pointer-get -(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { int8_t* p = (int8_t*)pointer; return p[offset]; }") +(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") (define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int)) -(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { uint8_t* p = (uint8_t*)pointer; return p[offset]; }") +(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }") (define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int)) -(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { int16_t* p = (int16_t*)pointer; return p[offset]; }") +(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }") (define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int)) -(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { uint16_t* p = (uint16_t*)pointer; return p[offset]; }") +(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }") (define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int)) -(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { int32_t* p = (int32_t*)pointer; return p[offset]; }") +(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }") (define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int)) -(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { uint32_t* p = (uint32_t*)pointer; return p[offset]; }") +(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }") (define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int)) -(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { int64_t* p = (int64_t*)pointer; return p[offset]; }") +(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }") (define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int)) -(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { uint64_t* p = (uint64_t*)pointer; return p[offset]; }") +(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }") (define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int)) -(c-declare "char pointer_ref_c_char(void* pointer, int offset) { char* p = (char*)pointer; return p[offset]; }") +(c-declare "char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }") (define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) -(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { unsigned char* p = (unsigned char*)pointer; return p[offset]; }") +(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }") (define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int)) -(c-declare "short pointer_ref_c_short(void* pointer, int offset) { short* p = (short*)pointer; return p[offset]; }") +(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }") (define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int)) -(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { unsigned short* p = (unsigned short*)pointer; return p[offset]; }") +(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }") (define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int)) -(c-declare "int pointer_ref_c_int(void* pointer, int offset) { int* p = (int*)pointer; return p[offset]; }") +(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }") (define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int)) -(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { unsigned int* p = (unsigned int*)pointer; return p[offset]; }") +(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }") (define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int)) -(c-declare "long pointer_ref_c_long(void* pointer, int offset) { long* p = (long*)pointer; return p[offset]; }") +(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }") (define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long)) -(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { unsigned long* p = (unsigned long*)pointer; return p[offset]; }") +(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }") (define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int)) -(c-declare "float pointer_ref_c_float(void* pointer, int offset) { float* p = (float*)pointer; return p[offset]; }") +(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }") (define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int)) -(c-declare "double pointer_ref_c_double(void* pointer, int offset) { double* p = (double*)pointer; return p[offset]; }") +(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }") (define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int)) -(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { void* p = &pointer + offset; return p;}") +(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") (define-c (maybe-null void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) ;; pffi-string->pointer diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm index a9d2583..ab83bf7 100644 --- a/retropikzel/r7rs-pffi/struct.scm +++ b/retropikzel/r7rs-pffi/struct.scm @@ -9,7 +9,7 @@ (define pffi-align-of (lambda (type) (cond-expand - (guile (alignof (pffi-type->native-type type))) + ;(guile (alignof (pffi-type->native-type type))) (else (pffi-size-of type))))) (define (round-to-next-modulo-of to-round roundee) @@ -31,27 +31,21 @@ (begin (set! size (+ size type-alignment)) (list name type (- size type-alignment))) - (begin - (set! size (+ (round-to-next-modulo-of size type-alignment) - type-alignment)) + (let ((next-alignment (round-to-next-modulo-of size type-alignment))) + (set! size (+ next-alignment type-alignment)) (list name type - (round-to-next-modulo-of size type-alignment)))))) + next-alignment))))) members))) (list (cons 'size (cond-expand - (guile (sizeof (map pffi-type->native-type (map car members)))) + ;(guile (sizeof (map pffi-type->native-type (map car members)))) (else (if (= (modulo size largest-member-size) 0) size (round-to-next-modulo-of size largest-member-size))))) (cons 'offsets offsets)))) -(define pffi-word-size - (cond-expand - (i386 4) ; 32-bit system - (else 8))) ; 64-bit system - (define (pffi-struct-make name members . pointer) (for-each (lambda (member) @@ -71,11 +65,20 @@ (name (if (string? name) name (symbol->string name)))) (struct-make name size pointer offsets))) +(define (pffi-struct-offset-get struct member-name) + (when (not (assoc member-name (pffi-struct-members struct))) + (error "Struct has no such member" (list struct member-name))) + (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))) + (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))))))) + (map display (list "type: " type + ", offset: " offset + ", value: " (pffi-pointer-get (pffi-struct-pointer struct) type offset) + #\newline)) (pffi-pointer-get (pffi-struct-pointer struct) type offset))) (define (pffi-struct-set! struct member-name value) diff --git a/test.scm b/test.scm index ce75e5e..9995f80 100644 --- a/test.scm +++ b/test.scm @@ -4,15 +4,20 @@ (scheme process-context) (retropikzel r7rs-pffi)) +(define header-count 1) + (define print-header (lambda (title) (set-tag title) (display "=========================================") (newline) + (display header-count) + (display " ") (display title) (newline) (display "=========================================") - (newline))) + (newline) + (set! header-count (+ header-count 1)))) (define count 0) (define assert-tag 'none) @@ -140,7 +145,7 @@ (assert = size-unsigned-int 4) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (assert equal? (number? (pffi-size-of 'long)) #t) (define size-long (pffi-size-of 'long)) (debug size-long) @@ -154,7 +159,7 @@ (assert = size-long 8))) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) (define size-unsigned-long (pffi-size-of 'unsigned-long)) (debug size-unsigned-long) @@ -180,7 +185,7 @@ (assert = size-double 8) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (define size-pointer (pffi-size-of 'pointer)) (debug size-pointer) (assert equal? (number? size-pointer) #t) @@ -278,7 +283,7 @@ (assert = align-unsigned-int 4) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (assert equal? (number? (pffi-align-of 'long)) #t) (define align-long (pffi-align-of 'long)) (debug align-long) @@ -292,7 +297,7 @@ (assert = align-long 8))) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (assert equal? (number? (pffi-align-of 'unsigned-long)) #t) (define align-unsigned-long (pffi-align-of 'unsigned-long)) (debug align-unsigned-long) @@ -318,7 +323,7 @@ (assert = align-double 8) (cond-expand - (larceny ;; Works on 32 bit mode + (i386 (define align-pointer (pffi-align-of 'pointer)) (debug align-pointer) (assert equal? (number? align-pointer) #t) @@ -342,8 +347,8 @@ (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 ""))))) + (windows (pffi-shared-object-auto-load (list "libtest.h") (list ".") "test" (list ""))) + (else (pffi-shared-object-auto-load (list "libtest.h") (list ".") "test" (list ""))))) (debug c-testlib) @@ -398,7 +403,7 @@ (print-header "pffi-pointer-set! and pffi-pointer-get 1/2") (define set-pointer (pffi-pointer-allocate 256)) -(define offset 50) +(define offset 0) (define value 1) (debug set-pointer) (debug offset) @@ -553,9 +558,10 @@ (assert equal? (string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) #t) -(assert string=? - (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) - "FOOBAR") +(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) @@ -577,7 +583,8 @@ (print-header 'pffi-struct-get) -(pffi-define c-test c-testlib 'test 'pointer (list 'pointer)) +(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) @@ -593,38 +600,53 @@ (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-test (pffi-struct-pointer 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)) ; FIXME -;(assert = (pffi-struct-get struct-test 'c) 3) ; FIXME +(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)) ; 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 '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)) ; 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 '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)) ; 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 '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)) ; FIXME -;(assert = (pffi-struct-get struct-test 'm) 13) ; FIXME +(debug (pffi-struct-get struct-test 'm)) +(assert = (pffi-struct-get struct-test 'm) 13) (debug (pffi-struct-get struct-test 'n)) (assert = (pffi-struct-get struct-test 'n) 14) @@ -717,7 +739,6 @@ ;(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) @@ -753,6 +774,5 @@ (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) (newline) -|# (exit 0)