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 windows? ]  [ "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 >c-array
 231     { 4.0 5.0 6.0 } float >c-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 : callback-throws ( -- x )
 338     int { } cdecl [ "Hi" throw ] alien-callback ;
 339
 340 [ t ] [ callback-throws alien? ] unit-test
 341
 342 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 343
 344 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 345
 346 [ t ] [ callback-1 alien? ] unit-test
 347
 348 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 349
 350 [ ] [ callback-1 callback_test_1 ] unit-test
 351
 352 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 353
 354 [ ] [ callback-2 callback_test_1 ] unit-test
 355
 356 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 357
 358 [ t 3 5 ] [
 359     [
 360         namestack*
 361         3 "x" set callback-3 callback_test_1
 362         namestack* eq?
 363         "x" get "x" get-global
 364     ] with-scope
 365 ] unit-test
 366
 367 : callback-5 ( -- callback )
 368     void { } cdecl [ gc ] alien-callback ;
 369
 370 [ "testing" ] [
 371     "testing" callback-5 callback_test_1
 372 ] unit-test
 373
 374 : callback-5b ( -- callback )
 375     void { } cdecl [ compact-gc ] alien-callback ;
 376
 377 [ "testing" ] [
 378     "testing" callback-5b callback_test_1
 379 ] unit-test
 380
 381 : callback-6 ( -- callback )
 382     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 383
 384 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 385
 386 : callback-7 ( -- callback )
 387     void { } cdecl [ 1000000 sleep ] alien-callback ;
 388
 389 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 390
 391 [ f ] [ namespace global eq? ] unit-test
 392
 393 : callback-8 ( -- callback )
 394     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 395
 396 [ ] [ callback-8 callback_test_1 ] unit-test
 397
 398 : callback-9 ( -- callback )
 399     int { int int int } cdecl [
 400         + + 1 +
 401     ] alien-callback ;
 402
 403 FUNCTION: void ffi_test_36_point_5 ( ) ;
 404
 405 [ ] [ ffi_test_36_point_5 ] unit-test
 406
 407 FUNCTION: int ffi_test_37 ( void* func ) ;
 408
 409 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 410
 411 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
 412
 413 STRUCT: test_struct_13
 414 { x1 float }
 415 { x2 float }
 416 { x3 float }
 417 { x4 float }
 418 { x5 float }
 419 { x6 float } ;
 420
 421 : make-test-struct-13 ( -- alien )
 422     test_struct_13 <struct>
 423         1.0 >>x1
 424         2.0 >>x2
 425         3.0 >>x3
 426         4.0 >>x4
 427         5.0 >>x5
 428         6.0 >>x6 ;
 429
 430 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 431
 432 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 433
 434 ! Joe Groff found this problem
 435 STRUCT: double-rect
 436 { a double }
 437 { b double }
 438 { c double }
 439 { d double } ;
 440
 441 : <double-rect> ( a b c d -- foo )
 442     double-rect <struct>
 443         swap >>d
 444         swap >>c
 445         swap >>b
 446         swap >>a ;
 447
 448 : >double-rect< ( foo -- a b c d )
 449     {
 450         [ a>> ]
 451         [ b>> ]
 452         [ c>> ]
 453         [ d>> ]
 454     } cleave ;
 455
 456 : double-rect-callback ( -- alien )
 457     void { void* void* double-rect } cdecl
 458     [ "example" set-global 2drop ] alien-callback ;
 459
 460 : double-rect-test ( arg callback -- arg' )
 461     [ f f ] 2dip
 462     void { void* void* double-rect } cdecl alien-indirect
 463     "example" get-global ;
 464
 465 [ byte-array 1.0 2.0 3.0 4.0 ]
 466 [
 467     1.0 2.0 3.0 4.0 <double-rect>
 468     double-rect-callback double-rect-test
 469     [ >c-ptr class ] [ >double-rect< ] bi
 470 ] unit-test
 471
 472 STRUCT: test_struct_14
 473     { x1 double }
 474     { x2 double } ;
 475
 476 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 477
 478 [ 1.0 2.0 ] [
 479     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 480 ] unit-test
 481
 482 : callback-10 ( -- callback )
 483     test_struct_14 { double double } cdecl
 484     [
 485         test_struct_14 <struct>
 486             swap >>x2
 487             swap >>x1
 488     ] alien-callback ;
 489
 490 : callback-10-test ( x1 x2 callback -- result )
 491     test_struct_14 { double double } cdecl alien-indirect ;
 492
 493 [ 1.0 2.0 ] [
 494     1.0 2.0 callback-10 callback-10-test
 495     [ x1>> ] [ x2>> ] bi
 496 ] unit-test
 497
 498 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 499
 500 [ 1 2.0 ] [
 501     1 2.0 ffi_test_41
 502     [ a>> ] [ x>> ] bi
 503 ] unit-test
 504
 505 : callback-11 ( -- callback )
 506     test-struct-12 { int double } cdecl
 507     [
 508         test-struct-12 <struct>
 509             swap >>x
 510             swap >>a
 511     ] alien-callback ;
 512
 513 : callback-11-test ( x1 x2 callback -- result )
 514     test-struct-12 { int double } cdecl alien-indirect ;
 515
 516 [ 1 2.0 ] [
 517     1 2.0 callback-11 callback-11-test
 518     [ a>> ] [ x>> ] bi
 519 ] unit-test
 520
 521 STRUCT: test_struct_15
 522     { x float }
 523     { y float } ;
 524
 525 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 526
 527 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 528
 529 : callback-12 ( -- callback )
 530     test_struct_15 { float float } cdecl
 531     [
 532         test_struct_15 <struct>
 533             swap >>y
 534             swap >>x
 535     ] alien-callback ;
 536
 537 : callback-12-test ( x1 x2 callback -- result )
 538     test_struct_15 { float float } cdecl alien-indirect ;
 539
 540 [ 1.0 2.0 ] [
 541     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 542 ] unit-test
 543
 544 STRUCT: test_struct_16
 545     { x float }
 546     { a int } ;
 547
 548 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 549
 550 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 551
 552 : callback-13 ( -- callback )
 553     test_struct_16 { float int } cdecl
 554     [
 555         test_struct_16 <struct>
 556             swap >>a
 557             swap >>x
 558     ] alien-callback ;
 559
 560 : callback-13-test ( x1 x2 callback -- result )
 561     test_struct_16 { float int } cdecl alien-indirect ;
 562
 563 [ 1.0 2 ] [
 564     1.0 2 callback-13 callback-13-test
 565     [ x>> ] [ a>> ] bi
 566 ] unit-test
 567
 568 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 569
 570 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 571
 572 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 573
 574 [ ] [ stack-frame-bustage 2drop ] unit-test
 575
 576 ! C99 tests
 577 os windows? [
 578
 579 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 580
 581 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 582
 583 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 584
 585 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 586
 587 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 588
 589 [ C{ 4.0 4.0 } ] [
 590     C{ 1.0 2.0 }
 591     C{ 1.5 1.0 } ffi_test_47
 592 ] unit-test
 593
 594 ! Reported by jedahu
 595 STRUCT: bool-field-test
 596     { name c-string }
 597     { on bool }
 598     { parents short } ;
 599
 600 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 601
 602 [ 123 ] [
 603     bool-field-test <struct>
 604         123 >>parents
 605     ffi_test_48
 606 ] unit-test
 607
 608 ] unless
 609
 610 ! Test interaction between threads and callbacks
 611 : thread-callback-1 ( -- callback )
 612     int { } cdecl [ yield 100 ] alien-callback ;
 613
 614 : thread-callback-2 ( -- callback )
 615     int { } cdecl [ yield 200 ] alien-callback ;
 616
 617 : thread-callback-invoker ( callback -- n )
 618     int { } cdecl alien-indirect ;
 619
 620 <promise> "p" set
 621 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
 622 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
 623 [ 100 ] [ "p" get ?promise ] unit-test
 624
 625 ! More alien-assembly tests are in cpu.* vocabs
 626 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 627
 628 [ ] [ assembly-test-1 ] unit-test
 629
 630 [ f ] [ "f-fastcall" load-library f = ] unit-test
 631 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
 632
 633 : ffi_test_49 ( x -- int )
 634     int "f-fastcall" "ffi_test_49" { int }
 635     alien-invoke gc ;
 636 : ffi_test_50 ( x y -- int )
 637     int "f-fastcall" "ffi_test_50" { int int }
 638     alien-invoke gc ;
 639 : ffi_test_51 ( x y z -- int )
 640     int "f-fastcall" "ffi_test_51" { int int int }
 641     alien-invoke gc ;
 642 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
 643     [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
 644     3dip
 645     int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
 646
 647 [ 4 ] [ 3 ffi_test_49 ] unit-test
 648 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
 649 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
 650 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
 651
 652 : ffi_test_52 ( x y z -- int )
 653     int "f-fastcall" "ffi_test_52" { int float int }
 654     alien-invoke gc ;
 655 : ffi_test_53 ( x y z w -- int )
 656     int "f-fastcall" "ffi_test_53" { int float int int }
 657     alien-invoke gc ;
 658 : ffi_test_57 ( x y -- test-struct-11 )
 659     test-struct-11 "f-fastcall" "ffi_test_57" { int int }
 660     alien-invoke gc ;
 661 : ffi_test_58 ( x y z -- test-struct-11 )
 662     test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
 663     alien-invoke gc ;
 664
 665 ! GCC bugs
 666 mingw? [
 667     [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
 668
 669     [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
 670 ] unless
 671
 672 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
 673
 674 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
 675
 676 : fastcall-ii-indirect ( x y ptr -- result )
 677     int { int int } fastcall alien-indirect ;
 678
 679 : fastcall-iii-indirect ( x y z ptr -- result )
 680     int { int int int } fastcall alien-indirect ;
 681
 682 : fastcall-ifi-indirect ( x y z ptr -- result )
 683     int { int float int } fastcall alien-indirect ;
 684
 685 : fastcall-ifii-indirect ( x y z w ptr -- result )
 686     int { int float int int } fastcall alien-indirect ;
 687
 688 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 689     test-struct-11 { int int } fastcall alien-indirect ;
 690
 691 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 692     test-struct-11 { int int int } fastcall alien-indirect ;
 693
 694 : win32? ( -- ? ) os windows? cpu x86.32? and ;
 695
 696 [ 8 ] [
 697     3 4
 698     win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
 699     fastcall-ii-indirect
 700 ] unit-test
 701
 702 [ 13 ] [
 703     3 4 5
 704     win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
 705     fastcall-iii-indirect
 706 ] unit-test
 707
 708 mingw? [
 709     [ 13 ] [
 710         3 4.0 5
 711         win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
 712         fastcall-ifi-indirect
 713     ] unit-test
 714
 715     [ 19 ] [
 716         3 4.0 5 6
 717         win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
 718         fastcall-ifii-indirect
 719     ] unit-test
 720 ] unless
 721
 722 [ S{ test-struct-11 f 7 -1 } ]
 723 [
 724     3 4
 725     win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
 726     fastcall-struct-return-ii-indirect
 727 ] unit-test
 728
 729 [ S{ test-struct-11 f 7 -3 } ]
 730 [
 731     3 4 7
 732     win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
 733     fastcall-struct-return-iii-indirect
 734 ] unit-test
 735
 736 : fastcall-ii-callback ( -- ptr )
 737     int { int int } fastcall [ + 1 + ] alien-callback ;
 738
 739 : fastcall-iii-callback ( -- ptr )
 740     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 741
 742 : fastcall-ifi-callback ( -- ptr )
 743     int { int float int } fastcall
 744     [ [ >integer ] dip + + 1 + ] alien-callback ;
 745
 746 : fastcall-ifii-callback ( -- ptr )
 747     int { int float int int } fastcall
 748     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 749
 750 : fastcall-struct-return-ii-callback ( -- ptr )
 751     test-struct-11 { int int } fastcall
 752     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 753
 754 : fastcall-struct-return-iii-callback ( -- ptr )
 755     test-struct-11 { int int int } fastcall
 756     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 757
 758 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
 759
 760 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
 761
 762 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
 763
 764 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
 765
 766 [ S{ test-struct-11 f 7 -1 } ]
 767 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
 768
 769 [ S{ test-struct-11 f 7 -3 } ]
 770 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
 771
 772 : x64-regression-1 ( -- c )
 773     int { int int int int int } cdecl [ + + + + ] alien-callback ;
 774
 775 : x64-regression-2 ( x x x x x c -- y )
 776     int { int int int int int } cdecl alien-indirect ; inline
 777
 778 [ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test
 779
 780 ! Stack allocation
 781 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
 782
 783 [ 3 ] [ blah ] unit-test
 784
 785 : out-param-test-1 ( -- b )
 786     { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 787
 788 [ 12 ] [ out-param-test-1 ] unit-test
 789
 790 : out-param-test-2 ( -- b )
 791     { { int initial: 12 } } [ drop ] with-out-parameters ;
 792
 793 [ 12 ] [ out-param-test-2 ] unit-test
 794
 795 : out-param-test-3 ( -- x y )
 796     { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
 797     with-out-parameters
 798     [ x>> ] [ y>> ] bi ;
 799
 800 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 801
 802 : out-param-callback ( -- a )
 803     void { int pointer: int } cdecl
 804     [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
 805
 806 : out-param-indirect ( a a -- b )
 807     { int } [
 808         swap void { int pointer: int } cdecl
 809         alien-indirect
 810     ] with-out-parameters ;
 811
 812 [ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
 813
 814 ! Alias analysis regression
 815 : aa-callback-1 ( -- c )
 816     double { } cdecl [ 5.0 ] alien-callback ;
 817
 818 : aa-indirect-1 ( c -- x )
 819     double { } cdecl alien-indirect ; inline
 820
 821 TUPLE: some-tuple x ;
 822
 823 [ T{ some-tuple f 5.0 } ] [
 824     [
 825         some-tuple new
 826         aa-callback-1
 827         aa-indirect-1 >>x
 828     ] compile-call
 829 ] unit-test
 830
 831 ! GC maps regression
 832 : anton's-regression ( -- )
 833     f (free) f (free) ;
 834
 835 [ ] [ anton's-regression ] unit-test