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 -- arg' )
 436     f f rot
 437     double-rect-callback
 438     void { void* void* double-rect } cdecl alien-indirect
 439     "example" get-global ;
 440
 441 [ 1.0 2.0 3.0 4.0 ]
 442 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
 443
 444 STRUCT: test_struct_14
 445     { x1 double }
 446     { x2 double } ;
 447
 448 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 449
 450 [ 1.0 2.0 ] [
 451     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 452 ] unit-test
 453
 454 : callback-10 ( -- callback )
 455     test_struct_14 { double double } cdecl
 456     [
 457         test_struct_14 <struct>
 458             swap >>x2
 459             swap >>x1
 460     ] alien-callback ;
 461
 462 : callback-10-test ( x1 x2 callback -- result )
 463     test_struct_14 { double double } cdecl alien-indirect ;
 464
 465 [ 1.0 2.0 ] [
 466     1.0 2.0 callback-10 callback-10-test
 467     [ x1>> ] [ x2>> ] bi
 468 ] unit-test
 469
 470 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 471
 472 [ 1 2.0 ] [
 473     1 2.0 ffi_test_41
 474     [ a>> ] [ x>> ] bi
 475 ] unit-test
 476
 477 : callback-11 ( -- callback )
 478     test-struct-12 { int double } cdecl
 479     [
 480         test-struct-12 <struct>
 481             swap >>x
 482             swap >>a
 483     ] alien-callback ;
 484
 485 : callback-11-test ( x1 x2 callback -- result )
 486     test-struct-12 { int double } cdecl alien-indirect ;
 487
 488 [ 1 2.0 ] [
 489     1 2.0 callback-11 callback-11-test
 490     [ a>> ] [ x>> ] bi
 491 ] unit-test
 492
 493 STRUCT: test_struct_15
 494     { x float }
 495     { y float } ;
 496
 497 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 498
 499 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 500
 501 : callback-12 ( -- callback )
 502     test_struct_15 { float float } cdecl
 503     [
 504         test_struct_15 <struct>
 505             swap >>y
 506             swap >>x
 507     ] alien-callback ;
 508
 509 : callback-12-test ( x1 x2 callback -- result )
 510     test_struct_15 { float float } cdecl alien-indirect ;
 511
 512 [ 1.0 2.0 ] [
 513     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 514 ] unit-test
 515
 516 STRUCT: test_struct_16
 517     { x float }
 518     { a int } ;
 519
 520 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 521
 522 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 523
 524 : callback-13 ( -- callback )
 525     test_struct_16 { float int } cdecl
 526     [
 527         test_struct_16 <struct>
 528             swap >>a
 529             swap >>x
 530     ] alien-callback ;
 531
 532 : callback-13-test ( x1 x2 callback -- result )
 533     test_struct_16 { float int } cdecl alien-indirect ;
 534
 535 [ 1.0 2 ] [
 536     1.0 2 callback-13 callback-13-test
 537     [ x>> ] [ a>> ] bi
 538 ] unit-test
 539
 540 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 541
 542 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 543
 544 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 545
 546 [ ] [ stack-frame-bustage 2drop ] unit-test
 547
 548 ! C99 tests
 549 os windows? [
 550
 551 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 552
 553 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 554
 555 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 556
 557 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 558
 559 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 560
 561 [ C{ 4.0 4.0 } ] [
 562     C{ 1.0 2.0 }
 563     C{ 1.5 1.0 } ffi_test_47
 564 ] unit-test
 565
 566 ! Reported by jedahu
 567 STRUCT: bool-field-test
 568     { name c-string }
 569     { on bool }
 570     { parents short } ;
 571
 572 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 573
 574 [ 123 ] [
 575     bool-field-test <struct>
 576         123 >>parents
 577     ffi_test_48
 578 ] unit-test
 579
 580 ] unless
 581
 582 ! Test interaction between threads and callbacks
 583 : thread-callback-1 ( -- callback )
 584     int { } cdecl [ yield 100 ] alien-callback ;
 585
 586 : thread-callback-2 ( -- callback )
 587     int { } cdecl [ yield 200 ] alien-callback ;
 588
 589 : thread-callback-invoker ( callback -- n )
 590     int { } cdecl alien-indirect ;
 591
 592 <promise> "p" set
 593 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
 594 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
 595 [ 100 ] [ "p" get ?promise ] unit-test
 596
 597 ! Regression: calling an undefined function would raise a protection fault
 598 FUNCTION: void this_does_not_exist ( ) ;
 599
 600 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
 601
 602 ! More alien-assembly tests are in cpu.* vocabs
 603 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
 604
 605 [ ] [ assembly-test-1 ] unit-test