-USING: accessors alien alien.c-types alien.libraries
-alien.syntax arrays classes.struct combinators
-compiler continuations effects generalizations io
-io.backend io.pathnames io.streams.string kernel
-math memory namespaces namespaces.private parser
-quotations sequences specialized-arrays stack-checker
-stack-checker.errors system threads tools.test words
-alien.complex concurrency.promises ;
+USING: accessors alien alien.c-types alien.complex alien.data alien.libraries
+alien.syntax arrays byte-arrays classes classes.struct combinators
+combinators.extras compiler compiler.test concurrency.promises continuations
+destructors effects generalizations io io.backend io.pathnames
+io.streams.string kernel kernel.private libc layouts math math.bitwise
+math.private memory namespaces namespaces.private random parser quotations
+sequences slots.private specialized-arrays stack-checker stack-checker.errors
+system threads tools.test words ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
+! Make sure that invalid inputs don't pass the stack checker
+[ [ void { } "cdecl" alien-indirect ] infer ] must-fail
+[ [ "void" { } cdecl alien-indirect ] infer ] must-fail
+[ [ void* 3 cdecl alien-indirect ] infer ] must-fail
+[ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
+[ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
+
<<
: libfactor-ffi-tests-path ( -- string )
"resource:" absolute-path
{
- { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
+ { [ os windows? ] [ "libfactor-ffi-test.dll" ] }
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
LIBRARY: f-cdecl
-FUNCTION: void ffi_test_0 ;
+FUNCTION: void ffi_test_0 ( )
[ ] [ ffi_test_0 ] unit-test
-FUNCTION: int ffi_test_1 ;
+FUNCTION: int ffi_test_1 ( )
[ 3 ] [ ffi_test_1 ] unit-test
-FUNCTION: int ffi_test_2 int x int y ;
+[ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
+
+FUNCTION: int ffi_test_2 ( int x, int y )
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] must-fail
-FUNCTION: int ffi_test_3 int x int y int z int t ;
+FUNCTION: int ffi_test_3 ( int x, int y, int z, int t )
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-FUNCTION: float ffi_test_4 ;
+FUNCTION: float ffi_test_4 ( )
[ 1.5 ] [ ffi_test_4 ] unit-test
-FUNCTION: double ffi_test_5 ;
+FUNCTION: double ffi_test_5 ( )
[ 1.5 ] [ ffi_test_5 ] unit-test
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+FUNCTION: int ffi_test_9 )( int a, int b, int c, int d, int e, int f, int g )
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
: make-FOO ( x y -- FOO )
FOO <struct> swap >>y swap >>x ;
-FUNCTION: int ffi_test_11 int a FOO b int c ;
+FUNCTION: int ffi_test_11 ( int a, FOO b, int c )
[ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+FUNCTION: int ffi_test_13 ( int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k )
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-FUNCTION: FOO ffi_test_14 int x int y ;
+FUNCTION: FOO ffi_test_14 ( int x, int y )
[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
-FUNCTION: c-string ffi_test_15 c-string x c-string y ;
+FUNCTION: c-string ffi_test_15 ( c-string x, c-string y )
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
STRUCT: BAR { x long } { y long } { z long } ;
-FUNCTION: BAR ffi_test_16 long x long y long z ;
+FUNCTION: BAR ffi_test_16 ( long x, long y, long z )
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
STRUCT: TINY { x int } ;
-FUNCTION: TINY ffi_test_17 int x ;
+FUNCTION: TINY ffi_test_17 ( int x )
[ 11 ] [ 11 ffi_test_17 x>> ] unit-test
{ 1 1 } [ indirect-test-1 ] must-infer-as
-[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
-
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
-[ stdcall ] [ "f-stdcall" library abi>> ] unit-test
+[ stdcall ] [ "f-stdcall" lookup-library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
int "f-stdcall" "ffi_test_18" { int int int int }
[ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
-FUNCTION: double ffi_test_6 float x float y ;
+FUNCTION: double ffi_test_6 ( float x, float y )
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail
-FUNCTION: double ffi_test_7 double x double y ;
+FUNCTION: double ffi_test_7 ( double x, double y )
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+FUNCTION: double ffi_test_8 ( double x, float y, double z, float t, int w )
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+FUNCTION: int ffi_test_10 ( int a, int b, double c, int d, float e, int f, int g, int h )
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+FUNCTION: void ffi_test_20 ( double x1, double x2, double x3,
double y1, double y2, double y3,
- double z1, double z2, double z3 ;
+ double z1, double z2, double z3 )
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
-FUNCTION: longlong ffi_test_21 long x long y ;
+FUNCTION: longlong ffi_test_21 ( long x, long y )
[ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+FUNCTION: long ffi_test_22 ( long x, longlong y, longlong z )
[ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
swap >>y
swap >>x ;
-FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
+FUNCTION: int ffi_test_12 ( int a, int b, RECT c, int d, int e, int f )
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y )
[ 32.0 ] [
- { 1.0 2.0 3.0 } >float-array
- { 4.0 5.0 6.0 } >float-array
+ { 1.0 2.0 3.0 } float >c-array
+ { 4.0 5.0 6.0 } float >c-array
ffi_test_23
] unit-test
! Test odd-size structs
STRUCT: test-struct-1 { x char[1] } ;
-FUNCTION: test-struct-1 ffi_test_24 ;
+FUNCTION: test-struct-1 ffi_test_24 ( )
[ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
STRUCT: test-struct-2 { x char[2] } ;
-FUNCTION: test-struct-2 ffi_test_25 ;
+FUNCTION: test-struct-2 ffi_test_25 ( )
[ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
STRUCT: test-struct-3 { x char[3] } ;
-FUNCTION: test-struct-3 ffi_test_26 ;
+FUNCTION: test-struct-3 ffi_test_26 ( )
[ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
STRUCT: test-struct-4 { x char[4] } ;
-FUNCTION: test-struct-4 ffi_test_27 ;
+FUNCTION: test-struct-4 ffi_test_27 ( )
[ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
STRUCT: test-struct-5 { x char[5] } ;
-FUNCTION: test-struct-5 ffi_test_28 ;
+FUNCTION: test-struct-5 ffi_test_28 ( )
[ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
STRUCT: test-struct-6 { x char[6] } ;
-FUNCTION: test-struct-6 ffi_test_29 ;
+FUNCTION: test-struct-6 ffi_test_29 ( )
[ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
STRUCT: test-struct-7 { x char[7] } ;
-FUNCTION: test-struct-7 ffi_test_30 ;
+FUNCTION: test-struct-7 ffi_test_30 ( )
[ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
STRUCT: test-struct-8 { x double } { y double } ;
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+FUNCTION: double ffi_test_32 ( test-struct-8 x, int y )
[ 9.0 ] [
test-struct-8 <struct>
STRUCT: test-struct-9 { x float } { y float } ;
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+FUNCTION: double ffi_test_33 ( test-struct-9 x, int y )
[ 9.0 ] [
test-struct-9 <struct>
STRUCT: test-struct-10 { x float } { y int } ;
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+FUNCTION: double ffi_test_34 ( test-struct-10 x, int y )
[ 9.0 ] [
test-struct-10 <struct>
STRUCT: test-struct-11 { x int } { y int } ;
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+FUNCTION: double ffi_test_35 ( test-struct-11 x, int y )
[ 9.0 ] [
test-struct-11 <struct>
test-struct-12 <struct>
swap >>x ;
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+FUNCTION: double ffi_test_36 ( test-struct-12 x )
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y )
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
+: callback-throws ( -- x )
+ int { } cdecl [ "Hi" throw ] alien-callback ;
+
+{ t } [
+ callback-throws [ alien? ] with-callback
+] unit-test
: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
-[ t ] [ callback-1 alien? ] unit-test
+{ t } [ callback-1 [ alien? ] with-callback ] unit-test
: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
-[ ] [ callback-1 callback_test_1 ] unit-test
+{ } [ callback-1 [ callback_test_1 ] with-callback ] unit-test
: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
-[ ] [ callback-2 callback_test_1 ] unit-test
+{ } [ callback-2 [ callback_test_1 ] with-callback ] unit-test
: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
-[ t 3 5 ] [
+{ t 3 5 } [
[
namestack*
- 3 "x" set callback-3 callback_test_1
+ 3 "x" set callback-3 [ callback_test_1 ] with-callback
namestack* eq?
"x" get "x" get-global
] with-scope
: callback-5 ( -- callback )
void { } cdecl [ gc ] alien-callback ;
-[ "testing" ] [
- "testing" callback-5 callback_test_1
+{ "testing" } [
+ "testing" callback-5 [ callback_test_1 ] with-callback
] unit-test
: callback-5b ( -- callback )
void { } cdecl [ compact-gc ] alien-callback ;
[ "testing" ] [
- "testing" callback-5b callback_test_1
+ "testing" callback-5b [ callback_test_1 ] with-callback
] unit-test
: callback-6 ( -- callback )
void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [
+ callback-6 [ callback_test_1 1 2 3 ] with-callback
+] unit-test
: callback-7 ( -- callback )
void { } cdecl [ 1000000 sleep ] alien-callback ;
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
void { } cdecl [ [ ] in-thread yield ] alien-callback ;
-[ ] [ callback-8 callback_test_1 ] unit-test
+[ ] [ callback-8 [ callback_test_1 ] with-callback ] unit-test
: callback-9 ( -- callback )
int { int int int } cdecl [
+ + 1 +
] alien-callback ;
-FUNCTION: void ffi_test_36_point_5 ( ) ;
+FUNCTION: void ffi_test_36_point_5 ( )
[ ] [ ffi_test_36_point_5 ] unit-test
-FUNCTION: int ffi_test_37 ( void* func ) ;
+FUNCTION: int ffi_test_37 ( void* func )
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+[ 1 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+[ 7 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
STRUCT: test_struct_13
{ x1 float }
5.0 >>x5
6.0 >>x6 ;
-FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
+FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s )
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
void { void* void* double-rect } cdecl alien-indirect
"example" get-global ;
-[ 1.0 2.0 3.0 4.0 ]
-[
+{ byte-array 1.0 2.0 3.0 4.0 } [
1.0 2.0 3.0 4.0 <double-rect>
- double-rect-callback double-rect-test
- >double-rect<
+ double-rect-callback [
+ double-rect-test
+ [ >c-ptr class-of ] [ >double-rect< ] bi
+ ] with-callback
] unit-test
STRUCT: test_struct_14
{ x1 double }
{ x2 double } ;
-FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
+FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 )
[ 1.0 2.0 ] [
1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
: callback-10-test ( x1 x2 callback -- result )
test_struct_14 { double double } cdecl alien-indirect ;
-[ 1.0 2.0 ] [
- 1.0 2.0 callback-10 callback-10-test
- [ x1>> ] [ x2>> ] bi
+{ 1.0 2.0 } [
+ 1.0 2.0 callback-10 [
+ callback-10-test [ x1>> ] [ x2>> ] bi
+ ] with-callback
] unit-test
-FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
+FUNCTION: test-struct-12 ffi_test_41 ( int a, double x )
[ 1 2.0 ] [
1 2.0 ffi_test_41
: callback-11-test ( x1 x2 callback -- result )
test-struct-12 { int double } cdecl alien-indirect ;
-[ 1 2.0 ] [
- 1 2.0 callback-11 callback-11-test
- [ a>> ] [ x>> ] bi
+{ 1 2.0 } [
+ 1 2.0 callback-11 [
+ callback-11-test [ a>> ] [ x>> ] bi
+ ] with-callback
] unit-test
STRUCT: test_struct_15
{ x float }
{ y float } ;
-FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
+FUNCTION: test_struct_15 ffi_test_42 ( float x, float y )
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
test_struct_15 { float float } cdecl alien-indirect ;
[ 1.0 2.0 ] [
- 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
+ 1.0 2.0 callback-12 [
+ callback-12-test [ x>> ] [ y>> ] bi
+ ] with-callback
] unit-test
STRUCT: test_struct_16
{ x float }
{ a int } ;
-FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
+FUNCTION: test_struct_16 ffi_test_43 ( float x, int a )
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13-test ( x1 x2 callback -- result )
test_struct_16 { float int } cdecl alien-indirect ;
-[ 1.0 2 ] [
- 1.0 2 callback-13 callback-13-test
- [ x>> ] [ a>> ] bi
+{ 1.0 2 } [
+ 1.0 2 callback-13 [
+ callback-13-test [ x>> ] [ a>> ] bi
+ ] with-callback
] unit-test
-FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
+FUNCTION: test_struct_14 ffi_test_44 ( ) inline
[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
! C99 tests
os windows? [
-FUNCTION: complex-float ffi_test_45 ( int x ) ;
+ FUNCTION: complex-float ffi_test_45 ( int x )
-[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
+ [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
-FUNCTION: complex-double ffi_test_46 ( int x ) ;
+ FUNCTION: complex-double ffi_test_46 ( int x )
-[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
+ [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
-FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
+ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y )
-[ C{ 4.0 4.0 } ] [
- C{ 1.0 2.0 }
- C{ 1.5 1.0 } ffi_test_47
-] unit-test
+ [ C{ 4.0 4.0 } ] [
+ C{ 1.0 2.0 }
+ C{ 1.5 1.0 } ffi_test_47
+ ] unit-test
-! Reported by jedahu
-STRUCT: bool-field-test
- { name c-string }
- { on bool }
- { parents short } ;
+ ! Reported by jedahu
+ STRUCT: bool-field-test
+ { name c-string }
+ { on bool }
+ { parents short } ;
-FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
+ FUNCTION: short ffi_test_48 ( bool-field-test x )
-[ 123 ] [
- bool-field-test <struct>
- 123 >>parents
- ffi_test_48
-] unit-test
+ [ 123 ] [
+ bool-field-test <struct>
+ 123 >>parents
+ ffi_test_48
+ ] unit-test
] unless
int { } cdecl alien-indirect ;
<promise> "p" set
-[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
-[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
+[
+ thread-callback-1 [
+ thread-callback-invoker
+ ] with-callback "p" get fulfill
+] in-thread
+{ 200 } [
+ thread-callback-2 [ thread-callback-invoker ] with-callback
+] unit-test
[ 100 ] [ "p" get ?promise ] unit-test
-! Regression: calling an undefined function would raise a protection fault
-FUNCTION: void this_does_not_exist ( ) ;
-
-[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
-
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
[ ] [ assembly-test-1 ] unit-test
[ f ] [ "f-fastcall" load-library f = ] unit-test
-[ fastcall ] [ "f-fastcall" library abi>> ] unit-test
+[ fastcall ] [ "f-fastcall" lookup-library abi>> ] unit-test
: ffi_test_49 ( x -- int )
int "f-fastcall" "ffi_test_49" { int }
[ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
3dip
int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
-
+
[ 4 ] [ 3 ffi_test_49 ] unit-test
[ 8 ] [ 3 4 ffi_test_50 ] unit-test
[ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
alien-invoke gc ;
+! Make sure that large longlong/ulonglong are correctly dealt with
+FUNCTION: longlong ffi_test_59 ( longlong x )
+FUNCTION: ulonglong ffi_test_60 ( ulonglong x )
+
+[ t ] [ most-positive-fixnum 1 + [ ffi_test_59 ] keep = ] unit-test
+[ t ] [ most-positive-fixnum 1 + [ ffi_test_60 ] keep = ] unit-test
+
+[ -1 ] [ -1 ffi_test_59 ] unit-test
+[ -1 ] [ 0xffffffffffffffff ffi_test_59 ] unit-test
+[ 0xffffffffffffffff ] [ -1 ffi_test_60 ] unit-test
+[ 0xffffffffffffffff ] [ 0xffffffffffffffff ffi_test_60 ] unit-test
+
! GCC bugs
mingw? [
[ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
test-struct-11 { int int int } fastcall
[ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
-[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
+{ 8 } [
+ 3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
+] unit-test
-[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
+[ 13 ] [
+ 3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
+] unit-test
-[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
+[ 13 ] [
+ 3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
+] unit-test
-[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
+[ 19 ] [
+ 3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
+] unit-test
-[ S{ test-struct-11 f 7 -1 } ]
-[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
+[ S{ test-struct-11 f 7 -1 } ] [
+ 3 4 fastcall-struct-return-ii-callback [
+ fastcall-struct-return-ii-indirect
+ ] with-callback
+] unit-test
-[ S{ test-struct-11 f 7 -3 } ]
-[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
+[ S{ test-struct-11 f 7 -3 } ] [
+ 3 4 7 fastcall-struct-return-iii-callback [
+ fastcall-struct-return-iii-indirect
+ ] with-callback
+] unit-test
+
+: x64-regression-1 ( -- c )
+ int { int int int int int } cdecl [ + + + + ] alien-callback ;
+
+: x64-regression-2 ( x x x x x c -- y )
+ int { int int int int int } cdecl alien-indirect ; inline
+
+[ 661 ] [
+ 100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
+] unit-test
+
+! Stack allocation
+: blah ( -- x ) { RECT } [
+ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
+] with-scoped-allocation ;
+
+[ 3 ] [ blah ] unit-test
+
+: out-param-test-1 ( -- b )
+ { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-1 ] unit-test
+
+: out-param-test-2 ( -- b )
+ { { int initial: 12 } } [ drop ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-2 ] unit-test
+
+: out-param-test-3 ( -- x y )
+ { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
+ with-out-parameters
+ [ x>> ] [ y>> ] bi ;
+
+[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
+
+: out-param-callback ( -- a )
+ void { int pointer: int } cdecl
+ [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
+
+: out-param-indirect ( a a -- b )
+ { int } [
+ swap void { int pointer: int } cdecl
+ alien-indirect
+ ] with-out-parameters ;
+
+[ 12 ] [
+ 6 out-param-callback [ out-param-indirect ] with-callback
+] unit-test
+
+! Alias analysis regression
+: aa-callback-1 ( -- c )
+ double { } cdecl [ 5.0 ] alien-callback ;
+
+: aa-indirect-1 ( c -- x )
+ double { } cdecl alien-indirect ; inline
+
+TUPLE: some-tuple x ;
+
+[ T{ some-tuple f 5.0 } ] [
+ [
+ some-tuple new
+ aa-callback-1 [
+ aa-indirect-1
+ ] with-callback >>x
+ ] compile-call
+] unit-test
+
+! GC maps regression
+: anton's-regression ( -- )
+ f (free) f (free) ;
+
+[ ] [ anton's-regression ] unit-test
+
+os windows? [
+
+ STRUCT: bool-and-ptr
+ { b bool }
+ { ptr void* } ;
+
+ FUNCTION: bool-and-ptr ffi_test_61 ( )
+
+ ! { S{ bool-and-ptr { b t } { ptr f } } } [ ffi_test_61 ] unit-test
+ { t } [ ffi_test_61 bool-and-ptr? ] unit-test
+ { { t f } } [ ffi_test_61 [ b>> ] [ ptr>> ] bi 2array ] unit-test
+
+] unless
+
+STRUCT: uint-pair
+ { a uint }
+ { b uint } ;
+
+FUNCTION: uint-pair ffi_test_62 ( )
+
+{
+ S{ uint-pair { a 0xabcdefab } { b 0x12345678 } }
+} [ ffi_test_62 ] unit-test
+
+STRUCT: ulonglong-pair
+ { a ulonglong }
+ { b ulonglong } ;
+
+FUNCTION: ulonglong-pair ffi_test_63 ( )
+
+{
+ S{ ulonglong-pair { a 0xabcdefabcdefabcd } { b 0x1234567891234567 } }
+} [ ffi_test_63 ] unit-test
+
+FUNCTION: void* bug1021_test_1 ( void* s, int x )
+
+! Sanity test the formula: x sq s +
+{ t } [
+ 10 [ [ 100 random ] twice 2array ] replicate
+ [ [ first2 [ <alien> ] dip bug1021_test_1 alien-address ] map ]
+ [ [ first2 sq + ] map ] bi =
+] unit-test
+
+: each-to100 ( ... quot: ( ... i -- ... ) i -- ... )
+ dup 100 < [
+ 2dup swap (call) 1 + each-to100
+ ] [ 2drop ] if ; inline recursive
+
+: run-test ( alien -- seq )
+ 100 33 <array> swap over
+ [
+ pick swapd
+ bug1021_test_1
+ -rot swap 2 fixnum+fast
+ set-slot
+ ] curry curry 0 each-to100 ;
+
+{ } [
+ minor-gc 2000 [
+ 101 <alien> run-test
+ ! If #1021 ever comes back it will blow up here because
+ ! alien-address wants an alien not a fixnum.
+ [ alien-address ] map drop
+ ] times
+] unit-test
+
+FUNCTION: int bug1021_test_2 ( int a, char* b, void* c )
+FUNCTION: void* bug1021_test_3 ( c-string a )
+
+: doit ( a -- d )
+ 33 1byte-array "bar" bug1021_test_3 bug1021_test_2 ;
+
+{ } [
+ 10000 [ 0 doit 33 assert= ] times
+] unit-test
projects / factor.git / blobdiff