From b31d3cd92c9621e25ffd74e6373f4791c59f06fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Aug 2005 06:45:29 +0000 Subject: [PATCH] Some initial tests for foreign svn: r668 --- collects/tests/mzscheme/README | 4 +- collects/tests/mzscheme/all.ss | 7 +- collects/tests/mzscheme/foreign-test.c | 52 ++++ collects/tests/mzscheme/foreign-test.ss | 341 ++++++++++++++++++++++++ 4 files changed, 399 insertions(+), 5 deletions(-) create mode 100644 collects/tests/mzscheme/foreign-test.c create mode 100644 collects/tests/mzscheme/foreign-test.ss diff --git a/collects/tests/mzscheme/README b/collects/tests/mzscheme/README index 2b66d093d8..c4394c633c 100644 --- a/collects/tests/mzscheme/README +++ b/collects/tests/mzscheme/README @@ -7,7 +7,7 @@ Test failures may cause the test to stop before finishing, but most test failures will let the test continue, and a summary message at the end will enummerate the failures that occurred. -Some files are directories are created (in the current directory) +Some files and directories are created (in the current directory) during the run. The files are named "tmp" where is a number. The directory is named "deep". If the test suite passes, the directory should be removed, but some "tmp" files will remain. (The "tmp" @@ -26,7 +26,7 @@ Run 3 copies of the test suite concurrently in separate threads: > (load "PATHTOHERE/parallel.ss") -Please report bugs using +Please report bugs using Help Desk, or http://bugs.plt-scheme.org/ or (as a last resort) send mail to scheme@plt-scheme.org diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss index ce0bbac6bc..fec7455bd2 100644 --- a/collects/tests/mzscheme/all.ss +++ b/collects/tests/mzscheme/all.ss @@ -1,4 +1,5 @@ -(load-relative "mz.ss") -(load-relative "mzlib.ss") -(load-relative "boundmap-test.ss") \ No newline at end of file +;; (load-relative "mz.ss") +;; (load-relative "mzlib.ss") +;; (load-relative "boundmap-test.ss") +(load-relative "foreign-test.ss") diff --git a/collects/tests/mzscheme/foreign-test.c b/collects/tests/mzscheme/foreign-test.c new file mode 100644 index 0000000000..094d76b04f --- /dev/null +++ b/collects/tests/mzscheme/foreign-test.c @@ -0,0 +1,52 @@ +#include + +typedef signed char byte; + +int add1_int_int (int x) { return x + 1; } +int add1_byte_int (byte x) { return x + 1; } +byte add1_int_byte (int x) { return x + 1; } +byte add1_byte_byte (byte x) { return x + 1; } +int decimal_int_int_int (int x, int y) { return 10*x + y; } +int decimal_byte_int_int (byte x, int y) { return 10*x + y; } +int decimal_int_byte_int (int x, byte y) { return 10*x + y; } +int decimal_byte_byte_int (byte x, byte y) { return 10*x + y; } +byte decimal_int_int_byte (int x, int y) { return 10*x + y; } +byte decimal_byte_int_byte (byte x, int y) { return 10*x + y; } +byte decimal_int_byte_byte (int x, byte y) { return 10*x + y; } +byte decimal_byte_byte_byte (byte x, byte y) { return 10*x + y; } + +int callback3_int_int_int (int(*f)(int)) { return f(3); } +int callback3_byte_int_int (int(*f)(byte)) { return f(3); } +int callback3_int_byte_int (byte(*f)(int)) { return f(3); } +int callback3_byte_byte_int (byte(*f)(byte)) { return f(3); } +byte callback3_int_int_byte (int(*f)(int)) { return f(3); } +byte callback3_byte_int_byte (int(*f)(byte)) { return f(3); } +byte callback3_int_byte_byte (byte(*f)(int)) { return f(3); } +byte callback3_byte_byte_byte (byte(*f)(byte)) { return f(3); } + +int g1; +int curry_return_int_int (int x) { return g1 + x; } +int curry_return_byte_int (byte x) { return g1 + x; } +byte curry_return_int_byte (int x) { return g1 + x; } +byte curry_return_byte_byte (byte x) { return g1 + x; } +void* curry_int_int_int (int x) { g1 = x; return &curry_return_int_int; } +void* curry_byte_int_int (int x) { g1 = x; return &curry_return_int_int; } +void* curry_int_byte_int (int x) { g1 = x; return &curry_return_byte_int; } +void* curry_byte_byte_int (int x) { g1 = x; return &curry_return_byte_int; } +void* curry_int_int_byte (int x) { g1 = x; return &curry_return_int_byte; } +void* curry_byte_int_byte (int x) { g1 = x; return &curry_return_int_byte; } +void* curry_int_byte_byte (int x) { g1 = x; return &curry_return_byte_byte; } +void* curry_byte_byte_byte(int x) { g1 = x; return &curry_return_byte_byte; } + +int g2; +int ho_return(int x) { return g2 + x; } +void* ho(int(*f)(int), int x) { g2 = f(x); return ho_return; } + + +void *g3 = NULL; +int use_g3(int x) { return ((int(*)(int))g3)(x); } + +/* typedef int(*int2int)(int); */ +/* typedef int2int(*int_to_int2int)(int); */ +/* int hoho(int x, int_to_int2int f) { */ +int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); } diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss new file mode 100644 index 0000000000..b8b6da9310 --- /dev/null +++ b/collects/tests/mzscheme/foreign-test.ss @@ -0,0 +1,341 @@ + +(load-relative "loadtest.ss") + +(SECTION 'foreign) + +(require (lib "foreign.ss")) +(unsafe!) + +(let ([big/little + (if (system-big-endian?) (lambda (x y) x) (lambda (x y) y))] + [p (malloc _int32)]) + (ptr-set! p _int32 0) + (test 0 ptr-ref p _int32) + (ptr-set! p _int32 16909060) + (test 16909060 ptr-ref p _int32) + (test 16909060 ptr-ref p _int32 0) + (test (big/little 1 4) ptr-ref p _int8 0) + (test (big/little 2 3) ptr-ref p _int8 1) + (test (big/little 3 2) ptr-ref p _int8 2) + (test (big/little 4 1) ptr-ref p _int8 3)) + +(require (lib "compile.ss" "dynext") (lib "link.ss" "dynext")) +(let ([c "foreign-test.c"] + [o "foreign-test.o"] + [so "foreign-test.so"]) + (when (file-exists? o) (delete-file o)) + (when (file-exists? so) (delete-file so)) + (compile-extension #t c o '()) + (link-extension #t (list o) so)) + +(let* ([lib (ffi-lib "./foreign-test.so")] + [ffi (lambda (name type) (get-ffi-obj name lib type))] + [test* (lambda (expected name type proc) + (test expected name (proc (ffi name type))))] + [t (lambda (expected name type . args) + (test* expected name type (lambda (p) (apply p args))))] + [tc (lambda (expected name type arg1 . args) + ;; curry first argument + (test* expected name type (lambda (p) (apply (p arg1) args))))] + [sqr (lambda (x) (* x x))]) + ;; --- + (t 2 'add1_int_int (_fun _int -> _int ) 1) + (t 2 'add1_byte_int (_fun _byte -> _int ) 1) + (t 2 'add1_int_byte (_fun _int -> _byte) 1) + (t 2 'add1_byte_byte (_fun _byte -> _byte) 1) + ;; --- + (t 12 'decimal_int_int_int (_fun _int _int -> _int ) 1 2) + (t 12 'decimal_byte_int_int (_fun _byte _int -> _int ) 1 2) + (t 12 'decimal_int_byte_int (_fun _int _byte -> _int ) 1 2) + (t 12 'decimal_byte_byte_int (_fun _byte _byte -> _int ) 1 2) + (t 12 'decimal_int_int_byte (_fun _int _int -> _byte) 1 2) + (t 12 'decimal_byte_int_byte (_fun _byte _int -> _byte) 1 2) + (t 12 'decimal_int_byte_byte (_fun _int _byte -> _byte) 1 2) + (t 12 'decimal_byte_byte_byte (_fun _byte _byte -> _byte) 1 2) + ;; --- + (t 9 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) sqr) + (t 9 'callback3_byte_int_int (_fun (_fun _byte -> _int ) -> _int ) sqr) + (t 9 'callback3_int_byte_int (_fun (_fun _int -> _byte) -> _int ) sqr) + (t 9 'callback3_byte_byte_int (_fun (_fun _byte -> _byte) -> _int ) sqr) + (t 9 'callback3_int_int_byte (_fun (_fun _int -> _int ) -> _byte) sqr) + (t 9 'callback3_byte_int_byte (_fun (_fun _byte -> _int ) -> _byte) sqr) + (t 9 'callback3_int_byte_byte (_fun (_fun _int -> _byte) -> _byte) sqr) + (t 9 'callback3_byte_byte_byte (_fun (_fun _byte -> _byte) -> _byte) sqr) + ;; --- + (tc 3 'curry_int_int_int (_fun _int -> (_fun _int -> _int)) 1 2) + (tc 3 'curry_byte_int_int (_fun _byte -> (_fun _int -> _int)) 1 2) + (tc 3 'curry_int_byte_int (_fun _int -> (_fun _byte -> _int)) 1 2) + (tc 3 'curry_byte_byte_int (_fun _byte -> (_fun _byte -> _int)) 1 2) + ;; --- + (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) + (lambda (p) ((p add1 3) 10))) + (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) + (lambda (p) ((p (ffi 'add1_int_int (_fun _int -> _int)) 3) 10))) + (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) + (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) + ;; --- + (set-ffi-obj! "g3" lib (_fun _int -> _int) add1) + (t 4 'use_g3 (_fun _int -> _int) 3) + (test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3))) + ;; --- + (test ((lambda (x f) ((f (+ x 1)) (- x 1))) + 3 (lambda (x) (lambda (y) (+ y (* x x))))) + 'hoho + ((ffi 'hoho (_fun _int (_fun _int -> (_fun _int -> _int)) -> _int)) + 3 (lambda (x) (lambda (y) (+ y (* x x)))))) + ;; --- + (test '(0 1 2 3 4 5 6 7 8 9) + 'qsort + ((get-ffi-obj 'qsort #f + (_fun (l : (_list io _int len)) + (len : _int = (length l)) + (size : _int = (ctype-sizeof _int)) + (compare : (_fun _pointer _pointer -> _int)) + -> _void -> l)) + '(7 1 2 3 5 6 4 8 0 9) + (lambda (x y) + (let ([x (ptr-ref x _int)] [y (ptr-ref y _int)]) + (cond [(< x y) -1] [(> x y) +1] [else 0]))))) + ) + +(report-errs) + + +#| --- ignore everything below --- + +The following is some random Scheme and C code, with some things that should be +added. + +------------------------------------------------------------------------------- +(define _foo (_list-struct (list _byte _int))) +(define foo-struct1 + (get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int))) +(define foo-struct2 + (get-ffi-obj "foo_struct2" "junk/foo.so" (_fun _foo -> _foo))) +(printf ">>> foo-struct1(32,23) = ~s\n" (foo-struct1 '(32 23))) +(printf ">>> foo-struct2(32,23) = ~s\n" (foo-struct2 '(32 23))) +(exit) + +(define-cstruct _foo ((b _byte) (i _int))) +(printf ">>> struct-type: ~s\n" _foo) +(printf ">>> size: ~s\n" (ctype-sizeof _foo)) +(printf ">>> alignment: ~s\n" (ctype-alignof _foo)) +(define foo-struct1 + (get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int))) +(define foo-struct2 + (get-ffi-obj "foo_struct2" "junk/foo.so" (_fun _foo -> _foo))) +(define foostruct (make-foo 32 23)) +(printf ">>> foostruct = ~s = ~s,~s\n" + foostruct (foo-b foostruct) (foo-i foostruct)) +(set-foo-b! foostruct 34) +(set-foo-i! foostruct 43) +(printf ">>> foostruct = ~s = ~s,~s\n" + foostruct (foo-b foostruct) (foo-i foostruct)) +(printf ">>> foo-struct1(34,43) = ~s\n" (foo-struct1 foostruct)) +(printf ">>> foo-struct2(34,43) = ~s\n" + (let ([x (foo-struct2 foostruct)]) (list (foo-b x) (foo-i x)))) +(exit) + +(printf ">>> g3 = ~s\n" + (get-ffi-obj "g3" "junk/foo.so" _string)) +(printf ">>> g3 := \"blah\" -> ~s\n" + (set-ffi-obj! "g3" "junk/foo.so" _string "blah")) +(printf ">>> g3 = ~s\n" + (get-ffi-obj "g3" "junk/foo.so" _string)) +(printf ">>> g3 := add1 -> ~s\n" + (set-ffi-obj! "g3" "junk/foo.so" _scheme add1)) +(printf ">>> g3 = ~s\n" + (get-ffi-obj "g3" "junk/foo.so" _scheme)) +(printf ">>> g3 := s->c[int->int](add1) -> ~s\n" + (set-ffi-obj! "g3" "junk/foo.so" (_fun _int -> _int) add1)) +(printf ">>> (ptr) g3 = ~s\n" + (get-ffi-obj "g3" "junk/foo.so" _pointer)) +(printf ">>> (int->int) g3 = ~s\n" + (get-ffi-obj "g3" "junk/foo.so" (_fun _int -> _int))) +(printf ">>> use_g3(3) = ~s\n" + ((get-ffi-obj "use_g3" "junk/foo.so" (_fun _int -> _int)) 3)) +(printf ">>> g3(3) = ~s\n" + ((ptr-ref (get-ffi-obj "g3" "junk/foo.so" _pointer) + (_fun _int -> _int)) + 3)) + +(define block (malloc 4 _int)) +(ptr-set! block _int 0 2) +(ptr-set! block _int 1 1) +(ptr-set! block _int 2 4) +(ptr-set! block _int 3 3) +(printf ">>> block= ~s\n" (list (ptr-ref block _int 0) + (ptr-ref block _int 1) + (ptr-ref block _int 2) + (ptr-ref block _int 3))) + +(printf ">>> foo_none() = ~s\n" + ((get-ffi-obj "foo_none" "./junk/foo.so" (_fun -> _void)))) +(printf ">>> sleep(1) = ~s\n" + ((get-ffi-obj "sleep" #f (_fun _int -> _void)) 1)) +(printf ">>> fprintf(stderr,\"...\",3) = ~s\n" + ((get-ffi-obj "fprintf" #f (_fun _pointer _string _int -> _void)) + (get-ffi-obj "stderr" #f _pointer) + "using fprintf on stderr with an argument: %d\n" + 3)) + +(define (foo-test name args type) + (define res (apply (get-ffi-obj name "junk/foo.so" type) args)) + (printf ">>> ~a~s -> ~s\n" name args res) + res) +(foo-test "foo_int" '(3) (_fun _int -> _int)) +(foo-test "foo_int" '(3) (_fun _fixint -> _fixint)) +(foo-test "foo_int3" '(1 2 3) (_fun _int _int _int -> _int)) +(foo-test "foo_int3" '(1 2 3) (_fun _fixint _fixint _fixint -> _fixint)) +(foo-test "foo_long3" '(1 2 3) (_fun _long _long _long -> _long)) +(foo-test "foo_long3" '(1 2 3) (_fun _fixnum _fixnum _fixnum -> _fixnum)) +(foo-test "foo_char" '(3) (_fun _byte -> _byte)) +(foo-test "foo_short" '(22) (_fun _word -> _word)) +(foo-test "foo_ushort" '(22) (_fun _ushort -> _ushort)) +(foo-test "foo_byte" '(22) (_fun _byte -> _byte)) +(foo-test "foo_ubyte" '(22) (_fun _ubyte -> _ubyte)) +(foo-test "foo_byte" '(156) (_fun _byte -> _byte)) +(foo-test "foo_ubyte" '(156) (_fun _ubyte -> _ubyte)) +(foo-test "foo_double" '(81.0) (_fun _double -> _double)) +(foo-test "foo_float" '(81.0) (_fun _float -> _float)) + +(exit) ;======================================================================= +(newline) +(define x1 "foo") +(define x2 (foo-test "foo_string" (list x1) '(string) 'string)) +(printf ">>> now x1 = ~s\n" x1) +(string-set! x2 1 #\X) +(foo-test "foo_string" '(#f) '(string) 'string) + +(newline) +(printf ">>> scheme_make_pair(1,2) -> ~s\n" + ((ffi-call (ffi-obj libself "scheme_make_pair") + '(scheme scheme) 'scheme) + 1 2)) + +(newline) +(printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int)) +'(let loop ((l '())) + (eprintf ">>> ~s\n" (length l)) + (when (> (length l) 50) + (set-cdr! (cddddr l) '()) + (collect-garbage)) + (sleep 1) + ;; behavior with flags of this: atomic -> much faster, uncollectable -> crash + (loop (cons (malloc 'byte 1000000) l))) +(define block1 (malloc 'int 4)) +(printf ">>> block1 = ~s\n" block1) +(ffi-ptr-set! block1 'ulong 0 67305985) +(printf ">>> first uint of block1 = ~s\n" (ffi-ptr-ref block1 'uint)) +(define block2 (malloc block1 'int 4)) +(printf ">>> first 4 bytes of block2 = ~s\n" + (list (ffi-ptr-ref block2 'ubyte 0) (ffi-ptr-ref block2 'ubyte 1) + (ffi-ptr-ref block2 'ubyte 2) (ffi-ptr-ref block2 'ubyte 3))) +(ffi-ptr-set! block1 'ulong 0 11) +(ffi-ptr-set! block1 'ulong 1 22) +(ffi-ptr-set! block1 'ulong 2 33) +(ffi-ptr-set! block1 'ulong 3 44) +(foo-test "foo_vect" (list block1) '(pointer) 'int) +;(ffi-ptr-set! block1 'ulong 'abs 1 22) +(printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0)) +(printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1)) +(printf ">>> [abs 1] -> ~s\n" (ffi-ptr-ref block1 'ulong 'abs 1)) +(printf ">>> [abs 4] -> ~s\n" (ffi-ptr-ref block1 'ulong 'abs 4)) +(printf ">>> ptr-equal? b1 b2 -> ~s\n" (ffi-equal-ptr? block1 block2)) +(printf ">>> ptr-equal? b1 NULL -> ~s\n" (ffi-equal-ptr? block1 #f)) +(printf ">>> ptr-equal? b1 b1 -> ~s\n" (ffi-equal-ptr? block1 block1)) +(printf ">>> ptr-equal? NULL NULL -> ~s\n" (ffi-equal-ptr? #f #f)) + +(newline) +(define (final x) (printf "GC>>> ~s[0]=~s\n" x (ffi-ptr-ref x 'ulong))) +(printf ">>> set finalizer b1 -> ~s\n" (register-finalizer block1 final)) +(printf ">>> set finalizer b1 -> ~s\n" (register-finalizer block1 final)) +(printf ">>> set finalizer b2 -> ~s\n" (register-finalizer block2 final)) +(printf ">>> set finalizer b2 -> ~s\n" (register-finalizer block2 #f)) +(printf "Collecting garbage...\n") +(collect-garbage) +(printf "Clearing block1,2 and GCing again...\n") +(set! block1 #f) (set! block2 #f) +(collect-garbage) + +(newline) +(define (foo x) (+ x x x)) +(define a (malloc 'int 20)) +(ffi-ptr-set! a 'scheme foo) +(define b (ffi-ptr-ref a 'pointer)) +(ffi-ptr-set! a 'scheme 1 b) +(printf ">>> a[1] as a pointer object = ~s\n" (ffi-ptr-ref a 'scheme 1)) +(ffi-ptr-set! a 'pointer 1 b) +(printf ">>> a[1] as the pointer value = ~s\n" (ffi-ptr-ref a 'scheme 1)) +(printf ">>> (a[1] 12) -> ~s\n" ((ffi-ptr-ref a 'scheme 1) 12)) + +(newline) +(define c:int1 (make-ctype c:int sub1 add1)) +(define c:foo + (make-ctype + c:foo c:int1 + (lambda (x) + (unless (memq x '(foo1 foo2 bar1 bar2)) + (raise-type-error 'foo->int1 "foo" x)) + (cdr (assq x '((foo1 . 1) (foo2 . 2) (bar1 . 3) (bar2 . 4))))) + (lambda (x) + (cdr (or (assq x '((1 . foo1) (2 . foo2) (3 . bar1) (4 . bar2))) + '(#f . #f)))))) + +(printf ">>> sizeof(fooo) = ~s\n" (ffi-size-of 'fooo)) +(foo-test "foo_foo" (list 'foo1) '(fooo) 'fooo) +(foo-test "foo_foo" (list 'foo2) '(fooo) 'fooo) +(foo-test "foo_foo" (list 'bar1) '(fooo) 'fooo) +(foo-test "foo_foo" (list 'bar2) '(fooo) 'fooo) +(foo-test "foo_foo" (list 'fooo) '(fooo) 'fooo) +------------------------------------------------------------------------------- +void foo_none() { + fprintf(stderr, "===>>> in foo_none()\n"); +} + +#define U unsigned + +int foo_int (int x) { return x*2; } +int foo_int3 (int x, int y, int z) { return x*y*z; } +long foo_long3 (long x, long y, long z) { return x*y*z; } +char foo_char (char x) { return toupper(x); } +short foo_short (short x) { return x + 40000; } +U short foo_ushort (U short x) { return x + 40000; } +char foo_byte (char x) { return x + 200; } +U char foo_ubyte (U char x) { return x + 200; } +double foo_double (double x) { return sqrt(x); } +float foo_float (float x) { return sqrt(x); } + +char* foo_string (char* x) { + if (x==NULL) { + printf("===>>> Got NULL, HOME=\"%s\"\n", getenv("HOME")); + return NULL; + } else { + x[0] = toupper(x[0]); + return getenv("HOME"); + } +} + +int foo_vect(int x[]) { + return x[0]+x[1]+x[2]+x[3]; +} + +int foo_foo(int x) { return x^1; } + +typedef struct _char_int { + unsigned char a; + int b; +} char_int; + +int foo_struct1(char_int x) { + return ((int)x.a) + x.b; +} + +char_int foo_struct2(char_int x) { + char_int result; + result.a = (unsigned char)x.b; + result.b = (int)x.a; + return result; +} +------------------------------------------------------------------------------- +|#