basis/compiler/tests/alien.factor

   1 USING: accessors alien alien.c-types alien.complex alien.data alien.libraries
   2 alien.syntax arrays byte-arrays classes classes.struct combinators
   3 combinators.extras compiler compiler.test concurrency.promises continuations
   4 destructors effects generalizations io io.backend io.pathnames
   5 io.streams.string kernel kernel.private libc layouts math math.bitwise
   6 math.private memory namespaces namespaces.private random parser quotations
   7 sequences slots.private specialized-arrays stack-checker stack-checker.errors
   8 system threads tools.test words ;
   9 FROM: alien.c-types => float short ;
  10 SPECIALIZED-ARRAY: float
  11 SPECIALIZED-ARRAY: char
  12 IN: compiler.tests.alien
  13
  14 ! Make sure that invalid inputs don't pass the stack checker
  15 [ [ void { } "cdecl" alien-indirect ] infer ] must-fail
  16 [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
  17 [ [ void* 3 cdecl alien-indirect ] infer ] must-fail
  18 [ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
  19 [ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
  20
  21 <<
  22 : libfactor-ffi-tests-path ( -- string )
  23     "resource:" absolute-path
  24     {
  25         { [ os windows? ]  [ "libfactor-ffi-test.dll" ] }
  26         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
  27         { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
  28     } cond append-path ;
  29
  30 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
  31
  32 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
  33
  34 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
  35
  36 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
  37 >>
  38
  39 LIBRARY: f-cdecl
  40
  41 FUNCTION: void ffi_test_0 ;
  42 [ ] [ ffi_test_0 ] unit-test
  43
  44 FUNCTION: int ffi_test_1 ;
  45 [ 3 ] [ ffi_test_1 ] unit-test
  46
  47 [ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
  48
  49 FUNCTION: int ffi_test_2 int x int y ;
  50 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
  51 [ "hi" 3 ffi_test_2 ] must-fail
  52
  53 FUNCTION: int ffi_test_3 int x int y int z int t ;
  54 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
  55
  56 FUNCTION: float ffi_test_4 ;
  57 [ 1.5 ] [ ffi_test_4 ] unit-test
  58
  59 FUNCTION: double ffi_test_5 ;
  60 [ 1.5 ] [ ffi_test_5 ] unit-test
  61
  62 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
  63 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
  64 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
  65 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
  66
  67 STRUCT: FOO { x int } { y int } ;
  68
  69 : make-FOO ( x y -- FOO )
  70     FOO <struct> swap >>y swap >>x ;
  71
  72 FUNCTION: int ffi_test_11 int a FOO b int c ;
  73
  74 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
  75
  76 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 ;
  77
  78 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
  79
  80 FUNCTION: FOO ffi_test_14 int x int y ;
  81
  82 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
  83
  84 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
  85
  86 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
  87 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
  88 [ 1 2 ffi_test_15 ] must-fail
  89
  90 STRUCT: BAR { x long } { y long } { z long } ;
  91
  92 FUNCTION: BAR ffi_test_16 long x long y long z ;
  93
  94 [ 11 6 -7 ] [
  95     11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
  96 ] unit-test
  97
  98 STRUCT: TINY { x int } ;
  99
 100 FUNCTION: TINY ffi_test_17 int x ;
 101
 102 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
 103
 104 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
 105
 106 : indirect-test-1 ( ptr -- result )
 107     int { } cdecl alien-indirect ;
 108
 109 { 1 1 } [ indirect-test-1 ] must-infer-as
 110
 111 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 112
 113 : indirect-test-1' ( ptr -- )
 114     int { } cdecl alien-indirect drop ;
 115
 116 { 1 0 } [ indirect-test-1' ] must-infer-as
 117
 118 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 119
 120 [ -1 indirect-test-1 ] must-fail
 121
 122 : indirect-test-2 ( x y ptr -- result )
 123     int { int int } cdecl alien-indirect gc ;
 124
 125 { 3 1 } [ indirect-test-2 ] must-infer-as
 126
 127 [ 5 ]
 128 [ 2 3 &: ffi_test_2 indirect-test-2 ]
 129 unit-test
 130
 131 : indirect-test-3 ( a b c d ptr -- result )
 132     int { int int int int } stdcall alien-indirect
 133     gc ;
 134
 135 [ f ] [ "f-stdcall" load-library f = ] unit-test
 136 [ stdcall ] [ "f-stdcall" lookup-library abi>> ] unit-test
 137
 138 : ffi_test_18 ( w x y z -- int )
 139     int "f-stdcall" "ffi_test_18" { int int int int }
 140     alien-invoke gc ;
 141
 142 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 143
 144 : ffi_test_19 ( x y z -- BAR )
 145     BAR "f-stdcall" "ffi_test_19" { long long long }
 146     alien-invoke gc ;
 147
 148 [ 11 6 -7 ] [
 149     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 150 ] unit-test
 151
 152 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
 153     [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
 154     4 ndip
 155     int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
 156     gc ;
 157
 158 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
 159
 160 FUNCTION: double ffi_test_6 float x float y ;
 161 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 162 [ "a" "b" ffi_test_6 ] must-fail
 163
 164 FUNCTION: double ffi_test_7 double x double y ;
 165 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 166
 167 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 168 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 169
 170 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 171 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 172
 173 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 174     double y1, double y2, double y3,
 175     double z1, double z2, double z3 ;
 176
 177 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 178
 179 ! Make sure XT doesn't get clobbered in stack frame
 180
 181 : 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 )
 182     int
 183     "f-cdecl" "ffi_test_31"
 184     { 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 }
 185     alien-invoke gc 3 ;
 186
 187 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 188
 189 : 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 )
 190     float
 191     "f-cdecl" "ffi_test_31_point_5"
 192     { 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 }
 193     alien-invoke ;
 194
 195 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 196
 197 FUNCTION: longlong ffi_test_21 long x long y ;
 198
 199 [ 121932631112635269 ]
 200 [ 123456789 987654321 ffi_test_21 ] unit-test
 201
 202 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 203
 204 [ 987655432 ]
 205 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 206
 207 [ 1111 f 123456789 ffi_test_22 ] must-fail
 208
 209 STRUCT: RECT
 210     { x float } { y float }
 211     { w float } { h float } ;
 212
 213 : <RECT> ( x y w h -- rect )
 214     RECT <struct>
 215         swap >>h
 216         swap >>w
 217         swap >>y
 218         swap >>x ;
 219
 220 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
 221
 222 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 223
 224 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 225
 226 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 227
 228 [ 32.0 ] [
 229     { 1.0 2.0 3.0 } float >c-array
 230     { 4.0 5.0 6.0 } float >c-array
 231     ffi_test_23
 232 ] unit-test
 233
 234 ! Test odd-size structs
 235 STRUCT: test-struct-1 { x char[1] } ;
 236
 237 FUNCTION: test-struct-1 ffi_test_24 ;
 238
 239 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
 240
 241 STRUCT: test-struct-2 { x char[2] } ;
 242
 243 FUNCTION: test-struct-2 ffi_test_25 ;
 244
 245 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
 246
 247 STRUCT: test-struct-3 { x char[3] } ;
 248
 249 FUNCTION: test-struct-3 ffi_test_26 ;
 250
 251 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
 252
 253 STRUCT: test-struct-4 { x char[4] } ;
 254
 255 FUNCTION: test-struct-4 ffi_test_27 ;
 256
 257 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
 258
 259 STRUCT: test-struct-5 { x char[5] } ;
 260
 261 FUNCTION: test-struct-5 ffi_test_28 ;
 262
 263 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
 264
 265 STRUCT: test-struct-6 { x char[6] } ;
 266
 267 FUNCTION: test-struct-6 ffi_test_29 ;
 268
 269 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
 270
 271 STRUCT: test-struct-7 { x char[7] } ;
 272
 273 FUNCTION: test-struct-7 ffi_test_30 ;
 274
 275 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
 276
 277 STRUCT: test-struct-8 { x double } { y double } ;
 278
 279 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 280
 281 [ 9.0 ] [
 282     test-struct-8 <struct>
 283     1.0 >>x
 284     2.0 >>y
 285     3 ffi_test_32
 286 ] unit-test
 287
 288 STRUCT: test-struct-9 { x float } { y float } ;
 289
 290 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 291
 292 [ 9.0 ] [
 293     test-struct-9 <struct>
 294     1.0 >>x
 295     2.0 >>y
 296     3 ffi_test_33
 297 ] unit-test
 298
 299 STRUCT: test-struct-10 { x float } { y int } ;
 300
 301 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 302
 303 [ 9.0 ] [
 304     test-struct-10 <struct>
 305     1.0 >>x
 306     2 >>y
 307     3 ffi_test_34
 308 ] unit-test
 309
 310 STRUCT: test-struct-11 { x int } { y int } ;
 311
 312 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 313
 314 [ 9.0 ] [
 315     test-struct-11 <struct>
 316     1 >>x
 317     2 >>y
 318     3 ffi_test_35
 319 ] unit-test
 320
 321 STRUCT: test-struct-12 { a int } { x double } ;
 322
 323 : make-struct-12 ( x -- alien )
 324     test-struct-12 <struct>
 325         swap >>x ;
 326
 327 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 328
 329 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 330
 331 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 332
 333 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 334
 335 ! Test callbacks
 336 : callback-throws ( -- x )
 337     int { } cdecl [ "Hi" throw ] alien-callback ;
 338
 339 { t } [
 340     callback-throws [ alien? ] with-callback
 341 ] unit-test
 342
 343 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 344
 345 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 346
 347 { t } [ callback-1 [ alien? ] with-callback ] unit-test
 348
 349 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 350
 351 { } [ callback-1 [ callback_test_1 ] with-callback ] unit-test
 352
 353 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 354
 355 { } [ callback-2 [ callback_test_1 ] with-callback ] unit-test
 356
 357 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 358
 359 { t 3 5 } [
 360     [
 361         namestack*
 362         3 "x" set callback-3 [ callback_test_1 ] with-callback
 363         namestack* eq?
 364         "x" get "x" get-global
 365     ] with-scope
 366 ] unit-test
 367
 368 : callback-5 ( -- callback )
 369     void { } cdecl [ gc ] alien-callback ;
 370
 371 { "testing" } [
 372     "testing" callback-5 [ callback_test_1 ] with-callback
 373 ] unit-test
 374
 375 : callback-5b ( -- callback )
 376     void { } cdecl [ compact-gc ] alien-callback ;
 377
 378 [ "testing" ] [
 379     "testing" callback-5b [ callback_test_1 ] with-callback
 380 ] unit-test
 381
 382 : callback-6 ( -- callback )
 383     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 384
 385 [ 1 2 3 ] [
 386     callback-6 [ callback_test_1 1 2 3 ] with-callback
 387 ] unit-test
 388
 389 : callback-7 ( -- callback )
 390     void { } cdecl [ 1000000 sleep ] alien-callback ;
 391
 392 [ 1 2 3 ] [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test
 393
 394 [ f ] [ namespace global eq? ] unit-test
 395
 396 : callback-8 ( -- callback )
 397     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 398
 399 [ ] [ callback-8 [ callback_test_1 ] with-callback ] unit-test
 400
 401 : callback-9 ( -- callback )
 402     int { int int int } cdecl [
 403         + + 1 +
 404     ] alien-callback ;
 405
 406 FUNCTION: void ffi_test_36_point_5 ( ) ;
 407
 408 [ ] [ ffi_test_36_point_5 ] unit-test
 409
 410 FUNCTION: int ffi_test_37 ( void* func ) ;
 411
 412 [ 1 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
 413
 414 [ 7 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
 415
 416 STRUCT: test_struct_13
 417 { x1 float }
 418 { x2 float }
 419 { x3 float }
 420 { x4 float }
 421 { x5 float }
 422 { x6 float } ;
 423
 424 : make-test-struct-13 ( -- alien )
 425     test_struct_13 <struct>
 426         1.0 >>x1
 427         2.0 >>x2
 428         3.0 >>x3
 429         4.0 >>x4
 430         5.0 >>x5
 431         6.0 >>x6 ;
 432
 433 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 434
 435 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 436
 437 ! Joe Groff found this problem
 438 STRUCT: double-rect
 439 { a double }
 440 { b double }
 441 { c double }
 442 { d double } ;
 443
 444 : <double-rect> ( a b c d -- foo )
 445     double-rect <struct>
 446         swap >>d
 447         swap >>c
 448         swap >>b
 449         swap >>a ;
 450
 451 : >double-rect< ( foo -- a b c d )
 452     {
 453         [ a>> ]
 454         [ b>> ]
 455         [ c>> ]
 456         [ d>> ]
 457     } cleave ;
 458
 459 : double-rect-callback ( -- alien )
 460     void { void* void* double-rect } cdecl
 461     [ "example" set-global 2drop ] alien-callback ;
 462
 463 : double-rect-test ( arg callback -- arg' )
 464     [ f f ] 2dip
 465     void { void* void* double-rect } cdecl alien-indirect
 466     "example" get-global ;
 467
 468 { byte-array 1.0 2.0 3.0 4.0 } [
 469     1.0 2.0 3.0 4.0 <double-rect>
 470     double-rect-callback [
 471         double-rect-test
 472         [ >c-ptr class-of ] [ >double-rect< ] bi
 473     ] with-callback
 474 ] unit-test
 475
 476 STRUCT: test_struct_14
 477     { x1 double }
 478     { x2 double } ;
 479
 480 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 481
 482 [ 1.0 2.0 ] [
 483     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 484 ] unit-test
 485
 486 : callback-10 ( -- callback )
 487     test_struct_14 { double double } cdecl
 488     [
 489         test_struct_14 <struct>
 490             swap >>x2
 491             swap >>x1
 492     ] alien-callback ;
 493
 494 : callback-10-test ( x1 x2 callback -- result )
 495     test_struct_14 { double double } cdecl alien-indirect ;
 496
 497 { 1.0 2.0 } [
 498     1.0 2.0 callback-10 [
 499         callback-10-test [ x1>> ] [ x2>> ] bi
 500     ] with-callback
 501 ] unit-test
 502
 503 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 504
 505 [ 1 2.0 ] [
 506     1 2.0 ffi_test_41
 507     [ a>> ] [ x>> ] bi
 508 ] unit-test
 509
 510 : callback-11 ( -- callback )
 511     test-struct-12 { int double } cdecl
 512     [
 513         test-struct-12 <struct>
 514             swap >>x
 515             swap >>a
 516     ] alien-callback ;
 517
 518 : callback-11-test ( x1 x2 callback -- result )
 519     test-struct-12 { int double } cdecl alien-indirect ;
 520
 521 { 1 2.0 } [
 522     1 2.0 callback-11 [
 523         callback-11-test [ a>> ] [ x>> ] bi
 524     ] with-callback
 525 ] unit-test
 526
 527 STRUCT: test_struct_15
 528     { x float }
 529     { y float } ;
 530
 531 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 532
 533 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 534
 535 : callback-12 ( -- callback )
 536     test_struct_15 { float float } cdecl
 537     [
 538         test_struct_15 <struct>
 539             swap >>y
 540             swap >>x
 541     ] alien-callback ;
 542
 543 : callback-12-test ( x1 x2 callback -- result )
 544     test_struct_15 { float float } cdecl alien-indirect ;
 545
 546 [ 1.0 2.0 ] [
 547     1.0 2.0 callback-12 [
 548         callback-12-test [ x>> ] [ y>> ] bi
 549     ] with-callback
 550 ] unit-test
 551
 552 STRUCT: test_struct_16
 553     { x float }
 554     { a int } ;
 555
 556 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 557
 558 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 559
 560 : callback-13 ( -- callback )
 561     test_struct_16 { float int } cdecl
 562     [
 563         test_struct_16 <struct>
 564             swap >>a
 565             swap >>x
 566     ] alien-callback ;
 567
 568 : callback-13-test ( x1 x2 callback -- result )
 569     test_struct_16 { float int } cdecl alien-indirect ;
 570
 571 { 1.0 2 } [
 572     1.0 2 callback-13 [
 573         callback-13-test [ x>> ] [ a>> ] bi
 574     ] with-callback
 575 ] unit-test
 576
 577 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 578
 579 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 580
 581 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 582
 583 [ ] [ stack-frame-bustage 2drop ] unit-test
 584
 585 ! C99 tests
 586 os windows? [
 587
 588     FUNCTION: complex-float ffi_test_45 ( int x ) ;
 589
 590     [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 591
 592     FUNCTION: complex-double ffi_test_46 ( int x ) ;
 593
 594     [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 595
 596     FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 597
 598     [ C{ 4.0 4.0 } ] [
 599         C{ 1.0 2.0 }
 600         C{ 1.5 1.0 } ffi_test_47
 601     ] unit-test
 602
 603     ! Reported by jedahu
 604     STRUCT: bool-field-test
 605         { name c-string }
 606         { on bool }
 607         { parents short } ;
 608
 609     FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 610
 611     [ 123 ] [
 612         bool-field-test <struct>
 613             123 >>parents
 614         ffi_test_48
 615     ] unit-test
 616
 617 ] unless
 618
 619 ! Test interaction between threads and callbacks
 620 : thread-callback-1 ( -- callback )
 621     int { } cdecl [ yield 100 ] alien-callback ;
 622
 623 : thread-callback-2 ( -- callback )
 624     int { } cdecl [ yield 200 ] alien-callback ;
 625
 626 : thread-callback-invoker ( callback -- n )
 627     int { } cdecl alien-indirect ;
 628
 629 <promise> "p" set
 630 [
 631     thread-callback-1 [
 632         thread-callback-invoker
 633     ] with-callback "p" get fulfill
 634 ] in-thread
 635 { 200 } [
 636     thread-callback-2 [ thread-callback-invoker ] with-callback
 637 ] unit-test
 638 [ 100 ] [ "p" get ?promise ] unit-test
 639
 640 ! More alien-assembly tests are in cpu.* vocabs
 641 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 642
 643 [ ] [ assembly-test-1 ] unit-test
 644
 645 [ f ] [ "f-fastcall" load-library f = ] unit-test
 646 [ fastcall ] [ "f-fastcall" lookup-library abi>> ] unit-test
 647
 648 : ffi_test_49 ( x -- int )
 649     int "f-fastcall" "ffi_test_49" { int }
 650     alien-invoke gc ;
 651 : ffi_test_50 ( x y -- int )
 652     int "f-fastcall" "ffi_test_50" { int int }
 653     alien-invoke gc ;
 654 : ffi_test_51 ( x y z -- int )
 655     int "f-fastcall" "ffi_test_51" { int int int }
 656     alien-invoke gc ;
 657 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
 658     [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
 659     3dip
 660     int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
 661
 662 [ 4 ] [ 3 ffi_test_49 ] unit-test
 663 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
 664 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
 665 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
 666
 667 : ffi_test_52 ( x y z -- int )
 668     int "f-fastcall" "ffi_test_52" { int float int }
 669     alien-invoke gc ;
 670 : ffi_test_53 ( x y z w -- int )
 671     int "f-fastcall" "ffi_test_53" { int float int int }
 672     alien-invoke gc ;
 673 : ffi_test_57 ( x y -- test-struct-11 )
 674     test-struct-11 "f-fastcall" "ffi_test_57" { int int }
 675     alien-invoke gc ;
 676 : ffi_test_58 ( x y z -- test-struct-11 )
 677     test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
 678     alien-invoke gc ;
 679
 680 ! Make sure that large longlong/ulonglong are correctly dealt with
 681 FUNCTION: longlong ffi_test_59 ( longlong x ) ;
 682 FUNCTION: ulonglong ffi_test_60 ( ulonglong x ) ;
 683
 684 [ t ] [ most-positive-fixnum 1 + [ ffi_test_59 ] keep = ] unit-test
 685 [ t ] [ most-positive-fixnum 1 + [ ffi_test_60 ] keep = ] unit-test
 686
 687 [ -1 ] [ -1 ffi_test_59 ] unit-test
 688 [ -1 ] [ 0xffffffffffffffff ffi_test_59 ] unit-test
 689 [ 0xffffffffffffffff ] [ -1 ffi_test_60 ] unit-test
 690 [ 0xffffffffffffffff ] [ 0xffffffffffffffff ffi_test_60 ] unit-test
 691
 692 ! GCC bugs
 693 mingw? [
 694     [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
 695
 696     [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
 697 ] unless
 698
 699 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
 700
 701 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
 702
 703 : fastcall-ii-indirect ( x y ptr -- result )
 704     int { int int } fastcall alien-indirect ;
 705
 706 : fastcall-iii-indirect ( x y z ptr -- result )
 707     int { int int int } fastcall alien-indirect ;
 708
 709 : fastcall-ifi-indirect ( x y z ptr -- result )
 710     int { int float int } fastcall alien-indirect ;
 711
 712 : fastcall-ifii-indirect ( x y z w ptr -- result )
 713     int { int float int int } fastcall alien-indirect ;
 714
 715 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 716     test-struct-11 { int int } fastcall alien-indirect ;
 717
 718 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 719     test-struct-11 { int int int } fastcall alien-indirect ;
 720
 721 : win32? ( -- ? ) os windows? cpu x86.32? and ;
 722
 723 [ 8 ] [
 724     3 4
 725     win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
 726     fastcall-ii-indirect
 727 ] unit-test
 728
 729 [ 13 ] [
 730     3 4 5
 731     win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
 732     fastcall-iii-indirect
 733 ] unit-test
 734
 735 mingw? [
 736     [ 13 ] [
 737         3 4.0 5
 738         win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
 739         fastcall-ifi-indirect
 740     ] unit-test
 741
 742     [ 19 ] [
 743         3 4.0 5 6
 744         win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
 745         fastcall-ifii-indirect
 746     ] unit-test
 747 ] unless
 748
 749 [ S{ test-struct-11 f 7 -1 } ]
 750 [
 751     3 4
 752     win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
 753     fastcall-struct-return-ii-indirect
 754 ] unit-test
 755
 756 [ S{ test-struct-11 f 7 -3 } ]
 757 [
 758     3 4 7
 759     win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
 760     fastcall-struct-return-iii-indirect
 761 ] unit-test
 762
 763 : fastcall-ii-callback ( -- ptr )
 764     int { int int } fastcall [ + 1 + ] alien-callback ;
 765
 766 : fastcall-iii-callback ( -- ptr )
 767     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 768
 769 : fastcall-ifi-callback ( -- ptr )
 770     int { int float int } fastcall
 771     [ [ >integer ] dip + + 1 + ] alien-callback ;
 772
 773 : fastcall-ifii-callback ( -- ptr )
 774     int { int float int int } fastcall
 775     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 776
 777 : fastcall-struct-return-ii-callback ( -- ptr )
 778     test-struct-11 { int int } fastcall
 779     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 780
 781 : fastcall-struct-return-iii-callback ( -- ptr )
 782     test-struct-11 { int int int } fastcall
 783     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 784
 785 { 8 } [
 786     3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
 787 ] unit-test
 788
 789 [ 13 ] [
 790     3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
 791 ] unit-test
 792
 793 [ 13 ] [
 794     3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
 795 ] unit-test
 796
 797 [ 19 ] [
 798     3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
 799 ] unit-test
 800
 801 [ S{ test-struct-11 f 7 -1 } ] [
 802     3 4 fastcall-struct-return-ii-callback [
 803         fastcall-struct-return-ii-indirect
 804     ] with-callback
 805 ] unit-test
 806
 807 [ S{ test-struct-11 f 7 -3 } ] [
 808     3 4 7 fastcall-struct-return-iii-callback [
 809         fastcall-struct-return-iii-indirect
 810     ] with-callback
 811 ] unit-test
 812
 813 : x64-regression-1 ( -- c )
 814     int { int int int int int } cdecl [ + + + + ] alien-callback ;
 815
 816 : x64-regression-2 ( x x x x x c -- y )
 817     int { int int int int int } cdecl alien-indirect ; inline
 818
 819 [ 661 ] [
 820     100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
 821 ] unit-test
 822
 823 ! Stack allocation
 824 : blah ( -- x ) { RECT } [
 825     1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
 826 ] with-scoped-allocation ;
 827
 828 [ 3 ] [ blah ] unit-test
 829
 830 : out-param-test-1 ( -- b )
 831     { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 832
 833 [ 12 ] [ out-param-test-1 ] unit-test
 834
 835 : out-param-test-2 ( -- b )
 836     { { int initial: 12 } } [ drop ] with-out-parameters ;
 837
 838 [ 12 ] [ out-param-test-2 ] unit-test
 839
 840 : out-param-test-3 ( -- x y )
 841     { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
 842     with-out-parameters
 843     [ x>> ] [ y>> ] bi ;
 844
 845 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 846
 847 : out-param-callback ( -- a )
 848     void { int pointer: int } cdecl
 849     [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
 850
 851 : out-param-indirect ( a a -- b )
 852     { int } [
 853         swap void { int pointer: int } cdecl
 854         alien-indirect
 855     ] with-out-parameters ;
 856
 857 [ 12 ] [
 858     6 out-param-callback [ out-param-indirect ] with-callback
 859 ] unit-test
 860
 861 ! Alias analysis regression
 862 : aa-callback-1 ( -- c )
 863     double { } cdecl [ 5.0 ] alien-callback ;
 864
 865 : aa-indirect-1 ( c -- x )
 866     double { } cdecl alien-indirect ; inline
 867
 868 TUPLE: some-tuple x ;
 869
 870 [ T{ some-tuple f 5.0 } ] [
 871     [
 872         some-tuple new
 873         aa-callback-1 [
 874             aa-indirect-1
 875         ] with-callback >>x
 876     ] compile-call
 877 ] unit-test
 878
 879 ! GC maps regression
 880 : anton's-regression ( -- )
 881     f (free) f (free) ;
 882
 883 [ ] [ anton's-regression ] unit-test
 884
 885 os windows? [
 886
 887     STRUCT: bool-and-ptr
 888         { b bool }
 889         { ptr void* } ;
 890
 891     FUNCTION: bool-and-ptr ffi_test_61 ( ) ;
 892
 893     ! { S{ bool-and-ptr { b t } { ptr f } } } [ ffi_test_61 ] unit-test
 894     { t } [ ffi_test_61 bool-and-ptr? ] unit-test
 895     { { t f } } [ ffi_test_61 [ b>> ] [ ptr>> ] bi 2array ] unit-test
 896
 897 ] unless
 898
 899 STRUCT: uint-pair
 900     { a uint }
 901     { b uint } ;
 902
 903 FUNCTION: uint-pair ffi_test_62 ( ) ;
 904
 905 {
 906     S{ uint-pair { a 0xabcdefab } { b 0x12345678 } }
 907 } [ ffi_test_62 ] unit-test
 908
 909 STRUCT: ulonglong-pair
 910     { a ulonglong }
 911     { b ulonglong } ;
 912
 913 FUNCTION: ulonglong-pair ffi_test_63 ( ) ;
 914
 915 {
 916     S{ ulonglong-pair { a 0xabcdefabcdefabcd } { b 0x1234567891234567 } }
 917 } [ ffi_test_63 ] unit-test
 918
 919 FUNCTION: void* bug1021_test_1 ( void* s, int x ) ;
 920
 921 ! Sanity test the formula: x sq s +
 922 { t } [
 923     10 [ [ 100 random ] twice 2array ] replicate
 924     [ [ first2 [ <alien> ] dip bug1021_test_1 alien-address ] map ]
 925     [ [ first2 sq + ] map ] bi =
 926 ] unit-test
 927
 928 : each-to100 ( ... quot: ( ... i -- ... ) i -- ... )
 929     dup 100 < [
 930         2dup swap (call) 1 + each-to100
 931     ] [ 2drop ] if ; inline recursive
 932
 933 : run-test ( alien -- seq )
 934     100 33 <array> swap over
 935     [
 936         pick swapd
 937         bug1021_test_1
 938         -rot swap 2 fixnum+fast
 939         set-slot
 940     ] curry curry 0 each-to100 ;
 941
 942 { } [
 943     minor-gc 2000 [
 944         101 <alien> run-test
 945         ! If #1021 ever comes back it will blow up here because
 946         ! alien-address wants an alien not a fixnum.
 947         [ alien-address ] map drop
 948     ] times
 949 ] unit-test
 950
 951 FUNCTION: int bug1021_test_2 ( int a, char* b, void* c ) ;
 952 FUNCTION: void* bug1021_test_3 ( c-string a ) ;
 953
 954 : doit ( a -- d )
 955     33 1byte-array "bar" bug1021_test_3 bug1021_test_2 ;
 956
 957 { } [
 958     10000 [ 0 doit 33 assert= ] times
 959 ] unit-test