1 USING: accessors alien alien.c-types alien.libraries
2 alien.syntax arrays classes.struct combinators
3 compiler continuations effects generalizations io
4 io.backend io.pathnames io.streams.string kernel
5 math memory namespaces namespaces.private parser
6 quotations sequences specialized-arrays stack-checker
7 stack-checker.errors system threads tools.test words
8 alien.complex concurrency.promises ;
9 FROM: alien.c-types => float short ;
10 FROM: alien.private => fastcall ;
11 SPECIALIZED-ARRAY: float
12 SPECIALIZED-ARRAY: char
13 IN: compiler.tests.alien
16 : libfactor-ffi-tests-path ( -- string )
17 "resource:" absolute-path
19 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
20 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
21 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
24 "f-cdecl" libfactor-ffi-tests-path cdecl add-library
26 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
28 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
33 FUNCTION: void ffi_test_0 ;
34 [ ] [ ffi_test_0 ] unit-test
36 FUNCTION: int ffi_test_1 ;
37 [ 3 ] [ ffi_test_1 ] unit-test
39 FUNCTION: int ffi_test_2 int x int y ;
40 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
41 [ "hi" 3 ffi_test_2 ] must-fail
43 FUNCTION: int ffi_test_3 int x int y int z int t ;
44 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
46 FUNCTION: float ffi_test_4 ;
47 [ 1.5 ] [ ffi_test_4 ] unit-test
49 FUNCTION: double ffi_test_5 ;
50 [ 1.5 ] [ ffi_test_5 ] unit-test
52 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
53 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
54 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
55 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
57 STRUCT: FOO { x int } { y int } ;
59 : make-FOO ( x y -- FOO )
60 FOO <struct> swap >>y swap >>x ;
62 FUNCTION: int ffi_test_11 int a FOO b int c ;
64 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
66 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 ;
68 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
70 FUNCTION: FOO ffi_test_14 int x int y ;
72 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
74 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
76 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
77 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
78 [ 1 2 ffi_test_15 ] must-fail
80 STRUCT: BAR { x long } { y long } { z long } ;
82 FUNCTION: BAR ffi_test_16 long x long y long z ;
85 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
88 STRUCT: TINY { x int } ;
90 FUNCTION: TINY ffi_test_17 int x ;
92 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
94 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
96 : indirect-test-1 ( ptr -- result )
97 int { } cdecl alien-indirect ;
99 { 1 1 } [ indirect-test-1 ] must-infer-as
101 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
103 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
105 : indirect-test-1' ( ptr -- )
106 int { } cdecl alien-indirect drop ;
108 { 1 0 } [ indirect-test-1' ] must-infer-as
110 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
112 [ -1 indirect-test-1 ] must-fail
114 : indirect-test-2 ( x y ptr -- result )
115 int { int int } cdecl alien-indirect gc ;
117 { 3 1 } [ indirect-test-2 ] must-infer-as
120 [ 2 3 &: ffi_test_2 indirect-test-2 ]
123 : indirect-test-3 ( a b c d ptr -- result )
124 int { int int int int } stdcall alien-indirect
127 [ f ] [ "f-stdcall" load-library f = ] unit-test
128 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
130 : ffi_test_18 ( w x y z -- int )
131 int "f-stdcall" "ffi_test_18" { int int int int }
134 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
136 : ffi_test_19 ( x y z -- BAR )
137 BAR "f-stdcall" "ffi_test_19" { long long long }
141 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
144 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
145 [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
147 int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
150 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
152 FUNCTION: double ffi_test_6 float x float y ;
153 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
154 [ "a" "b" ffi_test_6 ] must-fail
156 FUNCTION: double ffi_test_7 double x double y ;
157 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
159 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
160 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
162 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
163 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
165 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
166 double y1, double y2, double y3,
167 double z1, double z2, double z3 ;
169 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
171 ! Make sure XT doesn't get clobbered in stack frame
173 : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
175 "f-cdecl" "ffi_test_31"
176 { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
179 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
181 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
183 "f-cdecl" "ffi_test_31_point_5"
184 { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
187 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
189 FUNCTION: longlong ffi_test_21 long x long y ;
191 [ 121932631112635269 ]
192 [ 123456789 987654321 ffi_test_21 ] unit-test
194 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
197 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
199 [ 1111 f 123456789 ffi_test_22 ] must-fail
202 { x float } { y float }
203 { w float } { h float } ;
205 : <RECT> ( x y w h -- rect )
212 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
214 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
216 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
218 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
221 { 1.0 2.0 3.0 } >float-array
222 { 4.0 5.0 6.0 } >float-array
226 ! Test odd-size structs
227 STRUCT: test-struct-1 { x char[1] } ;
229 FUNCTION: test-struct-1 ffi_test_24 ;
231 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
233 STRUCT: test-struct-2 { x char[2] } ;
235 FUNCTION: test-struct-2 ffi_test_25 ;
237 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
239 STRUCT: test-struct-3 { x char[3] } ;
241 FUNCTION: test-struct-3 ffi_test_26 ;
243 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
245 STRUCT: test-struct-4 { x char[4] } ;
247 FUNCTION: test-struct-4 ffi_test_27 ;
249 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
251 STRUCT: test-struct-5 { x char[5] } ;
253 FUNCTION: test-struct-5 ffi_test_28 ;
255 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
257 STRUCT: test-struct-6 { x char[6] } ;
259 FUNCTION: test-struct-6 ffi_test_29 ;
261 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
263 STRUCT: test-struct-7 { x char[7] } ;
265 FUNCTION: test-struct-7 ffi_test_30 ;
267 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
269 STRUCT: test-struct-8 { x double } { y double } ;
271 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
274 test-struct-8 <struct>
280 STRUCT: test-struct-9 { x float } { y float } ;
282 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
285 test-struct-9 <struct>
291 STRUCT: test-struct-10 { x float } { y int } ;
293 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
296 test-struct-10 <struct>
302 STRUCT: test-struct-11 { x int } { y int } ;
304 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
307 test-struct-11 <struct>
313 STRUCT: test-struct-12 { a int } { x double } ;
315 : make-struct-12 ( x -- alien )
316 test-struct-12 <struct>
319 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
321 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
323 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
325 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
329 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
331 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
333 [ t ] [ callback-1 alien? ] unit-test
335 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
337 [ ] [ callback-1 callback_test_1 ] unit-test
339 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
341 [ ] [ callback-2 callback_test_1 ] unit-test
343 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
348 3 "x" set callback-3 callback_test_1
350 "x" get "x" get-global
354 : callback-5 ( -- callback )
355 void { } cdecl [ gc ] alien-callback ;
358 "testing" callback-5 callback_test_1
361 : callback-5b ( -- callback )
362 void { } cdecl [ compact-gc ] alien-callback ;
365 "testing" callback-5b callback_test_1
368 : callback-6 ( -- callback )
369 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
371 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
373 : callback-7 ( -- callback )
374 void { } cdecl [ 1000000 sleep ] alien-callback ;
376 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
378 [ f ] [ namespace global eq? ] unit-test
380 : callback-8 ( -- callback )
381 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
383 [ ] [ callback-8 callback_test_1 ] unit-test
385 : callback-9 ( -- callback )
386 int { int int int } cdecl [
390 FUNCTION: void ffi_test_36_point_5 ( ) ;
392 [ ] [ ffi_test_36_point_5 ] unit-test
394 FUNCTION: int ffi_test_37 ( void* func ) ;
396 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
398 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
400 STRUCT: test_struct_13
408 : make-test-struct-13 ( -- alien )
409 test_struct_13 <struct>
417 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
419 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
421 ! Joe Groff found this problem
428 : <double-rect> ( a b c d -- foo )
435 : >double-rect< ( foo -- a b c d )
443 : double-rect-callback ( -- alien )
444 void { void* void* double-rect } cdecl
445 [ "example" set-global 2drop ] alien-callback ;
447 : double-rect-test ( arg -- arg' )
450 void { void* void* double-rect } cdecl alien-indirect
451 "example" get-global ;
454 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
456 STRUCT: test_struct_14
460 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
463 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
466 : callback-10 ( -- callback )
467 test_struct_14 { double double } cdecl
469 test_struct_14 <struct>
474 : callback-10-test ( x1 x2 callback -- result )
475 test_struct_14 { double double } cdecl alien-indirect ;
478 1.0 2.0 callback-10 callback-10-test
482 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
489 : callback-11 ( -- callback )
490 test-struct-12 { int double } cdecl
492 test-struct-12 <struct>
497 : callback-11-test ( x1 x2 callback -- result )
498 test-struct-12 { int double } cdecl alien-indirect ;
501 1 2.0 callback-11 callback-11-test
505 STRUCT: test_struct_15
509 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
511 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
513 : callback-12 ( -- callback )
514 test_struct_15 { float float } cdecl
516 test_struct_15 <struct>
521 : callback-12-test ( x1 x2 callback -- result )
522 test_struct_15 { float float } cdecl alien-indirect ;
525 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
528 STRUCT: test_struct_16
532 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
534 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
536 : callback-13 ( -- callback )
537 test_struct_16 { float int } cdecl
539 test_struct_16 <struct>
544 : callback-13-test ( x1 x2 callback -- result )
545 test_struct_16 { float int } cdecl alien-indirect ;
548 1.0 2 callback-13 callback-13-test
552 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
554 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
556 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
558 [ ] [ stack-frame-bustage 2drop ] unit-test
563 FUNCTION: complex-float ffi_test_45 ( int x ) ;
565 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
567 FUNCTION: complex-double ffi_test_46 ( int x ) ;
569 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
571 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
575 C{ 1.5 1.0 } ffi_test_47
579 STRUCT: bool-field-test
584 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
587 bool-field-test <struct>
594 ! Test interaction between threads and callbacks
595 : thread-callback-1 ( -- callback )
596 int { } cdecl [ yield 100 ] alien-callback ;
598 : thread-callback-2 ( -- callback )
599 int { } cdecl [ yield 200 ] alien-callback ;
601 : thread-callback-invoker ( callback -- n )
602 int { } cdecl alien-indirect ;
605 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
606 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
607 [ 100 ] [ "p" get ?promise ] unit-test
609 ! Regression: calling an undefined function would raise a protection fault
610 FUNCTION: void this_does_not_exist ( ) ;
612 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
614 ! More alien-assembly tests are in cpu.* vocabs
615 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
617 [ ] [ assembly-test-1 ] unit-test
619 [ f ] [ "f-fastcall" load-library f = ] unit-test
620 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
622 : ffi_test_49 ( x -- int )
623 int "f-fastcall" "ffi_test_49" { int }
625 : ffi_test_50 ( x y -- int )
626 int "f-fastcall" "ffi_test_50" { int int }
628 : ffi_test_51 ( x y z -- int )
629 int "f-fastcall" "ffi_test_51" { int int int }
631 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
632 [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
634 int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
636 [ 4 ] [ 3 ffi_test_49 ] unit-test
637 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
638 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
639 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
641 : ffi_test_52 ( x y z -- int )
642 int "f-fastcall" "ffi_test_52" { int float int }
644 : ffi_test_53 ( x y z w -- int )
645 int "f-fastcall" "ffi_test_53" { int float int int }
647 : ffi_test_57 ( x y -- test-struct-11 )
648 test-struct-11 "f-fastcall" "ffi_test_57" { int int }
650 : ffi_test_58 ( x y z -- test-struct-11 )
651 test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
654 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
655 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
656 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
657 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
659 : fastcall-ii-indirect ( x y ptr -- result )
660 int { int int } fastcall alien-indirect ;
661 : fastcall-ifi-indirect ( x y z ptr -- result )
662 int { int float int } fastcall alien-indirect ;
663 : fastcall-struct-return-indirect ( x y ptr -- result )
664 test-struct-11 { int int } fastcall alien-indirect ;
666 [ 8 ] [ 3 4 &: ffi_test_50 fastcall-ii-indirect ] unit-test
667 [ 13 ] [ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect ] unit-test
668 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 &: ffi_test_57 fastcall-struct-return-indirect ] unit-test