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 locals 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 } [ 2 3 &: ffi_test_2 indirect-test-2 ] unit-test
 128
 129 : indirect-test-3 ( a b c d ptr -- result )
 130     int { int int int int } stdcall alien-indirect
 131     gc ;
 132
 133 { f } [ "f-stdcall" library-dll f = ] unit-test
 134 { stdcall } [ "f-stdcall" lookup-library abi>> ] unit-test
 135
 136 : ffi_test_18 ( w x y z -- int )
 137     int "f-stdcall" "ffi_test_18" { int int int int } f
 138     alien-invoke gc ;
 139
 140 { 25 } [ 2 3 4 5 ffi_test_18 ] unit-test
 141
 142 : ffi_test_19 ( x y z -- BAR )
 143     BAR "f-stdcall" "ffi_test_19" { long long long } f
 144     alien-invoke gc ;
 145
 146 { 11 6 -7 } [
 147     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 148 ] unit-test
 149
 150 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
 151     [ int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke ]
 152     4dip
 153     int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke
 154     gc ;
 155
 156 { 25 85 } [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
 157
 158 FUNCTION: double ffi_test_6 ( float x, float y )
 159 { 6.0 } [ 3.0 2.0 ffi_test_6 ] unit-test
 160 [ "a" "b" ffi_test_6 ] must-fail
 161
 162 FUNCTION: double ffi_test_7 ( double x, double y )
 163 { 6.0 } [ 3.0 2.0 ffi_test_7 ] unit-test
 164
 165 FUNCTION: double ffi_test_8 ( double x, float y, double z, float t, int w )
 166 { 19.0 } [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 167
 168 FUNCTION: int ffi_test_10 ( int a, int b, double c, int d, float e, int f, int g, int h )
 169 { -34 } [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 170
 171 FUNCTION: void ffi_test_20 ( double x1, double x2, double x3,
 172     double y1, double y2, double y3,
 173     double z1, double z2, double z3 )
 174
 175 { } [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 176
 177 ! Make sure XT doesn't get clobbered in stack frame
 178
 179 : 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 )
 180     int
 181     "f-cdecl" "ffi_test_31"
 182     { 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 } f
 183     alien-invoke gc 3 ;
 184
 185 { 861 3 } [ 42 [ ] each-integer ffi_test_31 ] unit-test
 186
 187 : 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 )
 188     float
 189     "f-cdecl" "ffi_test_31_point_5"
 190     { 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 } f
 191     alien-invoke ;
 192
 193 { 861.0 } [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 194
 195 FUNCTION: longlong ffi_test_21 ( long x, long y )
 196
 197 { 121932631112635269 } [ 123456789 987654321 ffi_test_21 ] unit-test
 198
 199 FUNCTION: long ffi_test_22 ( long x, longlong y, longlong z )
 200
 201 { 987655432 } [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 202
 203 [ 1111 f 123456789 ffi_test_22 ] must-fail
 204
 205 STRUCT: RECT
 206     { x float } { y float }
 207     { w float } { h float } ;
 208
 209 : <RECT> ( x y w h -- rect )
 210     RECT <struct>
 211         swap >>h
 212         swap >>w
 213         swap >>y
 214         swap >>x ;
 215
 216 FUNCTION: int ffi_test_12 ( int a, int b, RECT c, int d, int e, int f )
 217
 218 { 45 } [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 219
 220 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 221
 222 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y )
 223
 224 { 32.0 } [
 225     { 1.0 2.0 3.0 } float >c-array
 226     { 4.0 5.0 6.0 } float >c-array
 227     ffi_test_23
 228 ] unit-test
 229
 230 ! Test odd-size structs
 231 STRUCT: test-struct-1 { x char[1] } ;
 232
 233 FUNCTION: test-struct-1 ffi_test_24 ( )
 234
 235 { S{ test-struct-1 { x char-array{ 1 } } } } [ ffi_test_24 ] unit-test
 236
 237 STRUCT: test-struct-2 { x char[2] } ;
 238
 239 FUNCTION: test-struct-2 ffi_test_25 ( )
 240
 241 { S{ test-struct-2 { x char-array{ 1 2 } } } } [ ffi_test_25 ] unit-test
 242
 243 STRUCT: test-struct-3 { x char[3] } ;
 244
 245 FUNCTION: test-struct-3 ffi_test_26 ( )
 246
 247 { S{ test-struct-3 { x char-array{ 1 2 3 } } } } [ ffi_test_26 ] unit-test
 248
 249 STRUCT: test-struct-4 { x char[4] } ;
 250
 251 FUNCTION: test-struct-4 ffi_test_27 ( )
 252
 253 { S{ test-struct-4 { x char-array{ 1 2 3 4 } } } } [ ffi_test_27 ] unit-test
 254
 255 STRUCT: test-struct-5 { x char[5] } ;
 256
 257 FUNCTION: test-struct-5 ffi_test_28 ( )
 258
 259 { S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } } [ ffi_test_28 ] unit-test
 260
 261 STRUCT: test-struct-6 { x char[6] } ;
 262
 263 FUNCTION: test-struct-6 ffi_test_29 ( )
 264
 265 { S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } } [ ffi_test_29 ] unit-test
 266
 267 STRUCT: test-struct-7 { x char[7] } ;
 268
 269 FUNCTION: test-struct-7 ffi_test_30 ( )
 270
 271 { S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } } [ ffi_test_30 ] unit-test
 272
 273 STRUCT: test-struct-8 { x double } { y double } ;
 274
 275 FUNCTION: double ffi_test_32 ( test-struct-8 x, int y )
 276
 277 { 9.0 } [
 278     test-struct-8 <struct>
 279     1.0 >>x
 280     2.0 >>y
 281     3 ffi_test_32
 282 ] unit-test
 283
 284 STRUCT: test-struct-9 { x float } { y float } ;
 285
 286 FUNCTION: double ffi_test_33 ( test-struct-9 x, int y )
 287
 288 { 9.0 } [
 289     test-struct-9 <struct>
 290     1.0 >>x
 291     2.0 >>y
 292     3 ffi_test_33
 293 ] unit-test
 294
 295 STRUCT: test-struct-10 { x float } { y int } ;
 296
 297 FUNCTION: double ffi_test_34 ( test-struct-10 x, int y )
 298
 299 { 9.0 } [
 300     test-struct-10 <struct>
 301     1.0 >>x
 302     2 >>y
 303     3 ffi_test_34
 304 ] unit-test
 305
 306 STRUCT: test-struct-11 { x int } { y int } ;
 307
 308 FUNCTION: double ffi_test_35 ( test-struct-11 x, int y )
 309
 310 { 9.0 } [
 311     test-struct-11 <struct>
 312     1 >>x
 313     2 >>y
 314     3 ffi_test_35
 315 ] unit-test
 316
 317 STRUCT: test-struct-12 { a int } { x double } ;
 318
 319 : make-struct-12 ( x -- alien )
 320     test-struct-12 <struct>
 321         swap >>x ;
 322
 323 FUNCTION: double ffi_test_36 ( test-struct-12 x )
 324
 325 { 1.23456 } [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 326
 327 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y )
 328
 329 { t } [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 330
 331 ! Test callbacks
 332 : callback-throws ( -- x )
 333     int { } cdecl [ "Hi" throw ] alien-callback ;
 334
 335 { t } [
 336     callback-throws [ alien? ] with-callback
 337 ] unit-test
 338
 339 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 340
 341 { 0 1 } [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 342
 343 { t } [ callback-1 [ alien? ] with-callback ] unit-test
 344
 345 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 346
 347 { } [ callback-1 [ callback_test_1 ] with-callback ] unit-test
 348
 349 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 350
 351 { } [ callback-2 [ callback_test_1 ] with-callback ] unit-test
 352
 353 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 354
 355 { t 3 5 } [
 356     [
 357         (get-namestack)
 358         3 "x" set callback-3 [ callback_test_1 ] with-callback
 359         (get-namestack) eq?
 360         "x" get "x" get-global
 361     ] with-scope
 362 ] unit-test
 363
 364 : callback-5 ( -- callback )
 365     void { } cdecl [ gc ] alien-callback ;
 366
 367 { "testing" } [
 368     "testing" callback-5 [ callback_test_1 ] with-callback
 369 ] unit-test
 370
 371 : callback-5b ( -- callback )
 372     void { } cdecl [ compact-gc ] alien-callback ;
 373
 374 { "testing" } [
 375     "testing" callback-5b [ callback_test_1 ] with-callback
 376 ] unit-test
 377
 378 : callback-6 ( -- callback )
 379     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 380
 381 { 1 2 3 } [
 382     callback-6 [ callback_test_1 1 2 3 ] with-callback
 383 ] unit-test
 384
 385 : callback-7 ( -- callback )
 386     void { } cdecl [ 1000000 sleep ] alien-callback ;
 387
 388 { 1 2 3 } [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test
 389
 390 { f } [ namespace global eq? ] unit-test
 391
 392 : callback-8 ( -- callback )
 393     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 394
 395 { } [ callback-8 [ callback_test_1 ] with-callback ] unit-test
 396
 397 : callback-9 ( -- callback )
 398     int { int int int } cdecl [
 399         + + 1 +
 400     ] alien-callback ;
 401
 402 FUNCTION: void ffi_test_36_point_5 ( )
 403
 404 { } [ ffi_test_36_point_5 ] unit-test
 405
 406 FUNCTION: int ffi_test_37 ( void* func )
 407
 408 { 1 } [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
 409
 410 { 7 } [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
 411
 412 STRUCT: test_struct_13
 413     { x1 float }
 414     { x2 float }
 415     { x3 float }
 416     { x4 float }
 417     { x5 float }
 418     { x6 float } ;
 419
 420 : make-test-struct-13 ( -- alien )
 421     test_struct_13 <struct>
 422         1.0 >>x1
 423         2.0 >>x2
 424         3.0 >>x3
 425         4.0 >>x4
 426         5.0 >>x5
 427         6.0 >>x6 ;
 428
 429 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s )
 430
 431 { 21 } [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 432
 433 ! Joe Groff found this problem
 434 STRUCT: double-rect
 435     { a double }
 436     { b double }
 437     { c double }
 438     { d double } ;
 439
 440 : <double-rect> ( a b c d -- foo )
 441     double-rect <struct>
 442         swap >>d
 443         swap >>c
 444         swap >>b
 445         swap >>a ;
 446
 447 : >double-rect< ( foo -- a b c d )
 448     {
 449         [ a>> ]
 450         [ b>> ]
 451         [ c>> ]
 452         [ d>> ]
 453     } cleave ;
 454
 455 : double-rect-callback ( -- alien )
 456     void { void* void* double-rect } cdecl
 457     [ "example" set-global 2drop ] alien-callback ;
 458
 459 : double-rect-test ( arg callback -- arg' )
 460     [ f f ] 2dip
 461     void { void* void* double-rect } cdecl alien-indirect
 462     "example" get-global ;
 463
 464 { byte-array 1.0 2.0 3.0 4.0 } [
 465     1.0 2.0 3.0 4.0 <double-rect>
 466     double-rect-callback [
 467         double-rect-test
 468         [ >c-ptr class-of ] [ >double-rect< ] bi
 469     ] with-callback
 470 ] unit-test
 471
 472 STRUCT: test_struct_14
 473     { x1 double }
 474     { x2 double } ;
 475
 476 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 )
 477
 478 { 1.0 2.0 } [
 479     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 480 ] unit-test
 481
 482 : callback-10 ( -- callback )
 483     test_struct_14 { double double } cdecl
 484     [
 485         test_struct_14 <struct>
 486             swap >>x2
 487             swap >>x1
 488     ] alien-callback ;
 489
 490 : callback-10-test ( x1 x2 callback -- result )
 491     test_struct_14 { double double } cdecl alien-indirect ;
 492
 493 { 1.0 2.0 } [
 494     1.0 2.0 callback-10 [
 495         callback-10-test [ x1>> ] [ x2>> ] bi
 496     ] with-callback
 497 ] unit-test
 498
 499 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x )
 500
 501 { 1 2.0 } [
 502     1 2.0 ffi_test_41
 503     [ a>> ] [ x>> ] bi
 504 ] unit-test
 505
 506 : callback-11 ( -- callback )
 507     test-struct-12 { int double } cdecl
 508     [
 509         test-struct-12 <struct>
 510             swap >>x
 511             swap >>a
 512     ] alien-callback ;
 513
 514 : callback-11-test ( x1 x2 callback -- result )
 515     test-struct-12 { int double } cdecl alien-indirect ;
 516
 517 { 1 2.0 } [
 518     1 2.0 callback-11 [
 519         callback-11-test [ a>> ] [ x>> ] bi
 520     ] with-callback
 521 ] unit-test
 522
 523 STRUCT: test_struct_15
 524     { x float }
 525     { y float } ;
 526
 527 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y )
 528
 529 { 1.0 2.0 } [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 530
 531 : callback-12 ( -- callback )
 532     test_struct_15 { float float } cdecl
 533     [
 534         test_struct_15 <struct>
 535             swap >>y
 536             swap >>x
 537     ] alien-callback ;
 538
 539 : callback-12-test ( x1 x2 callback -- result )
 540     test_struct_15 { float float } cdecl alien-indirect ;
 541
 542 { 1.0 2.0 } [
 543     1.0 2.0 callback-12 [
 544         callback-12-test [ x>> ] [ y>> ] bi
 545     ] with-callback
 546 ] unit-test
 547
 548 STRUCT: test_struct_16
 549     { x float }
 550     { a int } ;
 551
 552 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a )
 553
 554 { 1.0 2 } [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 555
 556 : callback-13 ( -- callback )
 557     test_struct_16 { float int } cdecl
 558     [
 559         test_struct_16 <struct>
 560             swap >>a
 561             swap >>x
 562     ] alien-callback ;
 563
 564 : callback-13-test ( x1 x2 callback -- result )
 565     test_struct_16 { float int } cdecl alien-indirect ;
 566
 567 { 1.0 2 } [
 568     1.0 2 callback-13 [
 569         callback-13-test [ x>> ] [ a>> ] bi
 570     ] with-callback
 571 ] unit-test
 572
 573 FUNCTION: test_struct_14 ffi_test_44 ( ) inline
 574
 575 { 1.0 2.0 } [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 576
 577 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 578
 579 [ stack-frame-bustage ] must-not-fail
 580
 581 ! C99 tests
 582 os windows? [
 583
 584     FUNCTION: complex-float ffi_test_45 ( int x )
 585
 586     { C{ 3.0 0.0 } } [ 3 ffi_test_45 ] unit-test
 587
 588     FUNCTION: complex-double ffi_test_46 ( int x )
 589
 590     { C{ 3.0 0.0 } } [ 3 ffi_test_46 ] unit-test
 591
 592     FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y )
 593
 594     { C{ 4.0 4.0 } } [
 595         C{ 1.0 2.0 }
 596         C{ 1.5 1.0 } ffi_test_47
 597     ] unit-test
 598
 599     ! Reported by jedahu
 600     STRUCT: bool-field-test
 601         { name c-string }
 602         { on bool }
 603         { parents short } ;
 604
 605     FUNCTION: short ffi_test_48 ( bool-field-test x )
 606
 607     { 123 } [
 608         bool-field-test <struct>
 609             123 >>parents
 610         ffi_test_48
 611     ] unit-test
 612
 613 ] unless
 614
 615 ! Test interaction between threads and callbacks
 616 : thread-callback-1 ( -- callback )
 617     int { } cdecl [ yield 100 ] alien-callback ;
 618
 619 : thread-callback-2 ( -- callback )
 620     int { } cdecl [ yield 200 ] alien-callback ;
 621
 622 : thread-callback-invoker ( callback -- n )
 623     int { } cdecl alien-indirect ;
 624
 625 <promise> "p" set
 626 [
 627     thread-callback-1 [
 628         thread-callback-invoker
 629     ] with-callback "p" get fulfill
 630 ] in-thread
 631 { 200 } [
 632     thread-callback-2 [ thread-callback-invoker ] with-callback
 633 ] unit-test
 634 { 100 } [ "p" get ?promise ] unit-test
 635
 636 ! More alien-assembly tests are in cpu.* vocabs
 637 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 638
 639 { } [ assembly-test-1 ] unit-test
 640
 641 { f } [ "f-fastcall" library-dll f = ] unit-test
 642 { fastcall } [ "f-fastcall" lookup-library abi>> ] unit-test
 643
 644 : ffi_test_49 ( x -- int )
 645     int "f-fastcall" "ffi_test_49" { int } f
 646     alien-invoke gc ;
 647 : ffi_test_50 ( x y -- int )
 648     int "f-fastcall" "ffi_test_50" { int int } f
 649     alien-invoke gc ;
 650 : ffi_test_51 ( x y z -- int )
 651     int "f-fastcall" "ffi_test_51" { int int int } f
 652     alien-invoke gc ;
 653 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
 654     [ int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke ]
 655     3dip
 656     int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke gc ;
 657
 658 { 4 } [ 3 ffi_test_49 ] unit-test
 659 { 8 } [ 3 4 ffi_test_50 ] unit-test
 660 { 13 } [ 3 4 5 ffi_test_51 ] unit-test
 661 { 13 22 } [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
 662
 663 : ffi_test_52 ( x y z -- int )
 664     int "f-fastcall" "ffi_test_52" { int float int } f
 665     alien-invoke gc ;
 666 : ffi_test_53 ( x y z w -- int )
 667     int "f-fastcall" "ffi_test_53" { int float int int } f
 668     alien-invoke gc ;
 669 : ffi_test_57 ( x y -- test-struct-11 )
 670     test-struct-11 "f-fastcall" "ffi_test_57" { int int } f
 671     alien-invoke gc ;
 672 : ffi_test_58 ( x y z -- test-struct-11 )
 673     test-struct-11 "f-fastcall" "ffi_test_58" { int int int } f
 674     alien-invoke gc ;
 675
 676 ! Make sure that large longlong/ulonglong are correctly dealt with
 677 FUNCTION: longlong ffi_test_59 ( longlong x )
 678 FUNCTION: ulonglong ffi_test_60 ( ulonglong x )
 679
 680 { t } [ most-positive-fixnum 1 + [ ffi_test_59 ] keep = ] unit-test
 681 { t } [ most-positive-fixnum 1 + [ ffi_test_60 ] keep = ] unit-test
 682
 683 { -1 } [ -1 ffi_test_59 ] unit-test
 684 { -1 } [ 0xffffffffffffffff ffi_test_59 ] unit-test
 685 { 0xffffffffffffffff } [ -1 ffi_test_60 ] unit-test
 686 { 0xffffffffffffffff } [ 0xffffffffffffffff ffi_test_60 ] unit-test
 687
 688 ! GCC bugs
 689 mingw? [
 690     { 13 } [ 3 4.0 5 ffi_test_52 ] unit-test
 691
 692     { 19 } [ 3 4.0 5 6 ffi_test_53 ] unit-test
 693 ] unless
 694
 695 { S{ test-struct-11 f 7 -1 } } [ 3 4 ffi_test_57 ] unit-test
 696
 697 { S{ test-struct-11 f 7 -3 } } [ 3 4 7 ffi_test_58 ] unit-test
 698
 699 : fastcall-ii-indirect ( x y ptr -- result )
 700     int { int int } fastcall alien-indirect ;
 701
 702 : fastcall-iii-indirect ( x y z ptr -- result )
 703     int { int int int } fastcall alien-indirect ;
 704
 705 : fastcall-ifi-indirect ( x y z ptr -- result )
 706     int { int float int } fastcall alien-indirect ;
 707
 708 : fastcall-ifii-indirect ( x y z w ptr -- result )
 709     int { int float int int } fastcall alien-indirect ;
 710
 711 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
 712     test-struct-11 { int int } fastcall alien-indirect ;
 713
 714 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
 715     test-struct-11 { int int int } fastcall alien-indirect ;
 716
 717 { 8 } [
 718     3 4 &: ffi_test_50 fastcall-ii-indirect
 719 ] unit-test
 720
 721 { 13 } [
 722     3 4 5 &: ffi_test_51 fastcall-iii-indirect
 723 ] unit-test
 724
 725 mingw? [
 726     { 13 } [
 727         3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect
 728     ] unit-test
 729
 730     { 19 } [
 731         3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect
 732     ] unit-test
 733 ] unless
 734
 735 { S{ test-struct-11 f 7 -1 } } [
 736     3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect
 737 ] unit-test
 738
 739 { S{ test-struct-11 f 7 -3 } } [
 740     3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect
 741 ] unit-test
 742
 743 : fastcall-ii-callback ( -- ptr )
 744     int { int int } fastcall [ + 1 + ] alien-callback ;
 745
 746 : fastcall-iii-callback ( -- ptr )
 747     int { int int int } fastcall [ + + 1 + ] alien-callback ;
 748
 749 : fastcall-ifi-callback ( -- ptr )
 750     int { int float int } fastcall
 751     [ [ >integer ] dip + + 1 + ] alien-callback ;
 752
 753 : fastcall-ifii-callback ( -- ptr )
 754     int { int float int int } fastcall
 755     [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
 756
 757 : fastcall-struct-return-ii-callback ( -- ptr )
 758     test-struct-11 { int int } fastcall
 759     [ [ + ] [ - ] 2bi test-struct-11 boa ] alien-callback ;
 760
 761 : fastcall-struct-return-iii-callback ( -- ptr )
 762     test-struct-11 { int int int } fastcall
 763     [ [ drop + ] [ - nip ] 3bi test-struct-11 boa ] alien-callback ;
 764
 765 { 8 } [
 766     3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
 767 ] unit-test
 768
 769 { 13 } [
 770     3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
 771 ] unit-test
 772
 773 { 13 } [
 774     3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
 775 ] unit-test
 776
 777 { 19 } [
 778     3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
 779 ] unit-test
 780
 781 { S{ test-struct-11 f 7 -1 } } [
 782     3 4 fastcall-struct-return-ii-callback [
 783         fastcall-struct-return-ii-indirect
 784     ] with-callback
 785 ] unit-test
 786
 787 { S{ test-struct-11 f 7 -3 } } [
 788     3 4 7 fastcall-struct-return-iii-callback [
 789         fastcall-struct-return-iii-indirect
 790     ] with-callback
 791 ] unit-test
 792
 793 : x64-regression-1 ( -- c )
 794     int { int int int int int } cdecl [ + + + + ] alien-callback ;
 795
 796 : x64-regression-2 ( x x x x x c -- y )
 797     int { int int int int int } cdecl alien-indirect ; inline
 798
 799 { 661 } [
 800     100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
 801 ] unit-test
 802
 803 ! Stack allocation
 804 : blah ( -- x ) { RECT } [
 805     1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
 806 ] with-scoped-allocation ;
 807
 808 { 3 } [ blah ] unit-test
 809
 810 : out-param-test-1 ( -- b )
 811     { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 812
 813 { 12 } [ out-param-test-1 ] unit-test
 814
 815 : out-param-test-2 ( -- b )
 816     { { int initial: 12 } } [ drop ] with-out-parameters ;
 817
 818 { 12 } [ out-param-test-2 ] unit-test
 819
 820 : out-param-test-3 ( -- x y )
 821     { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
 822     with-out-parameters
 823     [ x>> ] [ y>> ] bi ;
 824
 825 { 3.0 4.0 } [ out-param-test-3 ] unit-test
 826
 827 : out-param-callback ( -- a )
 828     void { int pointer: int } cdecl
 829     [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
 830
 831 : out-param-indirect ( a a -- b )
 832     { int } [
 833         swap void { int pointer: int } cdecl
 834         alien-indirect
 835     ] with-out-parameters ;
 836
 837 { 12 } [
 838     6 out-param-callback [ out-param-indirect ] with-callback
 839 ] unit-test
 840
 841 ! Alias analysis regression
 842 : aa-callback-1 ( -- c )
 843     double { } cdecl [ 5.0 ] alien-callback ;
 844
 845 : aa-indirect-1 ( c -- x )
 846     double { } cdecl alien-indirect ; inline
 847
 848 TUPLE: some-tuple x ;
 849
 850 { T{ some-tuple f 5.0 } } [
 851     [
 852         some-tuple new
 853         aa-callback-1 [
 854             aa-indirect-1
 855         ] with-callback >>x
 856     ] compile-call
 857 ] unit-test
 858
 859 ! GC maps regression
 860 : anton's-regression ( -- )
 861     f (free) f (free) ;
 862
 863 { } [ anton's-regression ] unit-test
 864
 865 os windows? [
 866
 867     STRUCT: bool-and-ptr
 868         { b bool }
 869         { ptr void* } ;
 870
 871     FUNCTION: bool-and-ptr ffi_test_61 ( )
 872
 873     ! { S{ bool-and-ptr { b t } { ptr f } } } [ ffi_test_61 ] unit-test
 874     { t } [ ffi_test_61 bool-and-ptr? ] unit-test
 875     { { t f } } [ ffi_test_61 [ b>> ] [ ptr>> ] bi 2array ] unit-test
 876
 877 ] unless
 878
 879 STRUCT: uint-pair
 880     { a uint }
 881     { b uint } ;
 882
 883 FUNCTION: uint-pair ffi_test_62 ( )
 884
 885 {
 886     S{ uint-pair { a 0xabcdefab } { b 0x12345678 } }
 887 } [ ffi_test_62 ] unit-test
 888
 889 STRUCT: ulonglong-pair
 890     { a ulonglong }
 891     { b ulonglong } ;
 892
 893 FUNCTION: ulonglong-pair ffi_test_63 ( )
 894
 895 {
 896     S{ ulonglong-pair { a 0xabcdefabcdefabcd } { b 0x1234567891234567 } }
 897 } [ ffi_test_63 ] unit-test
 898
 899 FUNCTION: void* bug1021_test_1 ( void* s, int x )
 900
 901 ! Sanity test the formula: x sq s +
 902 { t } [
 903     10 [ [ 100 random ] twice 2array ] replicate
 904     [ [ first2 [ <alien> ] dip bug1021_test_1 alien-address ] map ]
 905     [ [ first2 sq + ] map ] bi =
 906 ] unit-test
 907
 908 : each-to100 ( ... quot: ( ... i -- ... ) i -- ... )
 909     dup 100 < [
 910         2dup swap (call) 1 + each-to100
 911     ] [ 2drop ] if ; inline recursive
 912
 913 : run-test ( alien -- seq )
 914     100 33 <array> tuck
 915     [
 916         pick swapd
 917         bug1021_test_1
 918         spin 2 fixnum+fast
 919         set-slot
 920     ] curry curry 0 each-to100 ;
 921
 922 { } [
 923     minor-gc 2000 [
 924         101 <alien> run-test
 925         ! If #1021 ever comes back it will blow up here because
 926         ! alien-address wants an alien not a fixnum.
 927         [ alien-address ] map drop
 928     ] times
 929 ] unit-test
 930
 931 ! Varargs with non-float parameters works.
 932 FUNCTION-ALIAS: do-sum-ints2 int ffi_test_64 ( int n, int a, int b )
 933 FUNCTION-ALIAS: do-sum-ints3 int ffi_test_64 ( int n, int a, int b, int c )
 934
 935 { 30 60 } [
 936     2 10 20 do-sum-ints2
 937     3 10 20 30 do-sum-ints3
 938 ] unit-test
 939
 940 ! Varargs with non-floats doesn't work on windows
 941 FUNCTION-ALIAS: do-sum-doubles2 double ffi_test_65 ( int n, double a, double b )
 942 FUNCTION-ALIAS: do-sum-doubles3 double ffi_test_65 ( int n, double a, double b, double c )
 943
 944 os windows? [
 945     { 27.0 22.0 } [
 946         2 7 20 do-sum-doubles2
 947         3 5 10 7 do-sum-doubles3
 948     ] unit-test
 949 ] unless
 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
 960
 961 ! Tests for System V AMD64 ABI
 962 STRUCT: test_struct_66 { mem1 ulong } { mem2 ulong } ;
 963 STRUCT: test_struct_68 { mem1 ulong } { mem2 ulong } { mem3 ulong } ;
 964 STRUCT: test_struct_69 { mem1 float } { mem2 ulong } { mem3 ulong } ;
 965 FUNCTION: ulong ffi_test_66 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e )
 966 FUNCTION: ulong ffi_test_67 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e ulong _f )
 967 FUNCTION: ulong ffi_test_68 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_68 e test_struct_66 _f )
 968 FUNCTION: ulong ffi_test_69 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_69 e test_struct_66 _f )
 969 FUNCTION: ulong ffi_test_70 ( test_struct_68 a test_struct_68 b, test_struct_66 c )
 970
 971 { 28 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } ffi_test_66 ] unit-test
 972
 973 : callback-14 ( -- callback )
 974     ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl
 975     [| a b c d e |
 976         a b + c +
 977         d [ mem1>> + ] [ mem2>> + ] bi
 978         e [ mem1>> + ] [ mem2>> + ] bi
 979     ] alien-callback ;
 980
 981 : callback-14-test ( a b c d e callback -- result )
 982     ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl alien-indirect ;
 983
 984 { 28 } [
 985     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } callback-14 [
 986         callback-14-test
 987     ] with-callback
 988 ] unit-test
 989
 990 { 44 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 ffi_test_67 ] unit-test
 991
 992 : callback-15 ( -- callback )
 993     ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl
 994     [| a b c d e _f |
 995         a b + c +
 996         d [ mem1>> + ] [ mem2>> + ] bi
 997         e [ mem1>> + ] [ mem2>> + ] bi
 998         _f 2 * +
 999     ] alien-callback ;
1000
1001 : callback-15-test ( a b c d e _f callback -- result )
1002     ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl alien-indirect ;
1003
1004 { 44 } [
1005     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 callback-15 [
1006         callback-15-test
1007     ] with-callback
1008 ] unit-test
1009
1010 { 55 } [
1011     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } ffi_test_68
1012 ] unit-test
1013
1014 : callback-16 ( -- callback )
1015     ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl
1016     [| a b c d e _f |
1017         a b + c +
1018         d [ mem1>> + ] [ mem2>> + ] bi
1019         e [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
1020         _f [ mem1>> + ] [ mem2>> + ] bi
1021     ] alien-callback ;
1022
1023 : callback-16-test ( a b c d e _f callback -- result )
1024     ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl alien-indirect ;
1025
1026 { 55 } [
1027     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } callback-16 [
1028         callback-16-test
1029     ] with-callback
1030 ] unit-test
1031
1032 { 55 } [
1033     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
1034 ] unit-test
1035
1036 : callback-17 ( -- callback )
1037     ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl
1038     [| a b c d e _f |
1039         a b + c +
1040         d [ mem1>> + ] [ mem2>> + ] bi
1041         e [ mem1>> >integer + ] [ mem2>> + ] [ mem3>> + ] tri
1042         _f [ mem1>> + ] [ mem2>> + ] bi
1043     ] alien-callback ;
1044
1045 : callback-17-test ( a b c d e _f callback -- result )
1046     ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl alien-indirect ;
1047
1048 { 55 } [
1049     1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } callback-17 [
1050         callback-17-test
1051     ] with-callback
1052 ] unit-test
1053
1054 { 36 } [
1055     S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } ffi_test_70
1056 ] unit-test
1057
1058 : callback-18 ( -- callback )
1059     ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl
1060     [| a b c |
1061         a [ mem1>> ] [ mem2>> + ] [ mem3>> + ] tri
1062         b [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
1063         c [ mem1>> + ] [ mem2>> + ] bi
1064     ] alien-callback ;
1065
1066 : callback-18-test ( a b c callback -- result )
1067     ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl alien-indirect ;
1068
1069 { 36 } [
1070     S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } callback-18 [
1071         callback-18-test
1072     ] with-callback
1073 ] unit-test