basis/compiler/tests/alien.factor

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