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