core/alien/compiler/compiler-tests.factor

   1 IN: alien.compiler.tests
   2 USING: alien alien.c-types alien.syntax compiler kernel
   3 namespaces namespaces tools.test sequences inference words
   4 arrays parser quotations continuations inference.backend effects
   5 namespaces.private io io.streams.string memory system threads
   6 tools.test math ;
   7
   8 FUNCTION: void ffi_test_0 ;
   9 [ ] [ ffi_test_0 ] unit-test
  10
  11 FUNCTION: int ffi_test_1 ;
  12 [ 3 ] [ ffi_test_1 ] unit-test
  13
  14 FUNCTION: int ffi_test_2 int x int y ;
  15 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
  16 [ "hi" 3 ffi_test_2 ] must-fail
  17
  18 FUNCTION: int ffi_test_3 int x int y int z int t ;
  19 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
  20
  21 FUNCTION: float ffi_test_4 ;
  22 [ 1.5 ] [ ffi_test_4 ] unit-test
  23
  24 FUNCTION: double ffi_test_5 ;
  25 [ 1.5 ] [ ffi_test_5 ] unit-test
  26
  27 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
  28 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
  29 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
  30 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
  31
  32 C-STRUCT: foo
  33     { "int" "x" }
  34     { "int" "y" }
  35 ;
  36
  37 : make-foo ( x y -- foo )
  38     "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
  39
  40 FUNCTION: int ffi_test_11 int a foo b int c ;
  41
  42 [ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
  43
  44 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 ;
  45
  46 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
  47
  48 FUNCTION: foo ffi_test_14 int x int y ;
  49
  50 [ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
  51
  52 FUNCTION: char* ffi_test_15 char* x char* y ;
  53
  54 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
  55 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
  56 [ 1 2 ffi_test_15 ] must-fail
  57
  58 C-STRUCT: bar
  59     { "long" "x" }
  60     { "long" "y" }
  61     { "long" "z" }
  62 ;
  63
  64 FUNCTION: bar ffi_test_16 long x long y long z ;
  65
  66 [ 11 6 -7 ] [
  67     11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
  68 ] unit-test
  69
  70 C-STRUCT: tiny
  71     { "int" "x" }
  72 ;
  73
  74 FUNCTION: tiny ffi_test_17 int x ;
  75
  76 [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
  77
  78 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
  79
  80 : indirect-test-1 ( ptr -- result )
  81     "int" { } "cdecl" alien-indirect ;
  82
  83 { 1 1 } [ indirect-test-1 ] must-infer-as
  84
  85 [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
  86
  87 [ -1 indirect-test-1 ] must-fail
  88
  89 : indirect-test-2 ( x y ptr -- result )
  90     "int" { "int" "int" } "cdecl" alien-indirect gc ;
  91
  92 { 3 1 } [ indirect-test-2 ] must-infer-as
  93
  94 [ 5 ]
  95 [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
  96 unit-test
  97
  98 : indirect-test-3 ( a b c d ptr -- result )
  99     "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
 100     gc ;
 101
 102 << "f-stdcall" f "stdcall" add-library >>
 103
 104 [ f ] [ "f-stdcall" load-library ] unit-test
 105 [ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
 106
 107 : ffi_test_18 ( w x y z -- int )
 108     "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
 109     alien-invoke gc ;
 110
 111 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 112
 113 : ffi_test_19 ( x y z -- bar )
 114     "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
 115     alien-invoke gc ;
 116
 117 [ 11 6 -7 ] [
 118     11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
 119 ] unit-test
 120
 121 FUNCTION: double ffi_test_6 float x float y ;
 122 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 123 [ "a" "b" ffi_test_6 ] must-fail
 124
 125 FUNCTION: double ffi_test_7 double x double y ;
 126 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 127
 128 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 129 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 130
 131 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 132 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 133
 134 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 135     double y1, double y2, double y3,
 136     double z1, double z2, double z3 ;
 137
 138 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 139
 140 ! Make sure XT doesn't get clobbered in stack frame
 141
 142 : 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 ptr -- result y )
 143     "void"
 144     f "ffi_test_31"
 145     { "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" }
 146     alien-invoke gc 3 ;
 147
 148 [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
 149
 150 FUNCTION: longlong ffi_test_21 long x long y ;
 151
 152 [ 121932631112635269 ]
 153 [ 123456789 987654321 ffi_test_21 ] unit-test
 154
 155 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 156
 157 [ 987655432 ]
 158 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 159
 160 [ 1111 f 123456789 ffi_test_22 ] must-fail
 161
 162 C-STRUCT: rect
 163     { "float" "x" }
 164     { "float" "y" }
 165     { "float" "w" }
 166     { "float" "h" }
 167 ;
 168
 169 : <rect>
 170     "rect" <c-object>
 171     [ set-rect-h ] keep
 172     [ set-rect-w ] keep
 173     [ set-rect-y ] keep
 174     [ set-rect-x ] keep ;
 175
 176 FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
 177
 178 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
 179
 180 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 181
 182 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 183
 184 [ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
 185
 186 ! Test odd-size structs
 187 C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
 188
 189 FUNCTION: test-struct-1 ffi_test_24 ;
 190
 191 [ B{ 1 } ] [ ffi_test_24 ] unit-test
 192
 193 C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
 194
 195 FUNCTION: test-struct-2 ffi_test_25 ;
 196
 197 [ B{ 1 2 } ] [ ffi_test_25 ] unit-test
 198
 199 C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
 200
 201 FUNCTION: test-struct-3 ffi_test_26 ;
 202
 203 [ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
 204
 205 C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
 206
 207 FUNCTION: test-struct-4 ffi_test_27 ;
 208
 209 [ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
 210
 211 C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
 212
 213 FUNCTION: test-struct-5 ffi_test_28 ;
 214
 215 [ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
 216
 217 C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
 218
 219 FUNCTION: test-struct-6 ffi_test_29 ;
 220
 221 [ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
 222
 223 C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
 224
 225 FUNCTION: test-struct-7 ffi_test_30 ;
 226
 227 [ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
 228
 229 C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
 230
 231 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 232
 233 [ 9.0 ] [
 234     "test-struct-8" <c-object>
 235     1.0 over set-test-struct-8-x
 236     2.0 over set-test-struct-8-y
 237     3 ffi_test_32
 238 ] unit-test
 239
 240 C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
 241
 242 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 243
 244 [ 9.0 ] [
 245     "test-struct-9" <c-object>
 246     1.0 over set-test-struct-9-x
 247     2.0 over set-test-struct-9-y
 248     3 ffi_test_33
 249 ] unit-test
 250
 251 C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
 252
 253 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 254
 255 [ 9.0 ] [
 256     "test-struct-10" <c-object>
 257     1.0 over set-test-struct-10-x
 258     2 over set-test-struct-10-y
 259     3 ffi_test_34
 260 ] unit-test
 261
 262 C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
 263
 264 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 265
 266 [ 9.0 ] [
 267     "test-struct-11" <c-object>
 268     1 over set-test-struct-11-x
 269     2 over set-test-struct-11-y
 270     3 ffi_test_35
 271 ] unit-test
 272
 273 C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
 274
 275 : make-struct-12
 276     "test-struct-12" <c-object>
 277     [ set-test-struct-12-x ] keep ;
 278
 279 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 280
 281 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 282
 283 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 284
 285 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 286
 287 ! Test callbacks
 288
 289 : callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
 290
 291 [ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
 292
 293 [ t ] [ callback-1 alien? ] unit-test
 294
 295 : callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
 296
 297 [ ] [ callback-1 callback_test_1 ] unit-test
 298
 299 : callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
 300
 301 [ ] [ callback-2 callback_test_1 ] unit-test
 302
 303 : callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
 304
 305 [ t ] [
 306     namestack*
 307     3 "x" set callback-3 callback_test_1
 308     namestack* eq?
 309 ] unit-test
 310
 311 [ 5 ] [
 312     [
 313         3 "x" set callback-3 callback_test_1 "x" get
 314     ] with-scope
 315 ] unit-test
 316
 317 : callback-4 ( -- callback )
 318     "void" { } "cdecl" [ "Hello world" write ] alien-callback
 319     gc ;
 320
 321 [ "Hello world" ] [
 322     [ callback-4 callback_test_1 ] with-string-writer
 323 ] unit-test
 324
 325 : callback-5 ( -- callback )
 326     "void" { } "cdecl" [ gc ] alien-callback ;
 327
 328 [ "testing" ] [
 329     "testing" callback-5 callback_test_1
 330 ] unit-test
 331
 332 : callback-5a ( -- callback )
 333     "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
 334
 335 ! Hack; if we're on ARM, we probably don't have much RAM, so
 336 ! skip this test.
 337 ! cpu "arm" = [
 338 !     [ "testing" ] [
 339 !         "testing" callback-5a callback_test_1
 340 !     ] unit-test
 341 ! ] unless
 342
 343 : callback-6 ( -- callback )
 344     "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
 345
 346 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 347
 348 : callback-7 ( -- callback )
 349     "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
 350
 351 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 352
 353 [ f ] [ namespace global eq? ] unit-test
 354
 355 : callback-8 ( -- callback )
 356     "void" { } "cdecl" [
 357         [ continue ] callcc0
 358     ] alien-callback ;
 359
 360 [ ] [ callback-8 callback_test_1 ] unit-test
 361
 362 : callback-9 ( -- callback )
 363     "int" { "int" "int" "int" } "cdecl" [
 364         + + 1+
 365     ] alien-callback ;
 366
 367 FUNCTION: void ffi_test_36_point_5 ( ) ;
 368
 369 [ ] [ ffi_test_36_point_5 ] unit-test
 370
 371 FUNCTION: int ffi_test_37 ( void* func ) ;
 372
 373 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 374
 375 [ 7 ] [ callback-9 ffi_test_37 ] unit-test