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 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
  24
  25 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
  26
  27 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
  28
  29 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
  30 >>
  31
  32 LIBRARY: f-cdecl
  33
  34 FUNCTION: void ffi_test_0 ;
  35 [ ] [ ffi_test_0 ] unit-test
  36
  37 FUNCTION: int ffi_test_1 ;
  38 [ 3 ] [ ffi_test_1 ] unit-test
  39
  40 FUNCTION: int ffi_test_2 int x int y ;
  41 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
  42 [ "hi" 3 ffi_test_2 ] must-fail
  43
  44 FUNCTION: int ffi_test_3 int x int y int z int t ;
  45 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
  46
  47 FUNCTION: float ffi_test_4 ;
  48 [ 1.5 ] [ ffi_test_4 ] unit-test
  49
  50 FUNCTION: double ffi_test_5 ;
  51 [ 1.5 ] [ ffi_test_5 ] unit-test
  52
  53 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
  54 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
  55 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
  56 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
  57
  58 STRUCT: FOO { x int } { y int } ;
  59
  60 : make-FOO ( x y -- FOO )
  61     FOO <struct> swap >>y swap >>x ;
  62
  63 FUNCTION: int ffi_test_11 int a FOO b int c ;
  64
  65 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
  66
  67 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 ;
  68
  69 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
  70
  71 FUNCTION: FOO ffi_test_14 int x int y ;
  72
  73 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
  74
  75 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
  76
  77 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
  78 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
  79 [ 1 2 ffi_test_15 ] must-fail
  80
  81 STRUCT: BAR { x long } { y long } { z long } ;
  82
  83 FUNCTION: BAR ffi_test_16 long x long y long z ;
  84
  85 [ 11 6 -7 ] [
  86     11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
  87 ] unit-test
  88
  89 STRUCT: TINY { x int } ;
  90
  91 FUNCTION: TINY ffi_test_17 int x ;
  92
  93 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
  94
  95 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
  96
  97 : indirect-test-1 ( ptr -- result )
  98     int { } cdecl alien-indirect ;
  99
 100 { 1 1 } [ indirect-test-1 ] must-infer-as
 101
 102 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
 103
 104 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 105
 106 : indirect-test-1' ( ptr -- )
 107     int { } cdecl alien-indirect drop ;
 108
 109 { 1 0 } [ indirect-test-1' ] must-infer-as
 110
 111 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 112
 113 [ -1 indirect-test-1 ] must-fail
 114
 115 : indirect-test-2 ( x y ptr -- result )
 116     int { int int } cdecl alien-indirect gc ;
 117
 118 { 3 1 } [ indirect-test-2 ] must-infer-as
 119
 120 [ 5 ]
 121 [ 2 3 &: ffi_test_2 indirect-test-2 ]
 122 unit-test
 123
 124 : indirect-test-3 ( a b c d ptr -- result )
 125     int { int int int int } stdcall alien-indirect
 126     gc ;
 127
 128 [ f ] [ "f-stdcall" load-library f = ] unit-test
 129 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
 130
 131 : ffi_test_18 ( w x y z -- int )
 132     int "f-stdcall" "ffi_test_18" { int int int int }
 133     alien-invoke gc ;
 134
 135 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 136
 137 : ffi_test_19 ( x y z -- BAR )
 138     BAR "f-stdcall" "ffi_test_19" { long long long }
 139     alien-invoke gc ;
 140
 141 [ 11 6 -7 ] [
 142     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 143 ] unit-test
 144
 145 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
 146     [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
 147     4 ndip
 148     int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
 149     gc ;
 150
 151 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
 152
 153 FUNCTION: double ffi_test_6 float x float y ;
 154 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 155 [ "a" "b" ffi_test_6 ] must-fail
 156
 157 FUNCTION: double ffi_test_7 double x double y ;
 158 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 159
 160 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 161 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 162
 163 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 164 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 165
 166 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 167     double y1, double y2, double y3,
 168     double z1, double z2, double z3 ;
 169
 170 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 171
 172 ! Make sure XT doesn't get clobbered in stack frame
 173
 174 : 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 )
 175     int
 176     "f-cdecl" "ffi_test_31"
 177     { 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 }
 178     alien-invoke gc 3 ;
 179
 180 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 181
 182 : 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 )
 183     float
 184     "f-cdecl" "ffi_test_31_point_5"
 185     { 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 }
 186     alien-invoke ;
 187
 188 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 189
 190 FUNCTION: longlong ffi_test_21 long x long y ;
 191
 192 [ 121932631112635269 ]
 193 [ 123456789 987654321 ffi_test_21 ] unit-test
 194
 195 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 196
 197 [ 987655432 ]
 198 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 199
 200 [ 1111 f 123456789 ffi_test_22 ] must-fail
 201
 202 STRUCT: RECT
 203     { x float } { y float }
 204     { w float } { h float } ;
 205
 206 : <RECT> ( x y w h -- rect )
 207     RECT <struct>
 208         swap >>h
 209         swap >>w
 210         swap >>y
 211         swap >>x ;
 212
 213 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
 214
 215 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 216
 217 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 218
 219 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 220
 221 [ 32.0 ] [
 222     { 1.0 2.0 3.0 } >float-array
 223     { 4.0 5.0 6.0 } >float-array
 224     ffi_test_23
 225 ] unit-test
 226
 227 ! Test odd-size structs
 228 STRUCT: test-struct-1 { x char[1] } ;
 229
 230 FUNCTION: test-struct-1 ffi_test_24 ;
 231
 232 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
 233
 234 STRUCT: test-struct-2 { x char[2] } ;
 235
 236 FUNCTION: test-struct-2 ffi_test_25 ;
 237
 238 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
 239
 240 STRUCT: test-struct-3 { x char[3] } ;
 241
 242 FUNCTION: test-struct-3 ffi_test_26 ;
 243
 244 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
 245
 246 STRUCT: test-struct-4 { x char[4] } ;
 247
 248 FUNCTION: test-struct-4 ffi_test_27 ;
 249
 250 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
 251
 252 STRUCT: test-struct-5 { x char[5] } ;
 253
 254 FUNCTION: test-struct-5 ffi_test_28 ;
 255
 256 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
 257
 258 STRUCT: test-struct-6 { x char[6] } ;
 259
 260 FUNCTION: test-struct-6 ffi_test_29 ;
 261
 262 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
 263
 264 STRUCT: test-struct-7 { x char[7] } ;
 265
 266 FUNCTION: test-struct-7 ffi_test_30 ;
 267
 268 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
 269
 270 STRUCT: test-struct-8 { x double } { y double } ;
 271
 272 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 273
 274 [ 9.0 ] [
 275     test-struct-8 <struct>
 276     1.0 >>x
 277     2.0 >>y
 278     3 ffi_test_32
 279 ] unit-test
 280
 281 STRUCT: test-struct-9 { x float } { y float } ;
 282
 283 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 284
 285 [ 9.0 ] [
 286     test-struct-9 <struct>
 287     1.0 >>x
 288     2.0 >>y
 289     3 ffi_test_33
 290 ] unit-test
 291
 292 STRUCT: test-struct-10 { x float } { y int } ;
 293
 294 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 295
 296 [ 9.0 ] [
 297     test-struct-10 <struct>
 298     1.0 >>x
 299     2 >>y
 300     3 ffi_test_34
 301 ] unit-test
 302
 303 STRUCT: test-struct-11 { x int } { y int } ;
 304
 305 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 306
 307 [ 9.0 ] [
 308     test-struct-11 <struct>
 309     1 >>x
 310     2 >>y
 311     3 ffi_test_35
 312 ] unit-test
 313
 314 STRUCT: test-struct-12 { a int } { x double } ;
 315
 316 : make-struct-12 ( x -- alien )
 317     test-struct-12 <struct>
 318         swap >>x ;
 319
 320 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 321
 322 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 323
 324 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 325
 326 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 327
 328 ! Test callbacks
 329
 330 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 331
 332 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 333
 334 [ t ] [ callback-1 alien? ] unit-test
 335
 336 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 337
 338 [ ] [ callback-1 callback_test_1 ] unit-test
 339
 340 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 341
 342 [ ] [ callback-2 callback_test_1 ] unit-test
 343
 344 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 345
 346 [ t 3 5 ] [
 347     [
 348         namestack*
 349         3 "x" set callback-3 callback_test_1
 350         namestack* eq?
 351         "x" get "x" get-global
 352     ] with-scope
 353 ] unit-test
 354
 355 : callback-5 ( -- callback )
 356     void { } cdecl [ gc ] alien-callback ;
 357
 358 [ "testing" ] [
 359     "testing" callback-5 callback_test_1
 360 ] unit-test
 361
 362 : callback-5b ( -- callback )
 363     void { } cdecl [ compact-gc ] alien-callback ;
 364
 365 [ "testing" ] [
 366     "testing" callback-5b callback_test_1
 367 ] unit-test
 368
 369 : callback-6 ( -- callback )
 370     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 371
 372 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 373
 374 : callback-7 ( -- callback )
 375     void { } cdecl [ 1000000 sleep ] alien-callback ;
 376
 377 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 378
 379 [ f ] [ namespace global eq? ] unit-test
 380
 381 : callback-8 ( -- callback )
 382     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 383
 384 [ ] [ callback-8 callback_test_1 ] unit-test
 385
 386 : callback-9 ( -- callback )
 387     int { int int int } cdecl [
 388         + + 1 +
 389     ] alien-callback ;
 390
 391 FUNCTION: void ffi_test_36_point_5 ( ) ;
 392
 393 [ ] [ ffi_test_36_point_5 ] unit-test
 394
 395 FUNCTION: int ffi_test_37 ( void* func ) ;
 396
 397 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 398
 399 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
 400
 401 STRUCT: test_struct_13
 402 { x1 float }
 403 { x2 float }
 404 { x3 float }
 405 { x4 float }
 406 { x5 float }
 407 { x6 float } ;
 408
 409 : make-test-struct-13 ( -- alien )
 410     test_struct_13 <struct>
 411         1.0 >>x1
 412         2.0 >>x2
 413         3.0 >>x3
 414         4.0 >>x4
 415         5.0 >>x5
 416         6.0 >>x6 ;
 417
 418 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 419
 420 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 421
 422 ! Joe Groff found this problem
 423 STRUCT: double-rect
 424 { a double }
 425 { b double }
 426 { c double }
 427 { d double } ;
 428
 429 : <double-rect> ( a b c d -- foo )
 430     double-rect <struct>
 431         swap >>d
 432         swap >>c
 433         swap >>b
 434         swap >>a ;
 435
 436 : >double-rect< ( foo -- a b c d )
 437     {
 438         [ a>> ]
 439         [ b>> ]
 440         [ c>> ]
 441         [ d>> ]
 442     } cleave ;
 443
 444 : double-rect-callback ( -- alien )
 445     void { void* void* double-rect } cdecl
 446     [ "example" set-global 2drop ] alien-callback ;
 447
 448 : double-rect-test ( arg callback -- arg' )
 449     [ f f ] 2dip
 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 ! GCC bugs
 659 mingw? [
 660     [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
 661
 662     [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
 663 ] unless
 664
 665 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
 666
 667 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
 668
 669 : fastcall-ii-indirect ( x y ptr -- result )
 670     int { int int } fastcall alien-indirect ;
 671
 672 : fastcall-iii-indirect ( x y z ptr -- result )
 673     int { int int int } fastcall alien-indirect ;
 674
 675 : fastcall-ifi-indirect ( x y z ptr -- result )
 676     int { int float int } fastcall alien-indirect ;
 677
 678 : fastcall-ifii-indirect ( x y z w ptr -- result )
 679     int { int float int int } fastcall alien-indirect ;
 680
 681 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 682     test-struct-11 { int int } fastcall alien-indirect ;
 683
 684 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 685     test-struct-11 { int int int } fastcall alien-indirect ;
 686
 687 : win32? ( -- ? ) os windows? cpu x86.32? and ;
 688
 689 [ 8 ] [
 690     3 4
 691     win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
 692     fastcall-ii-indirect
 693 ] unit-test
 694
 695 [ 13 ] [
 696     3 4 5
 697     win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
 698     fastcall-iii-indirect
 699 ] unit-test
 700
 701 mingw? [
 702     [ 13 ] [
 703         3 4.0 5
 704         win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
 705         fastcall-ifi-indirect
 706     ] unit-test
 707
 708     [ 19 ] [
 709         3 4.0 5 6
 710         win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
 711         fastcall-ifii-indirect
 712     ] unit-test
 713 ] unless
 714
 715 [ S{ test-struct-11 f 7 -1 } ]
 716 [
 717     3 4
 718     win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
 719     fastcall-struct-return-ii-indirect
 720 ] unit-test
 721
 722 [ S{ test-struct-11 f 7 -3 } ]
 723 [
 724     3 4 7
 725     win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
 726     fastcall-struct-return-iii-indirect
 727 ] unit-test
 728
 729 : fastcall-ii-callback ( -- ptr )
 730     int { int int } fastcall [ + 1 + ] alien-callback ;
 731
 732 : fastcall-iii-callback ( -- ptr )
 733     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 734
 735 : fastcall-ifi-callback ( -- ptr )
 736     int { int float int } fastcall
 737     [ [ >integer ] dip + + 1 + ] alien-callback ;
 738
 739 : fastcall-ifii-callback ( -- ptr )
 740     int { int float int int } fastcall
 741     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 742
 743 : fastcall-struct-return-ii-callback ( -- ptr )
 744     test-struct-11 { int int } fastcall
 745     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 746
 747 : fastcall-struct-return-iii-callback ( -- ptr )
 748     test-struct-11 { int int int } fastcall
 749     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 750
 751 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
 752
 753 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
 754
 755 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
 756
 757 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
 758
 759 [ S{ test-struct-11 f 7 -1 } ]
 760 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
 761
 762 [ S{ test-struct-11 f 7 -3 } ]
 763 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test