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