diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index e3c5dee917..3ecf873be5 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -1,10 +1,12 @@ -USING: alien alien.c-types alien.syntax compiler kernel namespaces -sequences stack-checker stack-checker.errors words arrays parser -quotations continuations effects namespaces.private io -io.streams.string memory system threads tools.test math accessors -combinators specialized-arrays.float alien.libraries io.pathnames -io.backend ; +USING: accessors alien alien.c-types alien.libraries +alien.syntax arrays classes.c-types classes.struct combinators +compiler continuations effects io io.backend io.pathnames +io.streams.string kernel math memory namespaces +namespaces.private parser quotations sequences +specialized-arrays.float stack-checker stack-checker.errors +system threads tools.test words ; IN: compiler.tests.alien +FROM: classes.c-types => short ; << : libfactor-ffi-tests-path ( -- string ) @@ -46,25 +48,22 @@ FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; +STRUCT: FOO { x int } { y int } ; -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; +: make-FOO ( x y -- FOO ) + FOO 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 +[ 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 ; [ 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 dup foo-x swap foo-y ] unit-test +[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test FUNCTION: char* ffi_test_15 char* x char* y ; @@ -72,25 +71,19 @@ FUNCTION: char* ffi_test_15 char* x char* y ; [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test [ 1 2 ffi_test_15 ] must-fail -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; +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 dup bar-x over bar-y rot bar-z + 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri ] unit-test -C-STRUCT: tiny - { "int" "x" } -; +STRUCT: TINY { x int } ; -FUNCTION: tiny ffi_test_17 int x ; +FUNCTION: TINY ffi_test_17 int x ; -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test +[ 11 ] [ 11 ffi_test_17 x>> ] unit-test [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with @@ -132,12 +125,12 @@ unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } +: ffi_test_19 ( x y z -- BAR ) + "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" } alien-invoke gc ; [ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z + 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri ] unit-test FUNCTION: double ffi_test_6 float x float y ; @@ -189,23 +182,20 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ; [ 1111 f 123456789 ffi_test_22 ] must-fail -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; +STRUCT: RECT + { x single-float } { y single-float } + { w single-float } { h single-float } ; -: ( x y w h -- rect ) - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; +: ( x y w h -- rect ) + RECT + swap >>h + swap >>w + 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 7 8 9 ffi_test_12 ] unit-test +[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail @@ -260,55 +250,55 @@ FUNCTION: test-struct-7 ffi_test_30 ; [ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; +STRUCT: test-struct-8 { x float } { y float } ; FUNCTION: double ffi_test_32 test-struct-8 x int y ; [ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y + test-struct-8 + 1.0 >>x + 2.0 >>y 3 ffi_test_32 ] unit-test -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; +STRUCT: test-struct-9 { x single-float } { y single-float } ; FUNCTION: double ffi_test_33 test-struct-9 x int y ; [ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y + test-struct-9 + 1.0 >>x + 2.0 >>y 3 ffi_test_33 ] unit-test -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; +STRUCT: test-struct-10 { x single-float } { y int } ; FUNCTION: double ffi_test_34 test-struct-10 x int y ; [ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y + test-struct-10 + 1.0 >>x + 2 >>y 3 ffi_test_34 ] unit-test -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; +STRUCT: test-struct-11 { x int } { y int } ; FUNCTION: double ffi_test_35 test-struct-11 x int y ; [ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y + test-struct-11 + 1 >>x + 2 >>y 3 ffi_test_35 ] unit-test -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; +STRUCT: test-struct-12 { a int } { x float } ; : make-struct-12 ( x -- alien ) - "test-struct-12" - [ set-test-struct-12-x ] keep ; + test-struct-12 + swap >>x ; FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; @@ -408,50 +398,47 @@ FUNCTION: int ffi_test_37 ( void* func ) ; [ 7 ] [ callback-9 ffi_test_37 ] unit-test -C-STRUCT: test_struct_13 -{ "float" "x1" } -{ "float" "x2" } -{ "float" "x3" } -{ "float" "x4" } -{ "float" "x5" } -{ "float" "x6" } ; +STRUCT: test_struct_13 +{ x1 single-float } +{ x2 single-float } +{ x3 single-float } +{ x4 single-float } +{ x5 single-float } +{ x6 single-float } ; : make-test-struct-13 ( -- alien ) - "test_struct_13" - 1.0 over set-test_struct_13-x1 - 2.0 over set-test_struct_13-x2 - 3.0 over set-test_struct_13-x3 - 4.0 over set-test_struct_13-x4 - 5.0 over set-test_struct_13-x5 - 6.0 over set-test_struct_13-x6 ; + test_struct_13 + 1.0 >>x1 + 2.0 >>x2 + 3.0 >>x3 + 4.0 >>x4 + 5.0 >>x5 + 6.0 >>x6 ; 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 ! Joe Groff found this problem -C-STRUCT: double-rect -{ "double" "a" } -{ "double" "b" } -{ "double" "c" } -{ "double" "d" } ; +STRUCT: double-rect +{ a float } +{ b float } +{ c float } +{ d float } ; : ( a b c d -- foo ) - "double-rect" - { - [ set-double-rect-d ] - [ set-double-rect-c ] - [ set-double-rect-b ] - [ set-double-rect-a ] - [ ] - } cleave ; + double-rect + swap >>d + swap >>c + swap >>b + swap >>a ; : >double-rect< ( foo -- a b c d ) { - [ double-rect-a ] - [ double-rect-b ] - [ double-rect-c ] - [ double-rect-d ] + [ a>> ] + [ b>> ] + [ c>> ] + [ d>> ] } cleave ; : double-rect-callback ( -- alien ) @@ -467,23 +454,22 @@ C-STRUCT: double-rect [ 1.0 2.0 3.0 4.0 ] [ 1.0 2.0 3.0 4.0 double-rect-test >double-rect< ] unit-test -C-STRUCT: test_struct_14 -{ "double" "x1" } -{ "double" "x2" } ; +STRUCT: test_struct_14 + { x1 float } + { x2 float } ; FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; [ 1.0 2.0 ] [ - 1.0 2.0 ffi_test_40 - [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi + 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi ] unit-test : callback-10 ( -- callback ) "test_struct_14" { "double" "double" } "cdecl" [ - "test_struct_14" - [ set-test_struct_14-x2 ] keep - [ set-test_struct_14-x1 ] keep + test_struct_14 + swap >>x2 + swap >>x1 ] alien-callback ; : callback-10-test ( x1 x2 callback -- result ) @@ -491,22 +477,22 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; [ 1.0 2.0 ] [ 1.0 2.0 callback-10 callback-10-test - [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi + [ x1>> ] [ x2>> ] bi ] unit-test FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; [ 1 2.0 ] [ 1 2.0 ffi_test_41 - [ test-struct-12-a ] [ test-struct-12-x ] bi + [ a>> ] [ x>> ] bi ] unit-test : callback-11 ( -- callback ) "test-struct-12" { "int" "double" } "cdecl" [ - "test-struct-12" - [ set-test-struct-12-x ] keep - [ set-test-struct-12-a ] keep + test-struct-12 + swap >>x + swap >>a ] alien-callback ; : callback-11-test ( x1 x2 callback -- result ) @@ -514,47 +500,46 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; [ 1 2.0 ] [ 1 2.0 callback-11 callback-11-test - [ test-struct-12-a ] [ test-struct-12-x ] bi + [ a>> ] [ x>> ] bi ] unit-test -C-STRUCT: test_struct_15 -{ "float" "x" } -{ "float" "y" } ; +STRUCT: test_struct_15 + { x single-float } + { y single-float } ; FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; -[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test +[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test : callback-12 ( -- callback ) "test_struct_15" { "float" "float" } "cdecl" [ - "test_struct_15" - [ set-test_struct_15-y ] keep - [ set-test_struct_15-x ] keep + test_struct_15 + swap >>y + swap >>x ] alien-callback ; : callback-12-test ( x1 x2 callback -- result ) "test_struct_15" { "float" "float" } "cdecl" alien-indirect ; [ 1.0 2.0 ] [ - 1.0 2.0 callback-12 callback-12-test - [ test_struct_15-x ] [ test_struct_15-y ] bi + 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi ] unit-test -C-STRUCT: test_struct_16 -{ "float" "x" } -{ "int" "a" } ; +STRUCT: test_struct_16 + { x single-float } + { a int } ; FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; -[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test +[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test : callback-13 ( -- callback ) "test_struct_16" { "float" "int" } "cdecl" [ - "test_struct_16" - [ set-test_struct_16-a ] keep - [ set-test_struct_16-x ] keep + test_struct_16 + swap >>a + swap >>x ] alien-callback ; : callback-13-test ( x1 x2 callback -- result ) @@ -562,12 +547,12 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; [ 1.0 2 ] [ 1.0 2 callback-13 callback-13-test - [ test_struct_16-x ] [ test_struct_16-a ] bi + [ x>> ] [ a>> ] bi ] unit-test FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline -[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test +[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; @@ -589,14 +574,15 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; ] unit-test ! Reported by jedahu -C-STRUCT: bool-field-test - { "char*" "name" } - { "bool" "on" } - { "short" "parents" } ; +STRUCT: bool-field-test + { name pinned-c-ptr } + { on boolean } + { parents short } ; FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ 123 ] [ - "bool-field-test" 123 over set-bool-field-test-parents + bool-field-test + 123 >>parents ffi_test_48 ] unit-test