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