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 ;
   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: char* ffi_test_15 char* x char* 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 ] [
 334     namestack*
 335     3 "x" set callback-3 callback_test_1
 336     namestack* eq?
 337 ] unit-test
 338
 339 [ 5 ] [
 340     [
 341         3 "x" set callback-3 callback_test_1 "x" get
 342     ] with-scope
 343 ] unit-test
 344
 345 : callback-4 ( -- callback )
 346     void { } "cdecl" [ "Hello world" write ] alien-callback
 347     gc ;
 348
 349 [ "Hello world" ] [
 350     [ callback-4 callback_test_1 ] with-string-writer
 351 ] unit-test
 352
 353 : callback-5 ( -- callback )
 354     void { } "cdecl" [ gc ] alien-callback ;
 355
 356 [ "testing" ] [
 357     "testing" callback-5 callback_test_1
 358 ] unit-test
 359
 360 : callback-5b ( -- callback )
 361     void { } "cdecl" [ compact-gc ] alien-callback ;
 362
 363 [ "testing" ] [
 364     "testing" callback-5b callback_test_1
 365 ] unit-test
 366
 367 : callback-6 ( -- callback )
 368     void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
 369
 370 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 371
 372 : callback-7 ( -- callback )
 373     void { } "cdecl" [ 1000000 sleep ] alien-callback ;
 374
 375 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 376
 377 [ f ] [ namespace global eq? ] unit-test
 378
 379 : callback-8 ( -- callback )
 380     void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
 381
 382 [ ] [ callback-8 callback_test_1 ] unit-test
 383
 384 : callback-9 ( -- callback )
 385     int { int int int } "cdecl" [
 386         + + 1 +
 387     ] alien-callback ;
 388
 389 FUNCTION: void ffi_test_36_point_5 ( ) ;
 390
 391 [ ] [ ffi_test_36_point_5 ] unit-test
 392
 393 FUNCTION: int ffi_test_37 ( void* func ) ;
 394
 395 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 396
 397 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
 398
 399 STRUCT: test_struct_13
 400 { x1 float }
 401 { x2 float }
 402 { x3 float }
 403 { x4 float }
 404 { x5 float }
 405 { x6 float } ;
 406
 407 : make-test-struct-13 ( -- alien )
 408     test_struct_13 <struct>
 409         1.0 >>x1
 410         2.0 >>x2
 411         3.0 >>x3
 412         4.0 >>x4
 413         5.0 >>x5
 414         6.0 >>x6 ;
 415
 416 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
 417
 418 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
 419
 420 ! Joe Groff found this problem
 421 STRUCT: double-rect
 422 { a double }
 423 { b double }
 424 { c double }
 425 { d double } ;
 426
 427 : <double-rect> ( a b c d -- foo )
 428     double-rect <struct>
 429         swap >>d
 430         swap >>c
 431         swap >>b
 432         swap >>a ;
 433
 434 : >double-rect< ( foo -- a b c d )
 435     {
 436         [ a>> ]
 437         [ b>> ]
 438         [ c>> ]
 439         [ d>> ]
 440     } cleave ;
 441
 442 : double-rect-callback ( -- alien )
 443     void { void* void* double-rect } "cdecl"
 444     [ "example" set-global 2drop ] alien-callback ;
 445
 446 : double-rect-test ( arg -- arg' )
 447     f f rot
 448     double-rect-callback
 449     void { void* void* double-rect } "cdecl" alien-indirect
 450     "example" get-global ;
 451
 452 [ 1.0 2.0 3.0 4.0 ]
 453 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
 454
 455 STRUCT: test_struct_14
 456     { x1 double }
 457     { x2 double } ;
 458
 459 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 460
 461 [ 1.0 2.0 ] [
 462     1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
 463 ] unit-test
 464
 465 : callback-10 ( -- callback )
 466     test_struct_14 { double double } "cdecl"
 467     [
 468         test_struct_14 <struct>
 469             swap >>x2
 470             swap >>x1
 471     ] alien-callback ;
 472
 473 : callback-10-test ( x1 x2 callback -- result )
 474     test_struct_14 { double double } "cdecl" alien-indirect ;
 475
 476 [ 1.0 2.0 ] [
 477     1.0 2.0 callback-10 callback-10-test
 478     [ x1>> ] [ x2>> ] bi
 479 ] unit-test
 480
 481 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 482
 483 [ 1 2.0 ] [
 484     1 2.0 ffi_test_41
 485     [ a>> ] [ x>> ] bi
 486 ] unit-test
 487
 488 : callback-11 ( -- callback )
 489     test-struct-12 { int double } "cdecl"
 490     [
 491         test-struct-12 <struct>
 492             swap >>x
 493             swap >>a
 494     ] alien-callback ;
 495
 496 : callback-11-test ( x1 x2 callback -- result )
 497     test-struct-12 { int double } "cdecl" alien-indirect ;
 498
 499 [ 1 2.0 ] [
 500     1 2.0 callback-11 callback-11-test
 501     [ a>> ] [ x>> ] bi
 502 ] unit-test
 503
 504 STRUCT: test_struct_15
 505     { x float }
 506     { y float } ;
 507
 508 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 509
 510 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
 511
 512 : callback-12 ( -- callback )
 513     test_struct_15 { float float } "cdecl"
 514     [
 515         test_struct_15 <struct>
 516             swap >>y
 517             swap >>x
 518     ] alien-callback ;
 519
 520 : callback-12-test ( x1 x2 callback -- result )
 521     test_struct_15 { float float } "cdecl" alien-indirect ;
 522
 523 [ 1.0 2.0 ] [
 524     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
 525 ] unit-test
 526
 527 STRUCT: test_struct_16
 528     { x float }
 529     { a int } ;
 530
 531 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 532
 533 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
 534
 535 : callback-13 ( -- callback )
 536     test_struct_16 { float int } "cdecl"
 537     [
 538         test_struct_16 <struct>
 539             swap >>a
 540             swap >>x
 541     ] alien-callback ;
 542
 543 : callback-13-test ( x1 x2 callback -- result )
 544     test_struct_16 { float int } "cdecl" alien-indirect ;
 545
 546 [ 1.0 2 ] [
 547     1.0 2 callback-13 callback-13-test
 548     [ x>> ] [ a>> ] bi
 549 ] unit-test
 550
 551 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 552
 553 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
 554
 555 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
 556
 557 [ ] [ stack-frame-bustage 2drop ] unit-test
 558
 559 ! C99 tests
 560 os windows? [
 561
 562 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 563
 564 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 565
 566 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 567
 568 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 569
 570 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 571
 572 [ C{ 4.0 4.0 } ] [
 573     C{ 1.0 2.0 }
 574     C{ 1.5 1.0 } ffi_test_47
 575 ] unit-test
 576
 577 ! Reported by jedahu
 578 STRUCT: bool-field-test
 579     { name char* }
 580     { on bool }
 581     { parents short } ;
 582
 583 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 584
 585 [ 123 ] [
 586     bool-field-test <struct>
 587         123 >>parents
 588     ffi_test_48
 589 ] unit-test
 590
 591 ] unless
 592
 593 ! Regression: calling an undefined function would raise a protection fault
 594 FUNCTION: void this_does_not_exist ( ) ;
 595
 596 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
 597
 598 ! More alien-assembly tests are in cpu.* vocabs
 599 : assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
 600
 601 [ ] [ assembly-test-1 ] unit-test