- Started making progress with Gauche implementation
- Clean up the repository structure and C file names
This commit is contained in:
parent
cb9b2f87be
commit
842178129d
|
|
@ -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
|
||||
|
|
|
|||
4
Makefile
4
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
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
|
@ -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);
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -13,8 +13,33 @@
|
|||
|
||||
(inline-stub
|
||||
(.include "pffi-gauche.h")
|
||||
(define-cproc spigot-calculate-pi (digits::<int>) Spigot_calculate_pi)
|
||||
(define-cproc spigot-calculate-e (digits::<int>) 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::<string>) shared_object_load)
|
||||
(define-cproc pointer-null () pointer_null)
|
||||
(define-cproc pointer-null? (pointer) is_pointer_null)
|
||||
(define-cproc pointer-allocate (size::<int>) pointer_allocate)
|
||||
(define-cproc pointer? (pointer) is_pointer)
|
||||
(define-cproc pointer-free (pointer) pointer_free)
|
||||
(define-cproc spigot-calculate-e (digits::<int>) Spigot_calculate_e))
|
||||
|
||||
;; You can define Scheme functions here if you want.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,267 @@
|
|||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <assert.h>
|
||||
#include <string.h>
|
||||
#include <stddef.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
|
|
@ -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))
|
||||
|
|
@ -0,0 +1,142 @@
|
|||
#include <math.h>
|
||||
#include <stdint.h>
|
||||
#include <gauche.h>
|
||||
#include <gauche/extend.h>
|
||||
#include <gauche/module.h>
|
||||
#include <gauche/load.h>
|
||||
#include <pffi-gauche.h>
|
||||
#include <ffi.h>
|
||||
#include <dlfcn.h>
|
||||
|
||||
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("<pffi-shared-object>\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, "<pffi-shared-object>", 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("<pffi-pointer>\n");
|
||||
}
|
||||
|
||||
ScmObj pointer_null() {
|
||||
ScmClass* class = Scm_MakeForeignPointerClass(module, "<pffi-pointer>", 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, "<pffi-pointer>", 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; i<k; i++) array[i] = 1;
|
||||
array[k] = 2;
|
||||
|
||||
for (i=0, b=1; i<digits; i++) {
|
||||
q = 0;
|
||||
for (j=k; j>0; 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();
|
||||
}
|
||||
Loading…
Reference in New Issue