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 callback -- arg' )
 448     [ f f ] 2dip
 449     void { void* void* double-rect } cdecl alien-indirect
 450     "example" get-global ;
 451
 452 [ 1.0 2.0 3.0 4.0 ]
 453 [
 454     1.0 2.0 3.0 4.0 <double-rect>
 455     double-rect-callback double-rect-test
 456     >double-rect<
 457 ] unit-test
 458
 459 STRUCT: test_struct_14
 460     { x1 double }
 461     { x2 double } ;
 462
 463 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 464
 465 [ 1.0 2.0 ] [
 466     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 467 ] unit-test
 468
 469 : callback-10 ( -- callback )
 470     test_struct_14 { double double } cdecl
 471     [
 472         test_struct_14 <struct>
 473             swap >>x2
 474             swap >>x1
 475     ] alien-callback ;
 476
 477 : callback-10-test ( x1 x2 callback -- result )
 478     test_struct_14 { double double } cdecl alien-indirect ;
 479
 480 [ 1.0 2.0 ] [
 481     1.0 2.0 callback-10 callback-10-test
 482     [ x1>> ] [ x2>> ] bi
 483 ] unit-test
 484
 485 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 486
 487 [ 1 2.0 ] [
 488     1 2.0 ffi_test_41
 489     [ a>> ] [ x>> ] bi
 490 ] unit-test
 491
 492 : callback-11 ( -- callback )
 493     test-struct-12 { int double } cdecl
 494     [
 495         test-struct-12 <struct>
 496             swap >>x
 497             swap >>a
 498     ] alien-callback ;
 499
 500 : callback-11-test ( x1 x2 callback -- result )
 501     test-struct-12 { int double } cdecl alien-indirect ;
 502
 503 [ 1 2.0 ] [
 504     1 2.0 callback-11 callback-11-test
 505     [ a>> ] [ x>> ] bi
 506 ] unit-test
 507
 508 STRUCT: test_struct_15
 509     { x float }
 510     { y float } ;
 511
 512 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 513
 514 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 515
 516 : callback-12 ( -- callback )
 517     test_struct_15 { float float } cdecl
 518     [
 519         test_struct_15 <struct>
 520             swap >>y
 521             swap >>x
 522     ] alien-callback ;
 523
 524 : callback-12-test ( x1 x2 callback -- result )
 525     test_struct_15 { float float } cdecl alien-indirect ;
 526
 527 [ 1.0 2.0 ] [
 528     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 529 ] unit-test
 530
 531 STRUCT: test_struct_16
 532     { x float }
 533     { a int } ;
 534
 535 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 536
 537 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 538
 539 : callback-13 ( -- callback )
 540     test_struct_16 { float int } cdecl
 541     [
 542         test_struct_16 <struct>
 543             swap >>a
 544             swap >>x
 545     ] alien-callback ;
 546
 547 : callback-13-test ( x1 x2 callback -- result )
 548     test_struct_16 { float int } cdecl alien-indirect ;
 549
 550 [ 1.0 2 ] [
 551     1.0 2 callback-13 callback-13-test
 552     [ x>> ] [ a>> ] bi
 553 ] unit-test
 554
 555 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 556
 557 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 558
 559 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 560
 561 [ ] [ stack-frame-bustage 2drop ] unit-test
 562
 563 ! C99 tests
 564 os windows? [
 565
 566 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 567
 568 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 569
 570 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 571
 572 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 573
 574 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 575
 576 [ C{ 4.0 4.0 } ] [
 577     C{ 1.0 2.0 }
 578     C{ 1.5 1.0 } ffi_test_47
 579 ] unit-test
 580
 581 ! Reported by jedahu
 582 STRUCT: bool-field-test
 583     { name c-string }
 584     { on bool }
 585     { parents short } ;
 586
 587 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 588
 589 [ 123 ] [
 590     bool-field-test <struct>
 591         123 >>parents
 592     ffi_test_48
 593 ] unit-test
 594
 595 ] unless
 596
 597 ! Test interaction between threads and callbacks
 598 : thread-callback-1 ( -- callback )
 599     int { } cdecl [ yield 100 ] alien-callback ;
 600
 601 : thread-callback-2 ( -- callback )
 602     int { } cdecl [ yield 200 ] alien-callback ;
 603
 604 : thread-callback-invoker ( callback -- n )
 605     int { } cdecl alien-indirect ;
 606
 607 <promise> "p" set
 608 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
 609 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
 610 [ 100 ] [ "p" get ?promise ] unit-test
 611
 612 ! Regression: calling an undefined function would raise a protection fault
 613 FUNCTION: void this_does_not_exist ( ) ;
 614
 615 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
 616
 617 ! More alien-assembly tests are in cpu.* vocabs
 618 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 619
 620 [ ] [ assembly-test-1 ] unit-test
 621
 622 [ f ] [ "f-fastcall" load-library f = ] unit-test
 623 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
 624
 625 : ffi_test_49 ( x -- int )
 626     int "f-fastcall" "ffi_test_49" { int }
 627     alien-invoke gc ;
 628 : ffi_test_50 ( x y -- int )
 629     int "f-fastcall" "ffi_test_50" { int int }
 630     alien-invoke gc ;
 631 : ffi_test_51 ( x y z -- int )
 632     int "f-fastcall" "ffi_test_51" { int int int }
 633     alien-invoke gc ;
 634 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
 635     [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
 636     3dip
 637     int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
 638
 639 [ 4 ] [ 3 ffi_test_49 ] unit-test
 640 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
 641 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
 642 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
 643
 644 : ffi_test_52 ( x y z -- int )
 645     int "f-fastcall" "ffi_test_52" { int float int }
 646     alien-invoke gc ;
 647 : ffi_test_53 ( x y z w -- int )
 648     int "f-fastcall" "ffi_test_53" { int float int int }
 649     alien-invoke gc ;
 650 : ffi_test_57 ( x y -- test-struct-11 )
 651     test-struct-11 "f-fastcall" "ffi_test_57" { int int }
 652     alien-invoke gc ;
 653 : ffi_test_58 ( x y z -- test-struct-11 )
 654     test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
 655     alien-invoke gc ;
 656
 657 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
 658 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
 659 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
 660 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
 661
 662 : fastcall-ii-indirect ( x y ptr -- result )
 663     int { int int } fastcall alien-indirect ;
 664 : fastcall-iii-indirect ( x y z ptr -- result )
 665     int { int int int } fastcall alien-indirect ;
 666 : fastcall-ifi-indirect ( x y z ptr -- result )
 667     int { int float int } fastcall alien-indirect ;
 668 : fastcall-ifii-indirect ( x y z w ptr -- result )
 669     int { int float int int } fastcall alien-indirect ;
 670 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 671     test-struct-11 { int int } fastcall alien-indirect ;
 672 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 673     test-struct-11 { int int int } fastcall alien-indirect ;
 674
 675 [ 8 ] [ 3 4 &: ffi_test_50 fastcall-ii-indirect ] unit-test
 676 [ 13 ] [ 3 4 5 &: ffi_test_51 fastcall-iii-indirect ] unit-test
 677 [ 13 ] [ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect ] unit-test
 678 [ 19 ] [ 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect ] unit-test
 679
 680 [ S{ test-struct-11 f 7 -1 } ]
 681 [ 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect ] unit-test
 682
 683 [ S{ test-struct-11 f 7 -3 } ]
 684 [ 3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect ] unit-test
 685
 686 : fastcall-ii-callback ( -- ptr )
 687     int { int int } fastcall [ + 1 + ] alien-callback ;
 688 : fastcall-iii-callback ( -- ptr )
 689     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 690 : fastcall-ifi-callback ( -- ptr )
 691     int { int float int } fastcall
 692     [ [ >integer ] dip + + 1 + ] alien-callback ;
 693 : fastcall-ifii-callback ( -- ptr )
 694     int { int float int int } fastcall
 695     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 696 : fastcall-struct-return-ii-callback ( -- ptr )
 697     test-struct-11 { int int } fastcall
 698     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 699 : fastcall-struct-return-iii-callback ( -- ptr )
 700     test-struct-11 { int int int } fastcall
 701     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 702
 703 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
 704 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
 705 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
 706 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
 707
 708 [ S{ test-struct-11 f 7 -1 } ]
 709 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
 710
 711 [ S{ test-struct-11 f 7 -3 } ]
 712 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test