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