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