steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

use new structs wherever possible in compiler tests

db4
Doug Coleman 2009-08-25 11:59:33 -04:00
parent 3a5c7d8908
commit b756a37d75
1 changed files with 118 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

250
basis/compiler/tests/alien.factor
View File

@ -1,10 +1,12 @@
USING: alien alien.c-types alien.syntax compiler kernel namespaces USING: accessors alien alien.c-types alien.libraries
sequences stack-checker stack-checker.errors words arrays parser alien.syntax arrays classes.c-types classes.struct combinators
quotations continuations effects namespaces.private io compiler continuations effects io io.backend io.pathnames
io.streams.string memory system threads tools.test math accessors io.streams.string kernel math memory namespaces
combinators specialized-arrays.float alien.libraries io.pathnames namespaces.private parser quotations sequences
io.backend ; specialized-arrays.float stack-checker stack-checker.errors
system threads tools.test words ;
IN: compiler.tests.alien IN: compiler.tests.alien
FROM: classes.c-types => short ;
<< <<
: libfactor-ffi-tests-path ( -- string ) : 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 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo STRUCT: FOO { x int } { y int } ;
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo ) : make-FOO ( x y -- FOO )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ; 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 [ 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 [ 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 ; 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 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail [ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar STRUCT: BAR { x long } { y long } { z long } ;
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
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 ] [
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 ] unit-test
C-STRUCT: tiny STRUCT: TINY { x int } ;
{ "int" "x" }
;
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 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
@ -132,12 +125,12 @@ unit-test
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar ) : ffi_test_19 ( x y z -- BAR )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ; alien-invoke gc ;
[ 11 6 -7 ] [ [ 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 ] unit-test
FUNCTION: double ffi_test_6 float x float y ; 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 [ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect STRUCT: RECT
{ "float" "x" } { x single-float } { y single-float }
{ "float" "y" } { w single-float } { h single-float } ;
{ "float" "w" }
{ "float" "h" }
;
: <rect> ( x y w h -- rect ) : <RECT> ( x y w h -- rect )
"rect" <c-object> RECT <struct>
[ set-rect-h ] keep swap >>h
[ set-rect-w ] keep swap >>w
[ set-rect-y ] keep swap >>y
[ set-rect-x ] keep ; 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 [ 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 [ 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 [ 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 ; FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-8" <c-object> test-struct-8 <struct>
1.0 over set-test-struct-8-x 1.0 >>x
2.0 over set-test-struct-8-y 2.0 >>y
3 ffi_test_32 3 ffi_test_32
] unit-test ] 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 ; FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-9" <c-object> test-struct-9 <struct>
1.0 over set-test-struct-9-x 1.0 >>x
2.0 over set-test-struct-9-y 2.0 >>y
3 ffi_test_33 3 ffi_test_33
] unit-test ] 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 ; FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-10" <c-object> test-struct-10 <struct>
1.0 over set-test-struct-10-x 1.0 >>x
2 over set-test-struct-10-y 2 >>y
3 ffi_test_34 3 ffi_test_34
] unit-test ] 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 ; FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-11" <c-object> test-struct-11 <struct>
1 over set-test-struct-11-x 1 >>x
2 over set-test-struct-11-y 2 >>y
3 ffi_test_35 3 ffi_test_35
] unit-test ] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; STRUCT: test-struct-12 { a int } { x float } ;
: make-struct-12 ( x -- alien ) : make-struct-12 ( x -- alien )
"test-struct-12" <c-object> test-struct-12 <struct>
[ set-test-struct-12-x ] keep ; swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 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 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
C-STRUCT: test_struct_13 STRUCT: test_struct_13
{ "float" "x1" } { x1 single-float }
{ "float" "x2" } { x2 single-float }
{ "float" "x3" } { x3 single-float }
{ "float" "x4" } { x4 single-float }
{ "float" "x5" } { x5 single-float }
{ "float" "x6" } ; { x6 single-float } ;
: make-test-struct-13 ( -- alien ) : make-test-struct-13 ( -- alien )
"test_struct_13" <c-object> test_struct_13 <struct>
1.0 over set-test_struct_13-x1 1.0 >>x1
2.0 over set-test_struct_13-x2 2.0 >>x2
3.0 over set-test_struct_13-x3 3.0 >>x3
4.0 over set-test_struct_13-x4 4.0 >>x4
5.0 over set-test_struct_13-x5 5.0 >>x5
6.0 over set-test_struct_13-x6 ; 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 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem ! Joe Groff found this problem
C-STRUCT: double-rect STRUCT: double-rect
{ "double" "a" } { a float }
{ "double" "b" } { b float }
{ "double" "c" } { c float }
{ "double" "d" } ; { d float } ;
: <double-rect> ( a b c d -- foo ) : <double-rect> ( a b c d -- foo )
"double-rect" <c-object> double-rect <struct>
{ swap >>d
[ set-double-rect-d ] swap >>c
[ set-double-rect-c ] swap >>b
[ set-double-rect-b ] swap >>a ;
[ set-double-rect-a ]
[ ]
} cleave ;
: >double-rect< ( foo -- a b c d ) : >double-rect< ( foo -- a b c d )
{ {
[ double-rect-a ] [ a>> ]
[ double-rect-b ] [ b>> ]
[ double-rect-c ] [ c>> ]
[ double-rect-d ] [ d>> ]
} cleave ; } cleave ;
: double-rect-callback ( -- alien ) : 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 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
C-STRUCT: test_struct_14 STRUCT: test_struct_14
{ "double" "x1" } { x1 float }
{ "double" "x2" } ; { x2 float } ;
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 ] [
1.0 2.0 ffi_test_40 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test ] unit-test
: callback-10 ( -- callback ) : callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl" "test_struct_14" { "double" "double" } "cdecl"
[ [
"test_struct_14" <c-object> test_struct_14 <struct>
[ set-test_struct_14-x2 ] keep swap >>x2
[ set-test_struct_14-x1 ] keep swap >>x1
] alien-callback ; ] alien-callback ;
: callback-10-test ( x1 x2 callback -- result ) : 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 ] [
1.0 2.0 callback-10 callback-10-test 1.0 2.0 callback-10 callback-10-test
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi [ x1>> ] [ x2>> ] bi
] unit-test ] 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 ] [
1 2.0 ffi_test_41 1 2.0 ffi_test_41
[ test-struct-12-a ] [ test-struct-12-x ] bi [ a>> ] [ x>> ] bi
] unit-test ] unit-test
: callback-11 ( -- callback ) : callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl" "test-struct-12" { "int" "double" } "cdecl"
[ [
"test-struct-12" <c-object> test-struct-12 <struct>
[ set-test-struct-12-x ] keep swap >>x
[ set-test-struct-12-a ] keep swap >>a
] alien-callback ; ] alien-callback ;
: callback-11-test ( x1 x2 callback -- result ) : 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 ] [
1 2.0 callback-11 callback-11-test 1 2.0 callback-11 callback-11-test
[ test-struct-12-a ] [ test-struct-12-x ] bi [ a>> ] [ x>> ] bi
] unit-test ] unit-test
C-STRUCT: test_struct_15 STRUCT: test_struct_15
{ "float" "x" } { x single-float }
{ "float" "y" } ; { y single-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 [ 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 ) : callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl" "test_struct_15" { "float" "float" } "cdecl"
[ [
"test_struct_15" <c-object> test_struct_15 <struct>
[ set-test_struct_15-y ] keep swap >>y
[ set-test_struct_15-x ] keep swap >>x
] alien-callback ; ] alien-callback ;
: callback-12-test ( x1 x2 callback -- result ) : callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ; "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ test_struct_15-x ] [ test_struct_15-y ] bi
] unit-test ] unit-test
C-STRUCT: test_struct_16 STRUCT: test_struct_16
{ "float" "x" } { x single-float }
{ "int" "a" } ; { 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 [ 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 ) : callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl" "test_struct_16" { "float" "int" } "cdecl"
[ [
"test_struct_16" <c-object> test_struct_16 <struct>
[ set-test_struct_16-a ] keep swap >>a
[ set-test_struct_16-x ] keep swap >>x
] alien-callback ; ] alien-callback ;
: callback-13-test ( x1 x2 callback -- result ) : 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 ] [
1.0 2 callback-13 callback-13-test 1.0 2 callback-13 callback-13-test
[ test_struct_16-x ] [ test_struct_16-a ] bi [ x>> ] [ a>> ] bi
] unit-test ] 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 [ 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 ; : 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 ] unit-test
! Reported by jedahu ! Reported by jedahu
C-STRUCT: bool-field-test STRUCT: bool-field-test
{ "char*" "name" } { name pinned-c-ptr }
{ "bool" "on" } { on boolean }
{ "short" "parents" } ; { parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ; FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [ [ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents bool-field-test <struct>
123 >>parents
ffi_test_48 ffi_test_48
] unit-test ] unit-test