Lots of improvements to Chibi. Started adding Chicken 6 support
This commit is contained in:
parent
77509b9620
commit
9578cc9ee3
36
Makefile
36
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
|
||||
|
|
|
|||
137
libtest.c
137
libtest.c
|
|
@ -2,17 +2,18 @@
|
|||
#include <stdio.h>
|
||||
#include <assert.h>
|
||||
#include <string.h>
|
||||
#include <stddef.h>
|
||||
|
||||
#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;
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
struct test* function(struct test* test);
|
||||
|
||||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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
|
||||
|
|
@ -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)))))))
|
||||
|
||||
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -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 "/")))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
78
test.scm
78
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue