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