From 842178129d910588b719dc79d529ac00bc0f64bf Mon Sep 17 00:00:00 2001 From: retropikzel Date: Mon, 3 Mar 2025 19:26:03 +0200 Subject: [PATCH] - Started making progress with Gauche implementation - Clean up the repository structure and C file names --- .gitignore | 9 +- Makefile | 4 +- include/libtest.h | 15 ++ include/pffi-gauche.h | 36 +++++ retropikzel/pffi.sld | 17 ++- retropikzel/pffi/gauche.scm | 65 +++++++-- src/gauchelib.scm | 31 ++++- src/libtest.c | 267 ++++++++++++++++++++++++++++++++++++ src/pffi-chibi.stub | 265 +++++++++++++++++++++++++++++++++++ src/pffi-gauche.c | 142 +++++++++++++++++++ test.scm | 3 - 11 files changed, 822 insertions(+), 32 deletions(-) create mode 100644 include/libtest.h create mode 100644 include/pffi-gauche.h create mode 100644 src/libtest.c create mode 100644 src/pffi-chibi.stub create mode 100644 src/pffi-gauche.c diff --git a/.gitignore b/.gitignore index 039ee15..15d93d4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,14 +1,13 @@ +*.h +!include/pffi-gauche.h +!include/libtest.h +*.c !src/libtest.c !src/pffi-gauche.c -!src/pffi-gauche.h -!include/libtest.h -!include/pffi-gauche.h -*.h *.swp *.swo docuptmp *.log -*.c *.a *.so *.o diff --git a/Makefile b/Makefile index 13ed551..3fa633f 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ DOCKER_INIT=cd /workdir && make clean && all: chibi chibi: - chibi-ffi src/chibi.stub && mv src/chibi.c src/pffi-chibi.c + chibi-ffi src/pffi-chibi.stub ${CC} -Werror -g3 -o retropikzel/pffi/pffi-chibi.so \ src/pffi-chibi.c \ -fPIC \ @@ -15,7 +15,7 @@ chibi: gauche: CFLAGS="-I./include" gauche-package compile \ - --verbose --srcdir=src retropikzel-pffi-gauche gauche.c gauchelib.scm + --verbose --srcdir=src retropikzel-pffi-gauche pffi-gauche.c gauchelib.scm jenkinsfile: gosh -r7 -I ./snow build.scm diff --git a/include/libtest.h b/include/libtest.h new file mode 100644 index 0000000..86e229d --- /dev/null +++ b/include/libtest.h @@ -0,0 +1,15 @@ +void print_string_pointer(char* p); +void print_offsets(); +void check_offset(int member_index, int offset); +struct test* init_struct(struct test* test); +struct color { + int8_t r; + int8_t g; + int8_t b; + int8_t a; +}; +int color_check(struct color* test); +int color_check_by_value(struct color color); +int test_check(struct test* test); +int test_check_by_value(struct test test); +struct test* test_new(); diff --git a/include/pffi-gauche.h b/include/pffi-gauche.h new file mode 100644 index 0000000..e3f9d4a --- /dev/null +++ b/include/pffi-gauche.h @@ -0,0 +1,36 @@ +/* + * spigot.h - calculate pi and e by spigot algorithm + * + * Written by Shiro Kawai (shiro@acm.org) + * I put this program in public domain. Use it as you like. + */ + +extern ScmObj size_of_int8(); +extern ScmObj size_of_uint8(); +extern ScmObj size_of_int16(); +extern ScmObj size_of_uint16(); +extern ScmObj size_of_int32(); +extern ScmObj size_of_uint32(); +extern ScmObj size_of_int64(); +extern ScmObj size_of_uint64(); +extern ScmObj size_of_char(); +extern ScmObj size_of_unsigned_char(); +extern ScmObj size_of_short(); +extern ScmObj size_of_unsigned_short(); +extern ScmObj size_of_int(); +extern ScmObj size_of_unsigned_int(); +extern ScmObj size_of_long(); +extern ScmObj size_of_unsigned_long(); +extern ScmObj size_of_float(); +extern ScmObj size_of_double(); +extern ScmObj size_of_string(); +extern ScmObj size_of_pointer(); +extern ScmObj size_of_void(); +extern ScmObj shared_object_load(ScmString* path); +extern ScmObj pointer_null(); +extern ScmObj is_pointer_null(); +extern ScmObj pointer_allocate(int size); +extern ScmObj is_pointer(ScmObj pointer); +extern ScmObj pointer_free(ScmObj pointer); +extern ScmObj Spigot_calculate_e(int digits); +extern void Scm_Init_gauchelib(void); diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 567f1ab..dc28711 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -173,17 +173,16 @@ (gauche base) (retropikzel pffi gauche)) (export pffi-init - ;pffi-size-of - spigot-calculate-pi + pffi-size-of pffi-type? pffi-align-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load - ;pffi-pointer-null - ;pffi-pointer-null? - ;pffi-pointer-allocate - ;pffi-pointer? - ;pffi-pointer-free + pffi-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 diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index aedb5bc..a7cc91e 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -1,16 +1,61 @@ (define-module retropikzel.pffi.gauche - (export spigot-calculate-pi + (export size-of-type + pffi-shared-object-load + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer? + pffi-pointer-free spigot-calculate-e)) (select-module retropikzel.pffi.gauche) - (dynamic-load "retropikzel-pffi-gauche") -;(define-module retropikzel.pffi.gauche (export pffi-foo)) -;(dynamic-load "retropikzel/pffi/pffi-gauche" :init-function "Scm__Init_pffi_2dgauche") -;(select-module pffi-gauche) - -;(pffi-foo 10) - -#;(define size-of-type +(define size-of-type (lambda (type) - (cond ((equal? type 'int8) 1)))) + (cond + ((equal? type 'int8) (size-of-int8)) + ((equal? type 'uint8) (size-of-uint8)) + ((equal? type 'int16) (size-of-int16)) + ((equal? type 'uint16) (size-of-uint16)) + ((equal? type 'int32) (size-of-int32)) + ((equal? type 'uint32) (size-of-uint32)) + ((equal? type 'int64) (size-of-int64)) + ((equal? type 'uint64) (size-of-uint64)) + ((equal? type 'char) (size-of-char)) + ((equal? type 'unsigned-char) (size-of-unsigned-char)) + ((equal? type 'short) (size-of-short)) + ((equal? type 'unsigned-short) (size-of-unsigned-short)) + ((equal? type 'int) (size-of-int)) + ((equal? type 'unsigned-int) (size-of-unsigned-int)) + ((equal? type 'long) (size-of-long)) + ((equal? type 'unsigned-long) (size-of-unsigned-long)) + ((equal? type 'float) (size-of-float)) + ((equal? type 'double) (size-of-double)) + ((equal? type 'string) (size-of-string)) + ((equal? type 'pointer) (size-of-pointer)) + ((equal? type 'void) (size-of-void))))) + +(define pffi-shared-object-load + (lambda (headers path . options) + (shared-object-load path))) + +(define pffi-pointer-null + (lambda () + (pointer-null))) + +(define pffi-pointer-null? + (lambda (pointer) + (pointer-null? pointer))) + +(define pffi-pointer-allocate + (lambda (size) + (pointer-allocate size))) + +(define pffi-pointer? + (lambda (pointer) + (pointer? pointer))) + +(define pffi-pointer-free + (lambda (pointer) + (pointer-free pointer))) + diff --git a/src/gauchelib.scm b/src/gauchelib.scm index beed4bb..e101b7d 100644 --- a/src/gauchelib.scm +++ b/src/gauchelib.scm @@ -13,8 +13,33 @@ (inline-stub (.include "pffi-gauche.h") - (define-cproc spigot-calculate-pi (digits::) Spigot_calculate_pi) - (define-cproc spigot-calculate-e (digits::) Spigot_calculate_e) - ) + (define-cproc size-of-int8 () size_of_int8) + (define-cproc size-of-uint8 () size_of_uint8) + (define-cproc size-of-int16 () size_of_int16) + (define-cproc size-of-uint16 () size_of_int16) + (define-cproc size-of-int32 () size_of_int32) + (define-cproc size-of-uint32 () size_of_int32) + (define-cproc size-of-int64 () size_of_int64) + (define-cproc size-of-uint64 () size_of_int64) + (define-cproc size-of-char () size_of_char) + (define-cproc size-of-unsigned-char () size_of_unsigned_char) + (define-cproc size-of-short () size_of_short) + (define-cproc size-of-unsigned-short () size_of_unsigned_short) + (define-cproc size-of-int () size_of_int) + (define-cproc size-of-unsigned-int () size_of_unsigned_int) + (define-cproc size-of-long () size_of_long) + (define-cproc size-of-unsigned-long () size_of_unsigned_long) + (define-cproc size-of-float () size_of_float) + (define-cproc size-of-double () size_of_double) + (define-cproc size-of-string () size_of_string) + (define-cproc size-of-pointer () size_of_pointer) + (define-cproc size-of-void () size_of_void) + (define-cproc shared-object-load (path::) shared_object_load) + (define-cproc pointer-null () pointer_null) + (define-cproc pointer-null? (pointer) is_pointer_null) + (define-cproc pointer-allocate (size::) pointer_allocate) + (define-cproc pointer? (pointer) is_pointer) + (define-cproc pointer-free (pointer) pointer_free) + (define-cproc spigot-calculate-e (digits::) Spigot_calculate_e)) ;; You can define Scheme functions here if you want. diff --git a/src/libtest.c b/src/libtest.c new file mode 100644 index 0000000..43b3bf6 --- /dev/null +++ b/src/libtest.c @@ -0,0 +1,267 @@ +#include +#include +#include +#include +#include + +#if defined(_MSC_VER) +#define EXPORT __declspec(dllexport) +#define IMPORT __declspec(dllimport) +#elif defined(__GNUC__) +#define EXPORT __attribute__((visibility("default"))) +#define IMPORT +#else +#define EXPORT +#define IMPORT +#pragma warning Unknown dynamic link import/export semantics. +#endif + +struct color { + int8_t r; + int8_t g; + int8_t b; + int8_t a; +}; + +struct test { + int8_t a; + char b; + double c; + char d; + void* e; + float f; + char* g; + int8_t h; + void* i; + int j; + int k; + int l; + double m; + float n; +}; + +void print_string_pointer(char* p) { + printf("C print_string_pointer: %s\n", p); +} + +void print_offsets() { + printf("C: Offset of a = %u\n", offsetof(struct test, a)); + printf("C: Offset of b = %u\n", offsetof(struct test, b)); + printf("C: Offset of c = %u\n", offsetof(struct test, c)); + printf("C: Offset of d = %u\n", offsetof(struct test, d)); + printf("C: Offset of e = %u\n", offsetof(struct test, e)); + printf("C: Offset of f = %u\n", offsetof(struct test, f)); + printf("C: Offset of g = %u\n", offsetof(struct test, g)); + printf("C: Offset of h = %u\n", offsetof(struct test, h)); + printf("C: Offset of i = %u\n", offsetof(struct test, i)); + printf("C: Offset of j = %u\n", offsetof(struct test, j)); + printf("C: Offset of k = %u\n", offsetof(struct test, k)); + printf("C: Offset of l = %u\n", offsetof(struct test, l)); + printf("C: Offset of m = %u\n", offsetof(struct test, m)); + printf("C: Offset of n = %u\n", offsetof(struct test, n)); +} + +void check_offset(int member_index, int offset) { + if (member_index == 1) { + int true_offset = offsetof(struct test, a); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 2) { + int true_offset = offsetof(struct test, b); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 3) { + int true_offset = offsetof(struct test, c); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 4) { + int true_offset = offsetof(struct test, d); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 5) { + int true_offset = offsetof(struct test, e); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 6) { + int true_offset = offsetof(struct test, f); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 7) { + int true_offset = offsetof(struct test, g); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 8) { + int true_offset = offsetof(struct test, h); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 9) { + int true_offset = offsetof(struct test, i); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 10) { + int true_offset = offsetof(struct test, j); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 11) { + int true_offset = offsetof(struct test, k); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 12) { + int true_offset = offsetof(struct test, l); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 13) { + int true_offset = offsetof(struct test, m); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } else if (member_index == 14) { + int true_offset = offsetof(struct test, n); + printf("C: Checking that member_index : %u, is offset: %u, true offset: %u\n", member_index, offset, true_offset); + fflush(stdout); + assert(true_offset == offset); + } +} + + +EXPORT struct test* init_struct(struct test* test) { + print_offsets(); + test->a = 1; + test->b = 'b'; + test->c = 3.0; + test->d = 'd'; + test->e = NULL; + test->f = 6.0; + char* foo = malloc(sizeof("FOOBAR")); + snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); + test->g = foo; + test->h = 8; + test->i = NULL; + test->j = 10; + test->k = 11; + test->l = 12; + test->m = 13; + test->n = 14; +} + +EXPORT int color_check(struct color* color) { + printf("C: Value of r is %c\n", color->r); + assert(color->r == 100); + printf("C: Value of g is %c\n", color->g); + assert(color->g == 100); + printf("C: Value of b is %c\n", color->b); + assert(color->b == 100); + printf("C: Value of a is %c\n", color->a); + assert(color->a == 100); + return 0; +} + +EXPORT int color_check_by_value(struct color color) { + printf("C: Value of r is %i\n", color.r); + assert(color.r == 100); + printf("C: Value of g is %i\n", color.g); + assert(color.g == 101); + printf("C: Value of b is %i\n", color.b); + assert(color.b == 102); + printf("C: Value of a is %i\n", color.a); + assert(color.a == 103); + return 0; +} + +EXPORT int test_check(struct test* test) { + print_offsets(); + printf("C: Value of a is %c\n", test->a); + assert(test->a == 1); + printf("C: Value of b is %c\n", test->b); + assert(test->b == 'b'); + printf("C: Value of c is %lf\n", test->c); + assert(test->c == 3.0); + printf("C: Value of d is %c\n", test->d); + assert(test->d == 'd'); + printf("C: Value of e is %s\n", test->e); + assert(test->e == NULL); + printf("C: Value of f is %f\n", test->f); + assert(test->f == 6.0); + printf("C: Value of g is %f\n", test->g); + assert(strcmp(test->g, "foo") == 0); + printf("C: Value of h is %i\n", test->h); + assert(test->h == 8); + printf("C: Value of i is %s\n", test->i); + assert(test->i == NULL); + printf("C: Value of j is %i\n", test->j); + assert(test->j == 10); + printf("C: Value of k is %i\n", test->k); + assert(test->k == 11); + printf("C: Value of l is %i\n", test->l); + assert(test->l == 12); + printf("C: Value of m is %i\n", test->m); + assert(test->m == 13); + printf("C: Value of n is %i\n", test->n); + assert(test->n == 14); +} + +EXPORT int test_check_by_value(struct test test) { + print_offsets(); + printf("C: Value of a is %i\n", test.a); + //assert(test.a == 1); + printf("C: Value of b is %c\n", test.b); + //assert(test.b == 'b'); + printf("C: Value of c is %lf\n", test.c); + //assert(test.c == 3.0); + printf("C: Value of d is %c\n", test.d); + //assert(test.d == 'd'); + printf("C: Value of e is %s\n", test.e); + //assert(test.e == NULL); + printf("C: Value of f is %f\n", test.f); + //assert(test.f == 6.0); + printf("C: Value of g is %f\n", test.g); + //assert(strcmp(test.g, "foo") == 0); + printf("C: Value of h is %i\n", test.h); + //assert(test.h == 8); + printf("C: Value of i is %s\n", test.i); + //assert(test.i == NULL); + printf("C: Value of j is %i\n", test.j); + //assert(test.j == 10); + printf("C: Value of k is %i\n", test.k); + //assert(test.k == 11); + printf("C: Value of l is %i\n", test.l); + //assert(test.l == 12); + printf("C: Value of m is %i\n", test.m); + //assert(test.m == 13); + printf("C: Value of n is %i\n", test.n); + //assert(test.n == 14); +} + +EXPORT struct test* test_new() { + print_offsets(); + struct test* t = malloc(sizeof(struct test)); + t->a = 1; + t->b = 'b'; + t->c = 3.0; + t->d = 'd'; + t->e = NULL; + t->f = 6.0; + char* foo = malloc(sizeof("FOOBAR")); + snprintf(foo, sizeof("FOOBAR") + 1, "FOOBAR"); + t->g = foo; + t->h = 8; + t->i = NULL; + t->j = 10; + t->k = 11; + t->l = 12; + t->m = 13; + t->n = 14; + return t; +} diff --git a/src/pffi-chibi.stub b/src/pffi-chibi.stub new file mode 100644 index 0000000..e0b64f3 --- /dev/null +++ b/src/pffi-chibi.stub @@ -0,0 +1,265 @@ +; 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 "int pointer_address(void* pointer) { return (intptr_t)&pointer; }") +(define-c int (pointer-address pointer_address) ((maybe-null void*))) + +(c-declare "void pointer_free(void* pointer) { free(pointer); }") +(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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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*)pointer + 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*)((char*)pointer + 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*)((char*)pointer + 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) { *(unsigned short*)((char*)pointer + 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*)((char*)pointer + 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) { *(unsigned int*)((char*)pointer + 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*)((char*)pointer + 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) { *(unsigned long*)((char*)pointer + 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*)((char*)pointer + 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*)((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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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) { 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 +(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); + 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(sexp proc) { + if(sexp_procedurep(proc) == 1) { + sexp debug1 = sexp_procedure_code(proc); + printf(\"HERE: %u\\n\", sexp_bytecode_length(debug1)); + } + return (void*)proc; + }") +(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/src/pffi-gauche.c b/src/pffi-gauche.c new file mode 100644 index 0000000..7e6162f --- /dev/null +++ b/src/pffi-gauche.c @@ -0,0 +1,142 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); } +ScmObj size_of_uint8() { return Scm_MakeInteger(sizeof(uint8_t)); } +ScmObj size_of_int16() { return Scm_MakeInteger(sizeof(int16_t)); } +ScmObj size_of_uint16() { return Scm_MakeInteger(sizeof(uint16_t)); } +ScmObj size_of_int32() { return Scm_MakeInteger(sizeof(int32_t)); } +ScmObj size_of_uint32() { return Scm_MakeInteger(sizeof(uint32_t)); } +ScmObj size_of_int64() { return Scm_MakeInteger(sizeof(int64_t)); } +ScmObj size_of_uint64() { return Scm_MakeInteger(sizeof(uint64_t)); } +ScmObj size_of_char() { return Scm_MakeInteger(sizeof(char)); } +ScmObj size_of_unsigned_char() { return Scm_MakeInteger(sizeof(unsigned char)); } +ScmObj size_of_short() { return Scm_MakeInteger(sizeof(short)); } +ScmObj size_of_unsigned_short() { return Scm_MakeInteger(sizeof(unsigned short)); } +ScmObj size_of_int() { return Scm_MakeInteger(sizeof(int)); } +ScmObj size_of_unsigned_int() { return Scm_MakeInteger(sizeof(unsigned int)); } +ScmObj size_of_long() { return Scm_MakeInteger(sizeof(long)); } +ScmObj size_of_unsigned_long() { return Scm_MakeInteger(sizeof(unsigned long)); } +ScmObj size_of_float() { return Scm_MakeInteger(sizeof(float)); } +ScmObj size_of_double() { return Scm_MakeInteger(sizeof(double)); } +ScmObj size_of_string() { return Scm_MakeInteger(sizeof(char*)); } +ScmObj size_of_pointer() { return Scm_MakeInteger(sizeof(void*)); } +ScmObj size_of_void() { return Scm_MakeInteger(sizeof(void)); } + +ScmModule* module = NULL; + +void print_shared_object(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) { + printf("\n"); +} + +ScmObj shared_object_load(ScmString* scm_path) { + const ScmStringBody* body = SCM_STRING_BODY(scm_path); + const char* path = SCM_STRING_BODY_START(body); + void* shared_object = dlopen(path, RTLD_NOW); + ScmClass* class = Scm_MakeForeignPointerClass(module, "", print_shared_object, NULL, 0); + ScmObj scm_shared_object = Scm_MakeForeignPointer(class, shared_object); + printf("Loading path: %s\n", path); + return scm_shared_object; +} + +void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) { + printf("\n"); +} + +ScmObj pointer_null() { + ScmClass* class = Scm_MakeForeignPointerClass(module, "", print_pointer, NULL, 0); + ScmObj pointer = Scm_MakeForeignPointer(class, NULL); + return pointer; +} + +ScmObj is_pointer_null(ScmObj pointer) { + if(!SCM_FOREIGN_POINTER_P(pointer)) { + return SCM_FALSE; + } + if(SCM_FOREIGN_POINTER_REF(void*, pointer) == NULL) { + return SCM_TRUE; + } else { + return SCM_FALSE; + } +} + +ScmObj pointer_allocate(int size) { + ScmClass* class = Scm_MakeForeignPointerClass(module, "", print_pointer, NULL, 0); + ScmObj pointer = Scm_MakeForeignPointer(class, malloc(size)); + return pointer; +} + +ScmObj is_pointer(ScmObj pointer) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + return SCM_TRUE; + } else { + return SCM_FALSE; + } +} + +ScmObj pointer_free(ScmObj pointer) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + free(SCM_FOREIGN_POINTER_REF(void*, pointer)); + } +} + +ScmObj Spigot_calculate_e(int digits) +{ + int k, i, j, l, b, q, r, *array; + ScmObj rvec, *relts; + + if (digits <= 0) Scm_Error("digits must be a positive integer"); + + /* Scheme vector to keep the result */ + rvec = Scm_MakeVector(digits, SCM_MAKE_INT(0)); + relts = SCM_VECTOR_ELEMENTS(rvec); + + /* Prepare the array for variable base system */ + k = (int)floor(digits * 3.3219280948873626); + array = SCM_NEW_ATOMIC2(int *, (k+1)*sizeof(int)); + for (i=0; i0; j--) { + q += array[j] * 10; + array[j] = q % j; + q /= j; + } + r = b + q/10; + b = q % 10; + /* Here, we have the i-th digit in r. + In rare occasions, r becomes more than 10, and we need to back-up + to increment the previous digit(s). (It's rarely the case that + this back-up cascades for more than one digit). */ + if (r < 10) { + relts[i] = SCM_MAKE_INT(r); + } else { + relts[i] = SCM_MAKE_INT(r%10); + for (l=i-1, r/=10; r && l>=0; l--, r/=10) { + r += SCM_INT_VALUE(relts[l]); + relts[l] = SCM_MAKE_INT(r%10); + } + } + } + return rvec; +} + +/* + * Module initialization function. + * This is called when math--spigot.so is dynamically loaded into gosh. + */ +void Scm_Init_retropikzel_pffi_gauche(void) +{ + SCM_INIT_EXTENSION(retropikzel.pffi.gauche); + module = SCM_MODULE(SCM_FIND_MODULE("retropikzel.pffi.gauche", TRUE)); + Scm_Init_gauchelib(); +} diff --git a/test.scm b/test.scm index 64dc784..6e60dc8 100755 --- a/test.scm +++ b/test.scm @@ -57,10 +57,7 @@ (print-header 'pffi-init) (pffi-init) -(write (spigot-calculate-pi 10)) -(newline) -(exit 0) ;; pffi-type? (print-header 'pffi-type?)