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