mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
cc23efac16
These ones are used to compute averages. If they are not initialized to zero, they might contain some garbage. In fact, they almost always do on platforms other that x86_64, failing the FFI tests. If optimizations are enabled, these tests usually fail on x86_64 too. The reason this went unnoticed is contrived set of coincidences.
648 lines
18 KiB
Scheme
648 lines
18 KiB
Scheme
|
|
(import (chibi) (chibi ast) (chibi match)
|
|
(chibi process) (chibi filesystem) (chibi test))
|
|
|
|
(define generated-shared-objects '())
|
|
|
|
(define (trash-shared-object! file)
|
|
(set! generated-shared-objects (cons file generated-shared-objects)))
|
|
|
|
(define (cleanup-shared-objects!)
|
|
(for-each (lambda (file) (protect (exn (else #f)) (delete-file file)))
|
|
generated-shared-objects))
|
|
|
|
(test-begin "ffi")
|
|
|
|
(define-syntax test-ffi
|
|
(syntax-rules ()
|
|
((test-ffi name-expr decls tests ...)
|
|
(let* ((name name-expr)
|
|
(stub-file (string-append "tests/ffi/" name ".stub"))
|
|
(c-file (string-append "tests/ffi/" name ".c"))
|
|
(lib-file
|
|
(string-append "tests/ffi/" name *shared-object-extension*)))
|
|
(call-with-output-file stub-file
|
|
(lambda (out) (write 'decls out) (newline out)))
|
|
(let ((res (system
|
|
"./chibi-scheme" "tools/chibi-ffi" "-c"
|
|
"-f" (string-append
|
|
"-O0 -L. -Iinclude"
|
|
(cond-expand
|
|
(boehm-gc
|
|
" -DSEXP_USE_BOEHM=1 -I/opt/local/include")
|
|
(else
|
|
"")))
|
|
stub-file)))
|
|
(cond
|
|
((zero? (cadr res))
|
|
(let ((orig-failures (test-failure-count)))
|
|
(load lib-file)
|
|
tests ...
|
|
;; on any failure leave the stub and c file for reference
|
|
(cond
|
|
((= orig-failures (test-failure-count))
|
|
(delete-file stub-file)
|
|
(delete-file c-file)))
|
|
(trash-shared-object! lib-file)))
|
|
(else
|
|
(test-assert (string-append "couldn't compile " name)
|
|
#f))))))))
|
|
|
|
;; A couple of dummy definitions to ensure the basic FFI and test
|
|
;; framework are working.
|
|
(test-ffi
|
|
"basic"
|
|
(begin
|
|
(c-declare "
|
|
int zero() {
|
|
return 0;
|
|
}
|
|
int cube(int x) {
|
|
return x * x * x;
|
|
}
|
|
int sub(int x, int y) {
|
|
return x - y;
|
|
}
|
|
int inc(int x, unsigned char y) {
|
|
return x + y;
|
|
}
|
|
")
|
|
(define-c int zero ())
|
|
(define-c int cube (int))
|
|
(define-c int sub (int int))
|
|
(define-c int inc (int unsigned-char)))
|
|
(test 0 (zero))
|
|
(test 4 (sub 7 3))
|
|
(test -27 (cube -3))
|
|
(test -3 (sub (zero) 3))
|
|
(test 6 (inc 5 1)))
|
|
|
|
(test-ffi
|
|
"params"
|
|
(begin
|
|
(c-declare "
|
|
int add4(int a, int b, int c, int d) {
|
|
return a+b+c+d;
|
|
}
|
|
int add5(int a, int b, int c, int d, int e) {
|
|
return a+b+c+d+e;
|
|
}
|
|
int add6(int a, int b, int c, int d, int e, int f) {
|
|
return a+b+c+d+e+f;
|
|
}
|
|
")
|
|
(define-c int add4 (int int int int))
|
|
(define-c int add5 (int int int int int))
|
|
(define-c int add6 (int int int int int int))
|
|
(define-c int (add3or4 "add4") (int int int (default 0 int)))
|
|
(define-c int (add4or5 "add5") (int int int int (default 0 int)))
|
|
(define-c int (add5or6 "add6") (int int int int int (default 0 int))))
|
|
(test 4321 (add4 1 20 300 4000))
|
|
(test 54321 (add5 1 20 300 4000 50000))
|
|
(test 654321 (add6 1 20 300 4000 50000 600000))
|
|
(test 321 (add3or4 1 20 300))
|
|
(test 4321 (add3or4 1 20 300 4000))
|
|
(test 4321 (add4or5 1 20 300 4000))
|
|
(test 54321 (add4or5 1 20 300 4000 50000))
|
|
(test 54321 (add5or6 1 20 300 4000 50000))
|
|
(test 654321 (add5or6 1 20 300 4000 50000 600000)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; More detailed tests on integer conversions and overflow.
|
|
|
|
(cond
|
|
((fixnum? (expt 2 60))
|
|
(test-ffi
|
|
"integers"
|
|
(begin
|
|
(c-declare "
|
|
unsigned hoge(unsigned x) {
|
|
return x;
|
|
}
|
|
long poge(long x) {
|
|
return x;
|
|
}
|
|
unsigned long piyo(unsigned long x) {
|
|
return x;
|
|
}
|
|
int ponyo(int x) {
|
|
return !x;
|
|
}
|
|
enum suuji {
|
|
ichi, ni, san, yon, go, roku, shichi, hachi, kyuu, juu
|
|
};
|
|
enum suuji tasu(enum suuji a, enum suuji b) {
|
|
return a + b;
|
|
}
|
|
")
|
|
(define-c unsigned hoge (unsigned))
|
|
(define-c long poge (long))
|
|
(define-c unsigned-long piyo (unsigned-long))
|
|
(define-c boolean ponyo (boolean))
|
|
(define-c-int-type suuji)
|
|
(define-c suuji tasu (suuji suuji)))
|
|
;; static cast
|
|
(test 4294967295 (hoge -1))
|
|
;; pass and return a signed bignum
|
|
(test -9223372036854775808 (poge (- (expt 2 63))))
|
|
;; pass and return an unsigned bignum
|
|
(test 4611686018427387904 (piyo (expt 2 62)))
|
|
;; booleans
|
|
(test #f (ponyo 'blah))
|
|
(test #t (ponyo #f))
|
|
;; int types
|
|
(test 5 (tasu 2 3))
|
|
)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; String passing, returning and mutation.
|
|
|
|
(test-ffi
|
|
"strings"
|
|
(begin
|
|
(c-declare "
|
|
int char_count(char* str, char ch) {
|
|
int count = 0;
|
|
if (!str) return -1;
|
|
while (*str) if (*str++ == ch) count++;
|
|
return count;
|
|
}
|
|
|
|
char message[] = \"Hello, World!\";
|
|
char* get_message() {
|
|
return message;
|
|
}
|
|
char* get_message2(int k) {
|
|
return k == 1 ? message : NULL;
|
|
}
|
|
|
|
void reverse_string(char* str) {
|
|
int lo=0, hi=strlen(str)-1, ch;
|
|
for (; lo < hi; lo++, hi--) {
|
|
ch = str[lo];
|
|
str[lo] = str[hi];
|
|
str[hi] = ch;
|
|
}
|
|
}
|
|
|
|
char test_cwd[] = \"/home/home/on/the/range\";
|
|
char* my_getcwd(char* buf, int len) {
|
|
char* res = test_cwd;
|
|
int needed = strlen(res);
|
|
if (needed >= len) return NULL;
|
|
strncpy(buf, res, needed+1);
|
|
return res;
|
|
}
|
|
")
|
|
|
|
(define-c int char_count (string char))
|
|
(define-c int (char_count2 char_count) (char* char))
|
|
(define-c int (char_count3 char_count) (char* int))
|
|
(define-c int (char_count4 char_count) ((maybe-null char*) int))
|
|
;; failures
|
|
;;(define-c int (char_count5 char_count) ((pointer char) int))
|
|
;;(define-c int (char_count6 char_count) ((array char) int))
|
|
(define-c string get_message ())
|
|
;; fix maybe-null results
|
|
;;(define-c (maybe-null string) get_message2 (int))
|
|
;; fix error results
|
|
;;(define-c non-null-string (get_message3 get_message2) (int))
|
|
(define-c (free string) strdup (string))
|
|
(define-c void reverse_string (string))
|
|
(define-c non-null-string my_getcwd
|
|
((result (array char (auto-expand arg1))) (value 4 int)))
|
|
(define-c non-null-string strncpy
|
|
(string string (value (string-length arg1) int)))
|
|
)
|
|
(test 1 (char_count "1-2" #\-))
|
|
(test 2 (char_count2 "1-2-3" #\-))
|
|
(test 3 (char_count3 "-1-2-3" #x2D))
|
|
(test -1 (char_count4 #f #x2D))
|
|
(test 4 (char_count4 "-1-2-3-" #x2D))
|
|
;;(test 5 (char_count5 "-1--2-3-" #x2D))
|
|
;;(test 5 (char_count5 "-1-2--3-" #x2D))
|
|
(test "Hello, World!" (get_message))
|
|
;; (test "Hello, World!" (get_message2 1))
|
|
;; (test #f (get_message2 0))
|
|
;; (test "Hello, World!" (get_message3 1))
|
|
;; (test #f (get_message3 0))
|
|
;; memory leak
|
|
(test "Hello, World!" (strdup "Hello, World!"))
|
|
(let ((str "abcdef"))
|
|
(reverse_string str)
|
|
(test "fedcba" str))
|
|
(test "/home/home/on/the/range" (my_getcwd))
|
|
(let ((str1 "abcdef")
|
|
(str2 "xxx"))
|
|
(test #t (strncpy str1 str2)) ;; update after fixing error results
|
|
(test "xxxdef" str1))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Structs and opaque types.
|
|
|
|
(test-ffi
|
|
"structs"
|
|
(begin
|
|
(c-declare "
|
|
struct Point {
|
|
double x, y;
|
|
};
|
|
struct Rectangle {
|
|
struct Point *top_left, *bottom_right;
|
|
};
|
|
struct Circle {
|
|
struct Point center;
|
|
double radius;
|
|
};
|
|
typedef struct {
|
|
short r, g, b;
|
|
} Color;
|
|
typedef struct {
|
|
struct Circle circle;
|
|
Color color;
|
|
} ColoredCircle;
|
|
|
|
struct Point make_point_struct(double x, double y) {
|
|
struct Point res;
|
|
res.x = x;
|
|
res.y = y;
|
|
return res;
|
|
}
|
|
|
|
void set_color(short r, short g, short b, Color* res) {
|
|
res->r = r;
|
|
res->g = g;
|
|
res->b = b;
|
|
}
|
|
|
|
Color* make_color(short r, short g, short b) {
|
|
Color* res = malloc(sizeof(Color));
|
|
if (res) {
|
|
res->r = r;
|
|
res->g = g;
|
|
res->b = b;
|
|
}
|
|
return res;
|
|
}
|
|
|
|
short color_red(Color* color) {
|
|
return color->r;
|
|
}
|
|
|
|
int draw_rect(struct Rectangle* rect, Color color) {
|
|
return 0;
|
|
}
|
|
|
|
double circle_area1(struct Circle* circ) {
|
|
return (circ->radius * circ->radius * 3.14);
|
|
}
|
|
double circle_area2(struct Circle circ) {
|
|
return circle_area1(&circ);
|
|
}
|
|
|
|
struct Point* centroid(struct Point** points, int num_points) {
|
|
struct Point* res;
|
|
double xsum=0, ysum=0;
|
|
int i;
|
|
for (i=0; i<num_points; ++i) {
|
|
xsum += points[i]->x;
|
|
ysum += points[i]->y;
|
|
}
|
|
res = malloc(sizeof(struct Point));
|
|
res->x = xsum / num_points;
|
|
res->y = ysum / num_points;
|
|
return res;
|
|
}
|
|
|
|
struct Point* centroid_null(struct Point** points) {
|
|
struct Point* res;
|
|
double xsum=0, ysum=0;
|
|
int i;
|
|
for (i=0; points[i]; ++i) {
|
|
xsum += points[i]->x;
|
|
ysum += points[i]->y;
|
|
}
|
|
res = malloc(sizeof(struct Point));
|
|
res->x = xsum / i;
|
|
res->y = ysum / i;
|
|
return res;
|
|
}
|
|
")
|
|
(define-c-struct Point
|
|
predicate: point?
|
|
constructor: (make-point x y)
|
|
(double x point-x point-x-set!)
|
|
(double y point-y point-y-set!))
|
|
(define-c (struct Point) make-point-struct (double double))
|
|
(define-c-struct Rectangle
|
|
predicate: rect?
|
|
constructor: (make-rect top_left bottom_right)
|
|
(Point top_left rect-top-left)
|
|
(Point bottom_right rect-bottom-right))
|
|
;; constructor with point fails
|
|
(define-c-struct Circle
|
|
predicate: circle?
|
|
constructor: (make-circle radius)
|
|
((struct Point) center circle-center)
|
|
(double radius circle-radius))
|
|
(define-c double circle_area1 (Circle))
|
|
(define-c double circle_area2 ((struct Circle)))
|
|
(define-c-type Color predicate: color?)
|
|
(define-c void set_color (short short short (result pointer Color)))
|
|
(define-c Color make_color (short short short))
|
|
(define-c short color_red ((pointer Color)))
|
|
;;(define-c errno draw_rect (Rectangle Color))
|
|
(define-c Point centroid ((array (pointer Point)) (value (length arg0) int)))
|
|
(define-c (maybe-null Point) centroid-null
|
|
((array (pointer Point) null)))
|
|
)
|
|
(test-assert (point? (make-point 1. 2.)))
|
|
(test 1. (point-x (make-point 1. 2.)))
|
|
(test 2. (point-y (make-point 1. 2.)))
|
|
(test 3. (point-x (let ((pt (make-point 1. 2.))) (point-x-set! pt 3.) pt)))
|
|
(test 1. (point-x (make-point-struct 1. 2.)))
|
|
(test 2. (point-y (make-point-struct 1. 2.)))
|
|
;; need constructor argument checking
|
|
;;(test-error (rect? (make-rect 1 2)))
|
|
;; gc miss - we don't preserve the pointers
|
|
(test-assert (rect? (make-rect (make-point 1. 2.) (make-point 3. 4.))))
|
|
(test-assert
|
|
(point? (rect-top-left
|
|
(make-rect (make-point 1. 2.) (make-point 3. 4.)))))
|
|
(test-assert
|
|
(point? (rect-bottom-right
|
|
(make-rect (make-point 1. 2.) (make-point 3. 4.)))))
|
|
(test 2.
|
|
(point-y (rect-top-left
|
|
(make-rect (make-point 1. 2.) (make-point 3. 4.)))))
|
|
(test 3.
|
|
(point-x (rect-bottom-right
|
|
(make-rect (make-point 1. 2.) (make-point 3. 4.)))))
|
|
(test-assert (circle? (make-circle 3.)))
|
|
(test 3.0 (circle-radius (make-circle 3.)))
|
|
(test 28.26 (circle_area1 (make-circle 3.)))
|
|
;;(test 28.26 (circle_area2 (make-circle 3.)))
|
|
(let ((circle (make-circle 3.)))
|
|
(point-x-set! (circle-center circle) 7.)
|
|
(point-y-set! (circle-center circle) 11.)
|
|
(test 7. (point-x (circle-center circle)))
|
|
(test 11. (point-y (circle-center circle))))
|
|
(test-assert (color? (set_color 1 2 3)))
|
|
(test 1 (color_red (set_color 1 2 3)))
|
|
(test-assert (color? (make_color 1 2 3)))
|
|
(test 1 (color_red (make_color 1 2 3)))
|
|
;; array of pointers
|
|
(let ((c (centroid (list (make-point 1. 1.)
|
|
(make-point 2. 2.)
|
|
(make-point 3. 3.)))))
|
|
(test 2. (point-x c))
|
|
(test 2. (point-y c)))
|
|
(let ((c (centroid-null (list (make-point 1. 1.)
|
|
(make-point 2. 2.)
|
|
(make-point 3. 3.)))))
|
|
(test 2. (point-x c))
|
|
(test 2. (point-y c)))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Exception wrapping.
|
|
|
|
(test-ffi
|
|
"exceptions"
|
|
(begin
|
|
(c-declare "
|
|
sexp usererror(sexp ctx, sexp self, const char* str) {
|
|
return sexp_maybe_wrap_error(ctx, sexp_user_exception(ctx, self, str, SEXP_NULL));
|
|
}
|
|
")
|
|
(define-c sexp usererror
|
|
((value ctx sexp) (value self sexp) string)))
|
|
(test-assert (exception? (usererror "BOOM!")))
|
|
(test-error (usererror 'not-a-string)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; More complex return parameters.
|
|
|
|
(test-ffi
|
|
"results"
|
|
(begin
|
|
(c-declare "
|
|
struct password {
|
|
char* pw_name;
|
|
char* pw_passwd;
|
|
};
|
|
char* etc_passwd[] = {
|
|
\"root:12345\",
|
|
\"joe:joe\",
|
|
};
|
|
int getpwnam_x(char* name, struct password* pwd, char* buf,
|
|
size_t bufsize, struct password** res) {
|
|
int i;
|
|
char* entry;
|
|
for (i=0; i < sizeof(etc_passwd) / sizeof(etc_passwd[0]); i++) {
|
|
entry = etc_passwd[i];
|
|
if (strstr(entry, name) == entry && entry[strlen(name)] == ':') {
|
|
strncpy(buf, entry, bufsize);
|
|
buf[strlen(entry)] = 0;
|
|
buf[strlen(name)] = 0;
|
|
pwd->pw_name = buf;
|
|
pwd->pw_passwd = buf + strlen(name) + 1;
|
|
*res = pwd;
|
|
return 0;
|
|
}
|
|
}
|
|
*res = NULL;
|
|
return -1;
|
|
}
|
|
")
|
|
(define-c-struct password
|
|
predicate: user?
|
|
(string pw_name user-name)
|
|
(string pw_passwd user-password))
|
|
(define-c errno getpwnam_x
|
|
(string
|
|
(result password)
|
|
(link string)
|
|
(value (string-length arg2) int)
|
|
(result pointer password))))
|
|
(test-assert (user? (car (getpwnam_x "root" (make-string 1024)))))
|
|
(test "root" (user-name (car (getpwnam_x "root" (make-string 1024)))))
|
|
(test "12345" (user-password (car (getpwnam_x "root" (make-string 1024)))))
|
|
(test-assert (user? (car (getpwnam_x "joe" (make-string 1024)))))
|
|
(test "joe" (user-name (car (getpwnam_x "joe" (make-string 1024)))))
|
|
(test "joe" (user-password (car (getpwnam_x "joe" (make-string 1024)))))
|
|
(test-not (getpwnam_x "hacker" (make-string 1024)))
|
|
)
|
|
|
|
(test-ffi
|
|
"error-results"
|
|
(begin
|
|
(c-declare "
|
|
char* err2str(int err) {
|
|
switch (err) {
|
|
case 0: return NULL;
|
|
case 1: return \"domain error\";
|
|
case 2: return \"bad things\";
|
|
}
|
|
return \"unknown error\";
|
|
}
|
|
|
|
int fib(int n, int* status) {
|
|
if (n < 0)
|
|
*status = 1;
|
|
if (n > 5)
|
|
*status = 2;
|
|
if (*status)
|
|
return 0;
|
|
if (n <= 1)
|
|
return 1;
|
|
return fib(n-1, status) + fib(n-2, status);
|
|
}
|
|
")
|
|
(define-c int fib
|
|
(int (error err2str int))))
|
|
(test 1 (fib 0))
|
|
(test 1 (fib 1))
|
|
(test 2 (fib 2))
|
|
(test 8 (fib 5))
|
|
(test "domain error"
|
|
(protect (exn (else (exception-message exn))) (fib -1)))
|
|
(test "bad things"
|
|
(protect (exn (else (exception-message exn))) (fib 10))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Field introspection and matching.
|
|
|
|
(test-ffi
|
|
"introspection"
|
|
(begin
|
|
(c-declare "
|
|
struct point3d {
|
|
int x, y, z;
|
|
};
|
|
")
|
|
(define-c-struct point3d
|
|
predicate: point3d?
|
|
constructor: (make-point3d x y z)
|
|
(int x point3d-x point3d-x-set!)
|
|
(int y point3d-y point3d-y-set!)
|
|
(int z point3d-z point3d-z-set!)))
|
|
(test-assert (point3d? (make-point3d 1 2 3)))
|
|
(test '(4 5 6)
|
|
(let ((pt (make-point3d 4 5 6)))
|
|
(list (point3d-x pt) (point3d-y pt) (point3d-z pt))))
|
|
(test '(7 8 9)
|
|
(match (make-point3d 7 8 9)
|
|
(($ point3d a b c) (list a b c))))
|
|
(test '(12 11 10)
|
|
(match (make-point3d 10 11 12)
|
|
((@ point3d (z a) (y b) (x c)) (list a b c))))
|
|
(test '(13 14 15 42)
|
|
(let ((pt (make-point3d 13 14 15)))
|
|
(match pt
|
|
((@ point3d (y b) (z (and (set! set-z!) orig-z)) (x c))
|
|
(set-z! 42)
|
|
(list c b orig-z (point3d-z pt))))))
|
|
)
|
|
|
|
(test-ffi
|
|
"virtual accessors"
|
|
(begin
|
|
(c-declare "
|
|
struct VirtComplex {
|
|
double r, phi;
|
|
};
|
|
double complex_real(struct VirtComplex* c) {
|
|
return c->r * cos(c->phi);
|
|
}
|
|
double complex_imag(struct VirtComplex* c) {
|
|
return c->r * sin(c->phi);
|
|
}
|
|
void complex_set(struct VirtComplex* c, double x, double y) {
|
|
c->r = sqrt(x*x + y*y);
|
|
c->phi = atan2(y, x);
|
|
}
|
|
void complex_real_set(struct VirtComplex* c, double x) {
|
|
complex_set(c, x, complex_imag(c));
|
|
}
|
|
void complex_imag_set(struct VirtComplex* c, double y) {
|
|
complex_set(c, complex_real(c), y);
|
|
}
|
|
")
|
|
(define-c-struct VirtComplex
|
|
predicate: virt-complex?
|
|
constructor: (make-virt-complex real imag)
|
|
(double real
|
|
(virt-complex-real function: "complex_real")
|
|
(virt-complex-real-set! function: "complex_real_set"))
|
|
(double imag
|
|
(virt-complex-imag function: "complex_imag")
|
|
(virt-complex-imag-set! function: "complex_imag_set"))
|
|
))
|
|
(test-assert (virt-complex? (make-virt-complex 1.0 2.0)))
|
|
(test 1.0 (virt-complex-real (make-virt-complex 1.0 2.0)))
|
|
(test 2.0 (virt-complex-imag (make-virt-complex 1.0 2.0)))
|
|
(let ((c (make-virt-complex 1.0 2.0)))
|
|
(test 1.0 (virt-complex-real c))
|
|
(virt-complex-real-set! c 3.0)
|
|
(test 3.0 (virt-complex-real c))
|
|
(test 2.0 (virt-complex-imag c)))
|
|
(test '(5 6 7)
|
|
(let ((c (make-virt-complex 5.0 6.0)))
|
|
(match c
|
|
((@ VirtComplex (real r) (imag (and (set! set-imag!) orig-i)))
|
|
(set-imag! 7.0)
|
|
(map inexact->exact
|
|
(map round (list r orig-i (virt-complex-imag c))))))))
|
|
)
|
|
|
|
(test-ffi
|
|
"nestedstructs"
|
|
(begin
|
|
(c-declare "
|
|
struct vec2 {
|
|
float x, y;
|
|
};
|
|
|
|
struct vec2box {
|
|
struct vec2 position;
|
|
};
|
|
")
|
|
(define-c-struct vec2
|
|
predicate: vec2?
|
|
constructor: (make-vec2 x y)
|
|
(float x vec2-x vec2-x!)
|
|
(float y vec2-y vec2-y!))
|
|
(define-c-struct vec2box
|
|
predicate: vec2box?
|
|
constructor: (make-vec2box position)
|
|
((struct vec2) position vec2box-pos vec2box-pos-set!)))
|
|
(test-assert (vec2? (make-vec2 17.0 23.0)))
|
|
(test '(17.0 23.0)
|
|
(let ((v (make-vec2 17.0 23.0)))
|
|
(list (vec2-x v) (vec2-y v))))
|
|
(test-assert (vec2box? (make-vec2box (make-vec2 17.0 23.0)))))
|
|
|
|
(test-ffi
|
|
"uniform vectors"
|
|
(begin
|
|
(c-declare "
|
|
float f32vector_ref(float* uv, int i) {
|
|
return uv[i];
|
|
}
|
|
void f32vector_set(float* uv, int i, float v) {
|
|
uv[i] = v;
|
|
}
|
|
")
|
|
(define-c float f32vector-ref (f32vector int))
|
|
(define-c void f32vector-set (f32vector int float)))
|
|
(let ((uv #f32(0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7)))
|
|
(test 0.3 (f32vector-ref uv 3))
|
|
(f32vector-set uv 3 3.14)
|
|
(test 3.14 (f32vector-ref uv 3))))
|
|
|
|
;; TODO: virtual method accessors
|
|
|
|
(cleanup-shared-objects!)
|
|
(test-end)
|