mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
Forgot to add FFI test script.
This commit is contained in:
Alex Shinn
parent
a32ae03add
commit
9f56df7de2
1 changed files with 351 additions and 0 deletions
351
tests/ffi/ffi-tests.scm
Normal file
351
tests/ffi/ffi-tests.scm
Normal file
|
|
@ -0,0 +1,351 @@
|
|||
|
||||
(import (chibi) (chibi ast) (chibi process) (chibi filesystem) (chibi test))
|
||||
|
||||
(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"))
|
||||
(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" "-O0 -L. -Iinclude" stub-file)))
|
||||
(cond
|
||||
((zero? (cadr res))
|
||||
(load lib-file)
|
||||
tests ...
|
||||
;; cleanup but leave the stub file for reference
|
||||
(delete-file 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;
|
||||
}
|
||||
")
|
||||
(define-c int zero ())
|
||||
(define-c int cube (int))
|
||||
(define-c int sub (int int)))
|
||||
(test 0 (zero))
|
||||
(test 4 (sub 7 3))
|
||||
(test -27 (cube -3))
|
||||
(test -3 (sub (zero) 3)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; More detailed tests on integer conversions and overflow.
|
||||
|
||||
(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;
|
||||
|
||||
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);
|
||||
}
|
||||
")
|
||||
(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 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))
|
||||
;; TODO: struct means no pointer
|
||||
;;(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))
|
||||
)
|
||||
(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)))
|
||||
;; 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)))
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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-end)
|
||||
Loading…
Add table
Reference in a new issue