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