basis/compiler/tests/alien.factor

   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 alien.data
   9 byte-arrays classes compiler.test libc ;
  10 FROM: alien.c-types => float short ;
  11 SPECIALIZED-ARRAY: float
  12 SPECIALIZED-ARRAY: char
  13 IN: compiler.tests.alien
  14
  15 ! Make sure that invalid inputs don't pass the stack checker
  16 [ [ void { } "cdecl" alien-indirect ] infer ] must-fail
  17 [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
  18 [ [ void* 3 cdecl alien-indirect ] infer ] must-fail
  19 [ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
  20 [ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
  21
  22 <<
  23 : libfactor-ffi-tests-path ( -- string )
  24     "resource:" absolute-path
  25     {
  26         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
  27         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
  28         { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
  29     } cond append-path ;
  30
  31 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
  32
  33 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
  34
  35 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
  36
  37 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
  38 >>
  39
  40 LIBRARY: f-cdecl
  41
  42 FUNCTION: void ffi_test_0 ;
  43 [ ] [ ffi_test_0 ] unit-test
  44
  45 FUNCTION: int ffi_test_1 ;
  46 [ 3 ] [ ffi_test_1 ] unit-test
  47
  48 [ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
  49
  50 FUNCTION: int ffi_test_2 int x int y ;
  51 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
  52 [ "hi" 3 ffi_test_2 ] must-fail
  53
  54 FUNCTION: int ffi_test_3 int x int y int z int t ;
  55 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
  56
  57 FUNCTION: float ffi_test_4 ;
  58 [ 1.5 ] [ ffi_test_4 ] unit-test
  59
  60 FUNCTION: double ffi_test_5 ;
  61 [ 1.5 ] [ ffi_test_5 ] unit-test
  62
  63 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
  64 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
  65 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
  66 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
  67
  68 STRUCT: FOO { x int } { y int } ;
  69
  70 : make-FOO ( x y -- FOO )
  71     FOO <struct> swap >>y swap >>x ;
  72
  73 FUNCTION: int ffi_test_11 int a FOO b int c ;
  74
  75 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
  76
  77 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 ;
  78
  79 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
  80
  81 FUNCTION: FOO ffi_test_14 int x int y ;
  82
  83 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
  84
  85 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
  86
  87 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
  88 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
  89 [ 1 2 ffi_test_15 ] must-fail
  90
  91 STRUCT: BAR { x long } { y long } { z long } ;
  92
  93 FUNCTION: BAR ffi_test_16 long x long y long z ;
  94
  95 [ 11 6 -7 ] [
  96     11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
  97 ] unit-test
  98
  99 STRUCT: TINY { x int } ;
 100
 101 FUNCTION: TINY ffi_test_17 int x ;
 102
 103 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
 104
 105 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
 106
 107 : indirect-test-1 ( ptr -- result )
 108     int { } cdecl alien-indirect ;
 109
 110 { 1 1 } [ indirect-test-1 ] must-infer-as
 111
 112 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 113
 114 : indirect-test-1' ( ptr -- )
 115     int { } cdecl alien-indirect drop ;
 116
 117 { 1 0 } [ indirect-test-1' ] must-infer-as
 118
 119 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 120
 121 [ -1 indirect-test-1 ] must-fail
 122
 123 : indirect-test-2 ( x y ptr -- result )
 124     int { int int } cdecl alien-indirect gc ;
 125
 126 { 3 1 } [ indirect-test-2 ] must-infer-as
 127
 128 [ 5 ]
 129 [ 2 3 &: ffi_test_2 indirect-test-2 ]
 130 unit-test
 131
 132 : indirect-test-3 ( a b c d ptr -- result )
 133     int { int int int int } stdcall alien-indirect
 134     gc ;
 135
 136 [ f ] [ "f-stdcall" load-library f = ] unit-test
 137 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
 138
 139 : ffi_test_18 ( w x y z -- int )
 140     int "f-stdcall" "ffi_test_18" { int int int int }
 141     alien-invoke gc ;
 142
 143 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 144
 145 : ffi_test_19 ( x y z -- BAR )
 146     BAR "f-stdcall" "ffi_test_19" { long long long }
 147     alien-invoke gc ;
 148
 149 [ 11 6 -7 ] [
 150     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 151 ] unit-test
 152
 153 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
 154     [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
 155     4 ndip
 156     int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
 157     gc ;
 158
 159 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
 160
 161 FUNCTION: double ffi_test_6 float x float y ;
 162 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 163 [ "a" "b" ffi_test_6 ] must-fail
 164
 165 FUNCTION: double ffi_test_7 double x double y ;
 166 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 167
 168 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 169 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 170
 171 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 172 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 173
 174 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 175     double y1, double y2, double y3,
 176     double z1, double z2, double z3 ;
 177
 178 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 179
 180 ! Make sure XT doesn't get clobbered in stack frame
 181
 182 : 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 )
 183     int
 184     "f-cdecl" "ffi_test_31"
 185     { 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 }
 186     alien-invoke gc 3 ;
 187
 188 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 189
 190 : 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 )
 191     float
 192     "f-cdecl" "ffi_test_31_point_5"
 193     { 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 }
 194     alien-invoke ;
 195
 196 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 197
 198 FUNCTION: longlong ffi_test_21 long x long y ;
 199
 200 [ 121932631112635269 ]
 201 [ 123456789 987654321 ffi_test_21 ] unit-test
 202
 203 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 204
 205 [ 987655432 ]
 206 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 207
 208 [ 1111 f 123456789 ffi_test_22 ] must-fail
 209
 210 STRUCT: RECT
 211     { x float } { y float }
 212     { w float } { h float } ;
 213
 214 : <RECT> ( x y w h -- rect )
 215     RECT <struct>
 216         swap >>h
 217         swap >>w
 218         swap >>y
 219         swap >>x ;
 220
 221 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
 222
 223 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 224
 225 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 226
 227 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 228
 229 [ 32.0 ] [
 230     { 1.0 2.0 3.0 } >float-array
 231     { 4.0 5.0 6.0 } >float-array
 232     ffi_test_23
 233 ] unit-test
 234
 235 ! Test odd-size structs
 236 STRUCT: test-struct-1 { x char[1] } ;
 237
 238 FUNCTION: test-struct-1 ffi_test_24 ;
 239
 240 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
 241
 242 STRUCT: test-struct-2 { x char[2] } ;
 243
 244 FUNCTION: test-struct-2 ffi_test_25 ;
 245
 246 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
 247
 248 STRUCT: test-struct-3 { x char[3] } ;
 249
 250 FUNCTION: test-struct-3 ffi_test_26 ;
 251
 252 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
 253
 254 STRUCT: test-struct-4 { x char[4] } ;
 255
 256 FUNCTION: test-struct-4 ffi_test_27 ;
 257
 258 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
 259
 260 STRUCT: test-struct-5 { x char[5] } ;
 261
 262 FUNCTION: test-struct-5 ffi_test_28 ;
 263
 264 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
 265
 266 STRUCT: test-struct-6 { x char[6] } ;
 267
 268 FUNCTION: test-struct-6 ffi_test_29 ;
 269
 270 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
 271
 272 STRUCT: test-struct-7 { x char[7] } ;
 273
 274 FUNCTION: test-struct-7 ffi_test_30 ;
 275
 276 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
 277
 278 STRUCT: test-struct-8 { x double } { y double } ;
 279
 280 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 281
 282 [ 9.0 ] [
 283     test-struct-8 <struct>
 284     1.0 >>x
 285     2.0 >>y
 286     3 ffi_test_32
 287 ] unit-test
 288
 289 STRUCT: test-struct-9 { x float } { y float } ;
 290
 291 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 292
 293 [ 9.0 ] [
 294     test-struct-9 <struct>
 295     1.0 >>x
 296     2.0 >>y
 297     3 ffi_test_33
 298 ] unit-test
 299
 300 STRUCT: test-struct-10 { x float } { y int } ;
 301
 302 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 303
 304 [ 9.0 ] [
 305     test-struct-10 <struct>
 306     1.0 >>x
 307     2 >>y
 308     3 ffi_test_34
 309 ] unit-test
 310
 311 STRUCT: test-struct-11 { x int } { y int } ;
 312
 313 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 314
 315 [ 9.0 ] [
 316     test-struct-11 <struct>
 317     1 >>x
 318     2 >>y
 319     3 ffi_test_35
 320 ] unit-test
 321
 322 STRUCT: test-struct-12 { a int } { x double } ;
 323
 324 : make-struct-12 ( x -- alien )
 325     test-struct-12 <struct>
 326         swap >>x ;
 327
 328 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 329
 330 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 331
 332 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 333
 334 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 335
 336 ! Test callbacks
 337
 338 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 339
 340 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 341
 342 [ t ] [ callback-1 alien? ] unit-test
 343
 344 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 345
 346 [ ] [ callback-1 callback_test_1 ] unit-test
 347
 348 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 349
 350 [ ] [ callback-2 callback_test_1 ] unit-test
 351
 352 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 353
 354 [ t 3 5 ] [
 355     [
 356         namestack*
 357         3 "x" set callback-3 callback_test_1
 358         namestack* eq?
 359         "x" get "x" get-global
 360     ] with-scope
 361 ] unit-test
 362
 363 : callback-5 ( -- callback )
 364     void { } cdecl [ gc ] alien-callback ;
 365
 366 [ "testing" ] [
 367     "testing" callback-5 callback_test_1
 368 ] unit-test
 369
 370 : callback-5b ( -- callback )
 371     void { } cdecl [ compact-gc ] alien-callback ;
 372
 373 [ "testing" ] [
 374     "testing" callback-5b callback_test_1
 375 ] unit-test
 376
 377 : callback-6 ( -- callback )
 378     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 379
 380 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 381
 382 : callback-7 ( -- callback )
 383     void { } cdecl [ 1000000 sleep ] alien-callback ;
 384
 385 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 386
 387 [ f ] [ namespace global eq? ] unit-test
 388
 389 : callback-8 ( -- callback )
 390     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 391
 392 [ ] [ callback-8 callback_test_1 ] unit-test
 393
 394 : callback-9 ( -- callback )
 395     int { int int int } cdecl [
 396         + + 1 +
 397     ] alien-callback ;
 398
 399 FUNCTION: void ffi_test_36_point_5 ( ) ;
 400
 401 [ ] [ ffi_test_36_point_5 ] unit-test
 402
 403 FUNCTION: int ffi_test_37 ( void* func ) ;
 404
 405 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 406
 407 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
 408
 409 STRUCT: test_struct_13
 410 { x1 float }
 411 { x2 float }
 412 { x3 float }
 413 { x4 float }
 414 { x5 float }
 415 { x6 float } ;
 416
 417 : make-test-struct-13 ( -- alien )
 418     test_struct_13 <struct>
 419         1.0 >>x1
 420         2.0 >>x2
 421         3.0 >>x3
 422         4.0 >>x4
 423         5.0 >>x5
 424         6.0 >>x6 ;
 425
 426 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 427
 428 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 429
 430 ! Joe Groff found this problem
 431 STRUCT: double-rect
 432 { a double }
 433 { b double }
 434 { c double }
 435 { d double } ;
 436
 437 : <double-rect> ( a b c d -- foo )
 438     double-rect <struct>
 439         swap >>d
 440         swap >>c
 441         swap >>b
 442         swap >>a ;
 443
 444 : >double-rect< ( foo -- a b c d )
 445     {
 446         [ a>> ]
 447         [ b>> ]
 448         [ c>> ]
 449         [ d>> ]
 450     } cleave ;
 451
 452 : double-rect-callback ( -- alien )
 453     void { void* void* double-rect } cdecl
 454     [ "example" set-global 2drop ] alien-callback ;
 455
 456 : double-rect-test ( arg callback -- arg' )
 457     [ f f ] 2dip
 458     void { void* void* double-rect } cdecl alien-indirect
 459     "example" get-global ;
 460
 461 [ byte-array 1.0 2.0 3.0 4.0 ]
 462 [
 463     1.0 2.0 3.0 4.0 <double-rect>
 464     double-rect-callback double-rect-test
 465     [ >c-ptr class ] [ >double-rect< ] bi
 466 ] unit-test
 467
 468 STRUCT: test_struct_14
 469     { x1 double }
 470     { x2 double } ;
 471
 472 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 473
 474 [ 1.0 2.0 ] [
 475     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 476 ] unit-test
 477
 478 : callback-10 ( -- callback )
 479     test_struct_14 { double double } cdecl
 480     [
 481         test_struct_14 <struct>
 482             swap >>x2
 483             swap >>x1
 484     ] alien-callback ;
 485
 486 : callback-10-test ( x1 x2 callback -- result )
 487     test_struct_14 { double double } cdecl alien-indirect ;
 488
 489 [ 1.0 2.0 ] [
 490     1.0 2.0 callback-10 callback-10-test
 491     [ x1>> ] [ x2>> ] bi
 492 ] unit-test
 493
 494 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 495
 496 [ 1 2.0 ] [
 497     1 2.0 ffi_test_41
 498     [ a>> ] [ x>> ] bi
 499 ] unit-test
 500
 501 : callback-11 ( -- callback )
 502     test-struct-12 { int double } cdecl
 503     [
 504         test-struct-12 <struct>
 505             swap >>x
 506             swap >>a
 507     ] alien-callback ;
 508
 509 : callback-11-test ( x1 x2 callback -- result )
 510     test-struct-12 { int double } cdecl alien-indirect ;
 511
 512 [ 1 2.0 ] [
 513     1 2.0 callback-11 callback-11-test
 514     [ a>> ] [ x>> ] bi
 515 ] unit-test
 516
 517 STRUCT: test_struct_15
 518     { x float }
 519     { y float } ;
 520
 521 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 522
 523 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 524
 525 : callback-12 ( -- callback )
 526     test_struct_15 { float float } cdecl
 527     [
 528         test_struct_15 <struct>
 529             swap >>y
 530             swap >>x
 531     ] alien-callback ;
 532
 533 : callback-12-test ( x1 x2 callback -- result )
 534     test_struct_15 { float float } cdecl alien-indirect ;
 535
 536 [ 1.0 2.0 ] [
 537     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 538 ] unit-test
 539
 540 STRUCT: test_struct_16
 541     { x float }
 542     { a int } ;
 543
 544 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 545
 546 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 547
 548 : callback-13 ( -- callback )
 549     test_struct_16 { float int } cdecl
 550     [
 551         test_struct_16 <struct>
 552             swap >>a
 553             swap >>x
 554     ] alien-callback ;
 555
 556 : callback-13-test ( x1 x2 callback -- result )
 557     test_struct_16 { float int } cdecl alien-indirect ;
 558
 559 [ 1.0 2 ] [
 560     1.0 2 callback-13 callback-13-test
 561     [ x>> ] [ a>> ] bi
 562 ] unit-test
 563
 564 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 565
 566 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 567
 568 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 569
 570 [ ] [ stack-frame-bustage 2drop ] unit-test
 571
 572 ! C99 tests
 573 os windows? [
 574
 575 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 576
 577 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 578
 579 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 580
 581 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 582
 583 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 584
 585 [ C{ 4.0 4.0 } ] [
 586     C{ 1.0 2.0 }
 587     C{ 1.5 1.0 } ffi_test_47
 588 ] unit-test
 589
 590 ! Reported by jedahu
 591 STRUCT: bool-field-test
 592     { name c-string }
 593     { on bool }
 594     { parents short } ;
 595
 596 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 597
 598 [ 123 ] [
 599     bool-field-test <struct>
 600         123 >>parents
 601     ffi_test_48
 602 ] unit-test
 603
 604 ] unless
 605
 606 ! Test interaction between threads and callbacks
 607 : thread-callback-1 ( -- callback )
 608     int { } cdecl [ yield 100 ] alien-callback ;
 609
 610 : thread-callback-2 ( -- callback )
 611     int { } cdecl [ yield 200 ] alien-callback ;
 612
 613 : thread-callback-invoker ( callback -- n )
 614     int { } cdecl alien-indirect ;
 615
 616 <promise> "p" set
 617 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
 618 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
 619 [ 100 ] [ "p" get ?promise ] unit-test
 620
 621 ! More alien-assembly tests are in cpu.* vocabs
 622 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 623
 624 [ ] [ assembly-test-1 ] unit-test
 625
 626 [ f ] [ "f-fastcall" load-library f = ] unit-test
 627 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
 628
 629 : ffi_test_49 ( x -- int )
 630     int "f-fastcall" "ffi_test_49" { int }
 631     alien-invoke gc ;
 632 : ffi_test_50 ( x y -- int )
 633     int "f-fastcall" "ffi_test_50" { int int }
 634     alien-invoke gc ;
 635 : ffi_test_51 ( x y z -- int )
 636     int "f-fastcall" "ffi_test_51" { int int int }
 637     alien-invoke gc ;
 638 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
 639     [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
 640     3dip
 641     int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
 642
 643 [ 4 ] [ 3 ffi_test_49 ] unit-test
 644 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
 645 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
 646 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
 647
 648 : ffi_test_52 ( x y z -- int )
 649     int "f-fastcall" "ffi_test_52" { int float int }
 650     alien-invoke gc ;
 651 : ffi_test_53 ( x y z w -- int )
 652     int "f-fastcall" "ffi_test_53" { int float int int }
 653     alien-invoke gc ;
 654 : ffi_test_57 ( x y -- test-struct-11 )
 655     test-struct-11 "f-fastcall" "ffi_test_57" { int int }
 656     alien-invoke gc ;
 657 : ffi_test_58 ( x y z -- test-struct-11 )
 658     test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
 659     alien-invoke gc ;
 660
 661 ! GCC bugs
 662 mingw? [
 663     [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
 664
 665     [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
 666 ] unless
 667
 668 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
 669
 670 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
 671
 672 : fastcall-ii-indirect ( x y ptr -- result )
 673     int { int int } fastcall alien-indirect ;
 674
 675 : fastcall-iii-indirect ( x y z ptr -- result )
 676     int { int int int } fastcall alien-indirect ;
 677
 678 : fastcall-ifi-indirect ( x y z ptr -- result )
 679     int { int float int } fastcall alien-indirect ;
 680
 681 : fastcall-ifii-indirect ( x y z w ptr -- result )
 682     int { int float int int } fastcall alien-indirect ;
 683
 684 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 685     test-struct-11 { int int } fastcall alien-indirect ;
 686
 687 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 688     test-struct-11 { int int int } fastcall alien-indirect ;
 689
 690 : win32? ( -- ? ) os windows? cpu x86.32? and ;
 691
 692 [ 8 ] [
 693     3 4
 694     win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
 695     fastcall-ii-indirect
 696 ] unit-test
 697
 698 [ 13 ] [
 699     3 4 5
 700     win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
 701     fastcall-iii-indirect
 702 ] unit-test
 703
 704 mingw? [
 705     [ 13 ] [
 706         3 4.0 5
 707         win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
 708         fastcall-ifi-indirect
 709     ] unit-test
 710
 711     [ 19 ] [
 712         3 4.0 5 6
 713         win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
 714         fastcall-ifii-indirect
 715     ] unit-test
 716 ] unless
 717
 718 [ S{ test-struct-11 f 7 -1 } ]
 719 [
 720     3 4
 721     win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
 722     fastcall-struct-return-ii-indirect
 723 ] unit-test
 724
 725 [ S{ test-struct-11 f 7 -3 } ]
 726 [
 727     3 4 7
 728     win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
 729     fastcall-struct-return-iii-indirect
 730 ] unit-test
 731
 732 : fastcall-ii-callback ( -- ptr )
 733     int { int int } fastcall [ + 1 + ] alien-callback ;
 734
 735 : fastcall-iii-callback ( -- ptr )
 736     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 737
 738 : fastcall-ifi-callback ( -- ptr )
 739     int { int float int } fastcall
 740     [ [ >integer ] dip + + 1 + ] alien-callback ;
 741
 742 : fastcall-ifii-callback ( -- ptr )
 743     int { int float int int } fastcall
 744     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 745
 746 : fastcall-struct-return-ii-callback ( -- ptr )
 747     test-struct-11 { int int } fastcall
 748     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 749
 750 : fastcall-struct-return-iii-callback ( -- ptr )
 751     test-struct-11 { int int int } fastcall
 752     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 753
 754 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
 755
 756 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
 757
 758 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
 759
 760 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
 761
 762 [ S{ test-struct-11 f 7 -1 } ]
 763 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
 764
 765 [ S{ test-struct-11 f 7 -3 } ]
 766 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
 767
 768 : x64-regression-1 ( -- c )
 769     int { int int int int int } cdecl [ + + + + ] alien-callback ;
 770
 771 : x64-regression-2 ( x x x x x c -- y )
 772     int { int int int int int } cdecl alien-indirect ; inline
 773
 774 [ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test
 775
 776 ! Stack allocation
 777 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
 778
 779 [ 3 ] [ blah ] unit-test
 780
 781 : out-param-test-1 ( -- b )
 782     { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 783
 784 [ 12 ] [ out-param-test-1 ] unit-test
 785
 786 : out-param-test-2 ( -- b )
 787     { { int initial: 12 } } [ drop ] with-out-parameters ;
 788
 789 [ 12 ] [ out-param-test-2 ] unit-test
 790
 791 : out-param-test-3 ( -- x y )
 792     { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
 793     with-out-parameters
 794     [ x>> ] [ y>> ] bi ;
 795
 796 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 797
 798 : out-param-callback ( -- a )
 799     void { int pointer: int } cdecl
 800     [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
 801
 802 : out-param-indirect ( a a -- b )
 803     { int } [
 804         swap void { int pointer: int } cdecl
 805         alien-indirect
 806     ] with-out-parameters ;
 807
 808 [ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
 809
 810 ! Alias analysis regression
 811 : aa-callback-1 ( -- c )
 812     double { } cdecl [ 5.0 ] alien-callback ;
 813
 814 : aa-indirect-1 ( c -- x )
 815     double { } cdecl alien-indirect ; inline
 816
 817 TUPLE: some-tuple x ;
 818
 819 [ T{ some-tuple f 5.0 } ] [
 820     [
 821         some-tuple new
 822         aa-callback-1
 823         aa-indirect-1 >>x
 824     ] compile-call
 825 ] unit-test
 826
 827 ! GC maps regression
 828 : anton's-regression ( -- )
 829     f (free) f (free) ;
 830
 831 [ ] [ anton's-regression ] unit-test