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         (get-namestack)
 362         3 "x" set callback-3 [ callback_test_1 ] with-callback
 363         (get-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 [ 8 ] [
 722     3 4 &: ffi_test_50 fastcall-ii-indirect
 723 ] unit-test
 724
 725 [ 13 ] [
 726     3 4 5 &: ffi_test_51 fastcall-iii-indirect
 727 ] unit-test
 728
 729 mingw? [
 730     [ 13 ] [
 731         3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect
 732     ] unit-test
 733
 734     [ 19 ] [
 735         3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect
 736     ] unit-test
 737 ] unless
 738
 739 [ S{ test-struct-11 f 7 -1 } ]
 740 [
 741     3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect
 742 ] unit-test
 743
 744 [ S{ test-struct-11 f 7 -3 } ]
 745 [
 746     3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect
 747 ] unit-test
 748
 749 : fastcall-ii-callback ( -- ptr )
 750     int { int int } fastcall [ + 1 + ] alien-callback ;
 751
 752 : fastcall-iii-callback ( -- ptr )
 753     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 754
 755 : fastcall-ifi-callback ( -- ptr )
 756     int { int float int } fastcall
 757     [ [ >integer ] dip + + 1 + ] alien-callback ;
 758
 759 : fastcall-ifii-callback ( -- ptr )
 760     int { int float int int } fastcall
 761     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 762
 763 : fastcall-struct-return-ii-callback ( -- ptr )
 764     test-struct-11 { int int } fastcall
 765     [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
 766
 767 : fastcall-struct-return-iii-callback ( -- ptr )
 768     test-struct-11 { int int int } fastcall
 769     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 770
 771 { 8 } [
 772     3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
 773 ] unit-test
 774
 775 [ 13 ] [
 776     3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
 777 ] unit-test
 778
 779 [ 13 ] [
 780     3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
 781 ] unit-test
 782
 783 [ 19 ] [
 784     3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
 785 ] unit-test
 786
 787 [ S{ test-struct-11 f 7 -1 } ] [
 788     3 4 fastcall-struct-return-ii-callback [
 789         fastcall-struct-return-ii-indirect
 790     ] with-callback
 791 ] unit-test
 792
 793 [ S{ test-struct-11 f 7 -3 } ] [
 794     3 4 7 fastcall-struct-return-iii-callback [
 795         fastcall-struct-return-iii-indirect
 796     ] with-callback
 797 ] unit-test
 798
 799 : x64-regression-1 ( -- c )
 800     int { int int int int int } cdecl [ + + + + ] alien-callback ;
 801
 802 : x64-regression-2 ( x x x x x c -- y )
 803     int { int int int int int } cdecl alien-indirect ; inline
 804
 805 [ 661 ] [
 806     100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
 807 ] unit-test
 808
 809 ! Stack allocation
 810 : blah ( -- x ) { RECT } [
 811     1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
 812 ] with-scoped-allocation ;
 813
 814 [ 3 ] [ blah ] unit-test
 815
 816 : out-param-test-1 ( -- b )
 817     { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 818
 819 [ 12 ] [ out-param-test-1 ] unit-test
 820
 821 : out-param-test-2 ( -- b )
 822     { { int initial: 12 } } [ drop ] with-out-parameters ;
 823
 824 [ 12 ] [ out-param-test-2 ] unit-test
 825
 826 : out-param-test-3 ( -- x y )
 827     { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
 828     with-out-parameters
 829     [ x>> ] [ y>> ] bi ;
 830
 831 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 832
 833 : out-param-callback ( -- a )
 834     void { int pointer: int } cdecl
 835     [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
 836
 837 : out-param-indirect ( a a -- b )
 838     { int } [
 839         swap void { int pointer: int } cdecl
 840         alien-indirect
 841     ] with-out-parameters ;
 842
 843 [ 12 ] [
 844     6 out-param-callback [ out-param-indirect ] with-callback
 845 ] unit-test
 846
 847 ! Alias analysis regression
 848 : aa-callback-1 ( -- c )
 849     double { } cdecl [ 5.0 ] alien-callback ;
 850
 851 : aa-indirect-1 ( c -- x )
 852     double { } cdecl alien-indirect ; inline
 853
 854 TUPLE: some-tuple x ;
 855
 856 [ T{ some-tuple f 5.0 } ] [
 857     [
 858         some-tuple new
 859         aa-callback-1 [
 860             aa-indirect-1
 861         ] with-callback >>x
 862     ] compile-call
 863 ] unit-test
 864
 865 ! GC maps regression
 866 : anton's-regression ( -- )
 867     f (free) f (free) ;
 868
 869 [ ] [ anton's-regression ] unit-test
 870
 871 os windows? [
 872
 873     STRUCT: bool-and-ptr
 874         { b bool }
 875         { ptr void* } ;
 876
 877     FUNCTION: bool-and-ptr ffi_test_61 ( )
 878
 879     ! { S{ bool-and-ptr { b t } { ptr f } } } [ ffi_test_61 ] unit-test
 880     { t } [ ffi_test_61 bool-and-ptr? ] unit-test
 881     { { t f } } [ ffi_test_61 [ b>> ] [ ptr>> ] bi 2array ] unit-test
 882
 883 ] unless
 884
 885 STRUCT: uint-pair
 886     { a uint }
 887     { b uint } ;
 888
 889 FUNCTION: uint-pair ffi_test_62 ( )
 890
 891 {
 892     S{ uint-pair { a 0xabcdefab } { b 0x12345678 } }
 893 } [ ffi_test_62 ] unit-test
 894
 895 STRUCT: ulonglong-pair
 896     { a ulonglong }
 897     { b ulonglong } ;
 898
 899 FUNCTION: ulonglong-pair ffi_test_63 ( )
 900
 901 {
 902     S{ ulonglong-pair { a 0xabcdefabcdefabcd } { b 0x1234567891234567 } }
 903 } [ ffi_test_63 ] unit-test
 904
 905 FUNCTION: void* bug1021_test_1 ( void* s, int x )
 906
 907 ! Sanity test the formula: x sq s +
 908 { t } [
 909     10 [ [ 100 random ] twice 2array ] replicate
 910     [ [ first2 [ <alien> ] dip bug1021_test_1 alien-address ] map ]
 911     [ [ first2 sq + ] map ] bi =
 912 ] unit-test
 913
 914 : each-to100 ( ... quot: ( ... i -- ... ) i -- ... )
 915     dup 100 < [
 916         2dup swap (call) 1 + each-to100
 917     ] [ 2drop ] if ; inline recursive
 918
 919 : run-test ( alien -- seq )
 920     100 33 <array> swap over
 921     [
 922         pick swapd
 923         bug1021_test_1
 924         -rot swap 2 fixnum+fast
 925         set-slot
 926     ] curry curry 0 each-to100 ;
 927
 928 { } [
 929     minor-gc 2000 [
 930         101 <alien> run-test
 931         ! If #1021 ever comes back it will blow up here because
 932         ! alien-address wants an alien not a fixnum.
 933         [ alien-address ] map drop
 934     ] times
 935 ] unit-test
 936
 937 FUNCTION: int bug1021_test_2 ( int a, char* b, void* c )
 938 FUNCTION: void* bug1021_test_3 ( c-string a )
 939
 940 : doit ( a -- d )
 941     33 1byte-array "bar" bug1021_test_3 bug1021_test_2 ;
 942
 943 { } [
 944     10000 [ 0 doit 33 assert= ] times
 945 ] unit-test