basis/compiler/tests/alien.factor

   1 USING: accessors alien alien.c-types alien.libraries
   2 alien.syntax arrays classes.struct combinators
   3 compiler continuations effects io io.backend io.pathnames
   4 io.streams.string kernel math memory namespaces
   5 namespaces.private parser quotations sequences
   6 specialized-arrays stack-checker stack-checker.errors
   7 system threads tools.test words alien.complex concurrency.promises ;
   8 FROM: alien.c-types => float short ;
   9 SPECIALIZED-ARRAY: float
  10 SPECIALIZED-ARRAY: char
  11 IN: compiler.tests.alien
  12
  13 <<
  14 : libfactor-ffi-tests-path ( -- string )
  15     "resource:" absolute-path
  16     {
  17         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
  18         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
  19         { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
  20     } cond append-path ;
  21
  22 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
  23
  24 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
  25 >>
  26
  27 LIBRARY: f-cdecl
  28
  29 FUNCTION: void ffi_test_0 ;
  30 [ ] [ ffi_test_0 ] unit-test
  31
  32 FUNCTION: int ffi_test_1 ;
  33 [ 3 ] [ ffi_test_1 ] unit-test
  34
  35 FUNCTION: int ffi_test_2 int x int y ;
  36 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
  37 [ "hi" 3 ffi_test_2 ] must-fail
  38
  39 FUNCTION: int ffi_test_3 int x int y int z int t ;
  40 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
  41
  42 FUNCTION: float ffi_test_4 ;
  43 [ 1.5 ] [ ffi_test_4 ] unit-test
  44
  45 FUNCTION: double ffi_test_5 ;
  46 [ 1.5 ] [ ffi_test_5 ] unit-test
  47
  48 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
  49 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
  50 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
  51 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
  52
  53 STRUCT: FOO { x int } { y int } ;
  54
  55 : make-FOO ( x y -- FOO )
  56     FOO <struct> swap >>y swap >>x ;
  57
  58 FUNCTION: int ffi_test_11 int a FOO b int c ;
  59
  60 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
  61
  62 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 ;
  63
  64 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
  65
  66 FUNCTION: FOO ffi_test_14 int x int y ;
  67
  68 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
  69
  70 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
  71
  72 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
  73 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
  74 [ 1 2 ffi_test_15 ] must-fail
  75
  76 STRUCT: BAR { x long } { y long } { z long } ;
  77
  78 FUNCTION: BAR ffi_test_16 long x long y long z ;
  79
  80 [ 11 6 -7 ] [
  81     11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
  82 ] unit-test
  83
  84 STRUCT: TINY { x int } ;
  85
  86 FUNCTION: TINY ffi_test_17 int x ;
  87
  88 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
  89
  90 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
  91
  92 : indirect-test-1 ( ptr -- result )
  93     int { } "cdecl" alien-indirect ;
  94
  95 { 1 1 } [ indirect-test-1 ] must-infer-as
  96
  97 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
  98
  99 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 100
 101 : indirect-test-1' ( ptr -- )
 102     int { } "cdecl" alien-indirect drop ;
 103
 104 { 1 0 } [ indirect-test-1' ] must-infer-as
 105
 106 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 107
 108 [ -1 indirect-test-1 ] must-fail
 109
 110 : indirect-test-2 ( x y ptr -- result )
 111     int { int int } "cdecl" alien-indirect gc ;
 112
 113 { 3 1 } [ indirect-test-2 ] must-infer-as
 114
 115 [ 5 ]
 116 [ 2 3 &: ffi_test_2 indirect-test-2 ]
 117 unit-test
 118
 119 : indirect-test-3 ( a b c d ptr -- result )
 120     int { int int int int } "stdcall" alien-indirect
 121     gc ;
 122
 123 [ f ] [ "f-stdcall" load-library f = ] unit-test
 124 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
 125
 126 : ffi_test_18 ( w x y z -- int )
 127     int "f-stdcall" "ffi_test_18" { int int int int }
 128     alien-invoke gc ;
 129
 130 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 131
 132 : ffi_test_19 ( x y z -- BAR )
 133     BAR "f-stdcall" "ffi_test_19" { long long long }
 134     alien-invoke gc ;
 135
 136 [ 11 6 -7 ] [
 137     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 138 ] unit-test
 139
 140 FUNCTION: double ffi_test_6 float x float y ;
 141 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 142 [ "a" "b" ffi_test_6 ] must-fail
 143
 144 FUNCTION: double ffi_test_7 double x double y ;
 145 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 146
 147 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 148 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 149
 150 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 151 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 152
 153 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 154     double y1, double y2, double y3,
 155     double z1, double z2, double z3 ;
 156
 157 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 158
 159 ! Make sure XT doesn't get clobbered in stack frame
 160
 161 : 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 )
 162     int
 163     "f-cdecl" "ffi_test_31"
 164     { 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 }
 165     alien-invoke gc 3 ;
 166
 167 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 168
 169 : 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 )
 170     float
 171     "f-cdecl" "ffi_test_31_point_5"
 172     { 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 }
 173     alien-invoke ;
 174
 175 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 176
 177 FUNCTION: longlong ffi_test_21 long x long y ;
 178
 179 [ 121932631112635269 ]
 180 [ 123456789 987654321 ffi_test_21 ] unit-test
 181
 182 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 183
 184 [ 987655432 ]
 185 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 186
 187 [ 1111 f 123456789 ffi_test_22 ] must-fail
 188
 189 STRUCT: RECT
 190     { x float } { y float }
 191     { w float } { h float } ;
 192
 193 : <RECT> ( x y w h -- rect )
 194     RECT <struct>
 195         swap >>h
 196         swap >>w
 197         swap >>y
 198         swap >>x ;
 199
 200 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
 201
 202 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 203
 204 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 205
 206 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 207
 208 [ 32.0 ] [
 209     { 1.0 2.0 3.0 } >float-array
 210     { 4.0 5.0 6.0 } >float-array
 211     ffi_test_23
 212 ] unit-test
 213
 214 ! Test odd-size structs
 215 STRUCT: test-struct-1 { x char[1] } ;
 216
 217 FUNCTION: test-struct-1 ffi_test_24 ;
 218
 219 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
 220
 221 STRUCT: test-struct-2 { x char[2] } ;
 222
 223 FUNCTION: test-struct-2 ffi_test_25 ;
 224
 225 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
 226
 227 STRUCT: test-struct-3 { x char[3] } ;
 228
 229 FUNCTION: test-struct-3 ffi_test_26 ;
 230
 231 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
 232
 233 STRUCT: test-struct-4 { x char[4] } ;
 234
 235 FUNCTION: test-struct-4 ffi_test_27 ;
 236
 237 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
 238
 239 STRUCT: test-struct-5 { x char[5] } ;
 240
 241 FUNCTION: test-struct-5 ffi_test_28 ;
 242
 243 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
 244
 245 STRUCT: test-struct-6 { x char[6] } ;
 246
 247 FUNCTION: test-struct-6 ffi_test_29 ;
 248
 249 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
 250
 251 STRUCT: test-struct-7 { x char[7] } ;
 252
 253 FUNCTION: test-struct-7 ffi_test_30 ;
 254
 255 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
 256
 257 STRUCT: test-struct-8 { x double } { y double } ;
 258
 259 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 260
 261 [ 9.0 ] [
 262     test-struct-8 <struct>
 263     1.0 >>x
 264     2.0 >>y
 265     3 ffi_test_32
 266 ] unit-test
 267
 268 STRUCT: test-struct-9 { x float } { y float } ;
 269
 270 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 271
 272 [ 9.0 ] [
 273     test-struct-9 <struct>
 274     1.0 >>x
 275     2.0 >>y
 276     3 ffi_test_33
 277 ] unit-test
 278
 279 STRUCT: test-struct-10 { x float } { y int } ;
 280
 281 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 282
 283 [ 9.0 ] [
 284     test-struct-10 <struct>
 285     1.0 >>x
 286     2 >>y
 287     3 ffi_test_34
 288 ] unit-test
 289
 290 STRUCT: test-struct-11 { x int } { y int } ;
 291
 292 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 293
 294 [ 9.0 ] [
 295     test-struct-11 <struct>
 296     1 >>x
 297     2 >>y
 298     3 ffi_test_35
 299 ] unit-test
 300
 301 STRUCT: test-struct-12 { a int } { x double } ;
 302
 303 : make-struct-12 ( x -- alien )
 304     test-struct-12 <struct>
 305         swap >>x ;
 306
 307 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 308
 309 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 310
 311 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 312
 313 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 314
 315 ! Test callbacks
 316
 317 : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
 318
 319 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 320
 321 [ t ] [ callback-1 alien? ] unit-test
 322
 323 : callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
 324
 325 [ ] [ callback-1 callback_test_1 ] unit-test
 326
 327 : callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
 328
 329 [ ] [ callback-2 callback_test_1 ] unit-test
 330
 331 : callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
 332
 333 [ t 3 5 ] [
 334     [
 335         namestack*
 336         3 "x" set callback-3 callback_test_1
 337         namestack* eq?
 338         "x" get "x" get-global
 339     ] with-scope
 340 ] unit-test
 341
 342 : callback-5 ( -- callback )
 343     void { } "cdecl" [ gc ] alien-callback ;
 344
 345 [ "testing" ] [
 346     "testing" callback-5 callback_test_1
 347 ] unit-test
 348
 349 : callback-5b ( -- callback )
 350     void { } "cdecl" [ compact-gc ] alien-callback ;
 351
 352 [ "testing" ] [
 353     "testing" callback-5b callback_test_1
 354 ] unit-test
 355
 356 : callback-6 ( -- callback )
 357     void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
 358
 359 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 360
 361 : callback-7 ( -- callback )
 362     void { } "cdecl" [ 1000000 sleep ] alien-callback ;
 363
 364 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 365
 366 [ f ] [ namespace global eq? ] unit-test
 367
 368 : callback-8 ( -- callback )
 369     void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
 370
 371 [ ] [ callback-8 callback_test_1 ] unit-test
 372
 373 : callback-9 ( -- callback )
 374     int { int int int } "cdecl" [
 375         + + 1 +
 376     ] alien-callback ;
 377
 378 FUNCTION: void ffi_test_36_point_5 ( ) ;
 379
 380 [ ] [ ffi_test_36_point_5 ] unit-test
 381
 382 FUNCTION: int ffi_test_37 ( void* func ) ;
 383
 384 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 385
 386 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
 387
 388 STRUCT: test_struct_13
 389 { x1 float }
 390 { x2 float }
 391 { x3 float }
 392 { x4 float }
 393 { x5 float }
 394 { x6 float } ;
 395
 396 : make-test-struct-13 ( -- alien )
 397     test_struct_13 <struct>
 398         1.0 >>x1
 399         2.0 >>x2
 400         3.0 >>x3
 401         4.0 >>x4
 402         5.0 >>x5
 403         6.0 >>x6 ;
 404
 405 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 406
 407 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 408
 409 ! Joe Groff found this problem
 410 STRUCT: double-rect
 411 { a double }
 412 { b double }
 413 { c double }
 414 { d double } ;
 415
 416 : <double-rect> ( a b c d -- foo )
 417     double-rect <struct>
 418         swap >>d
 419         swap >>c
 420         swap >>b
 421         swap >>a ;
 422
 423 : >double-rect< ( foo -- a b c d )
 424     {
 425         [ a>> ]
 426         [ b>> ]
 427         [ c>> ]
 428         [ d>> ]
 429     } cleave ;
 430
 431 : double-rect-callback ( -- alien )
 432     void { void* void* double-rect } "cdecl"
 433     [ "example" set-global 2drop ] alien-callback ;
 434
 435 : double-rect-test ( arg callback -- arg' )
 436     [ f f ] 2dip
 437     void { void* void* double-rect } "cdecl" alien-indirect
 438     "example" get-global ;
 439
 440 [ 1.0 2.0 3.0 4.0 ]
 441 [
 442     1.0 2.0 3.0 4.0 <double-rect>
 443     double-rect-callback double-rect-test
 444     >double-rect<
 445 ] unit-test
 446
 447 STRUCT: test_struct_14
 448     { x1 double }
 449     { x2 double } ;
 450
 451 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 452
 453 [ 1.0 2.0 ] [
 454     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 455 ] unit-test
 456
 457 : callback-10 ( -- callback )
 458     test_struct_14 { double double } "cdecl"
 459     [
 460         test_struct_14 <struct>
 461             swap >>x2
 462             swap >>x1
 463     ] alien-callback ;
 464
 465 : callback-10-test ( x1 x2 callback -- result )
 466     test_struct_14 { double double } "cdecl" alien-indirect ;
 467
 468 [ 1.0 2.0 ] [
 469     1.0 2.0 callback-10 callback-10-test
 470     [ x1>> ] [ x2>> ] bi
 471 ] unit-test
 472
 473 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 474
 475 [ 1 2.0 ] [
 476     1 2.0 ffi_test_41
 477     [ a>> ] [ x>> ] bi
 478 ] unit-test
 479
 480 : callback-11 ( -- callback )
 481     test-struct-12 { int double } "cdecl"
 482     [
 483         test-struct-12 <struct>
 484             swap >>x
 485             swap >>a
 486     ] alien-callback ;
 487
 488 : callback-11-test ( x1 x2 callback -- result )
 489     test-struct-12 { int double } "cdecl" alien-indirect ;
 490
 491 [ 1 2.0 ] [
 492     1 2.0 callback-11 callback-11-test
 493     [ a>> ] [ x>> ] bi
 494 ] unit-test
 495
 496 STRUCT: test_struct_15
 497     { x float }
 498     { y float } ;
 499
 500 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 501
 502 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 503
 504 : callback-12 ( -- callback )
 505     test_struct_15 { float float } "cdecl"
 506     [
 507         test_struct_15 <struct>
 508             swap >>y
 509             swap >>x
 510     ] alien-callback ;
 511
 512 : callback-12-test ( x1 x2 callback -- result )
 513     test_struct_15 { float float } "cdecl" alien-indirect ;
 514
 515 [ 1.0 2.0 ] [
 516     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 517 ] unit-test
 518
 519 STRUCT: test_struct_16
 520     { x float }
 521     { a int } ;
 522
 523 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 524
 525 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 526
 527 : callback-13 ( -- callback )
 528     test_struct_16 { float int } "cdecl"
 529     [
 530         test_struct_16 <struct>
 531             swap >>a
 532             swap >>x
 533     ] alien-callback ;
 534
 535 : callback-13-test ( x1 x2 callback -- result )
 536     test_struct_16 { float int } "cdecl" alien-indirect ;
 537
 538 [ 1.0 2 ] [
 539     1.0 2 callback-13 callback-13-test
 540     [ x>> ] [ a>> ] bi
 541 ] unit-test
 542
 543 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 544
 545 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 546
 547 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 548
 549 [ ] [ stack-frame-bustage 2drop ] unit-test
 550
 551 ! C99 tests
 552 os windows? [
 553
 554 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 555
 556 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 557
 558 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 559
 560 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 561
 562 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 563
 564 [ C{ 4.0 4.0 } ] [
 565     C{ 1.0 2.0 }
 566     C{ 1.5 1.0 } ffi_test_47
 567 ] unit-test
 568
 569 ! Reported by jedahu
 570 STRUCT: bool-field-test
 571     { name c-string }
 572     { on bool }
 573     { parents short } ;
 574
 575 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 576
 577 [ 123 ] [
 578     bool-field-test <struct>
 579         123 >>parents
 580     ffi_test_48
 581 ] unit-test
 582
 583 ] unless
 584
 585 ! Test interaction between threads and callbacks
 586 : thread-callback-1 ( -- callback )
 587     int { } "cdecl" [ yield 100 ] alien-callback ;
 588
 589 : thread-callback-2 ( -- callback )
 590     int { } "cdecl" [ yield 200 ] alien-callback ;
 591
 592 : thread-callback-invoker ( callback -- n )
 593     int { } "cdecl" alien-indirect ;
 594
 595 <promise> "p" set
 596 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
 597 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
 598 [ 100 ] [ "p" get ?promise ] unit-test
 599
 600 ! Regression: calling an undefined function would raise a protection fault
 601 FUNCTION: void this_does_not_exist ( ) ;
 602
 603 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
 604
 605 ! More alien-assembly tests are in cpu.* vocabs
 606 : assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
 607
 608 [ ] [ assembly-test-1 ] unit-test