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:" (normalize-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 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
  98
  99 : indirect-test-1' ( ptr -- )
 100     "int" { } "cdecl" alien-indirect drop ;
 101
 102 { 1 0 } [ indirect-test-1' ] must-infer-as
 103
 104 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 105
 106 [ -1 indirect-test-1 ] must-fail
 107
 108 : indirect-test-2 ( x y ptr -- result )
 109     "int" { "int" "int" } "cdecl" alien-indirect gc ;
 110
 111 { 3 1 } [ indirect-test-2 ] must-infer-as
 112
 113 [ 5 ]
 114 [ 2 3 &: ffi_test_2 indirect-test-2 ]
 115 unit-test
 116
 117 : indirect-test-3 ( a b c d ptr -- result )
 118     "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
 119     gc ;
 120
 121 [ f ] [ "f-stdcall" load-library f = ] unit-test
 122 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
 123
 124 : ffi_test_18 ( w x y z -- int )
 125     "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
 126     alien-invoke gc ;
 127
 128 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
 129
 130 : ffi_test_19 ( x y z -- BAR )
 131     "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
 132     alien-invoke gc ;
 133
 134 [ 11 6 -7 ] [
 135     11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
 136 ] unit-test
 137
 138 FUNCTION: double ffi_test_6 float x float y ;
 139 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
 140 [ "a" "b" ffi_test_6 ] must-fail
 141
 142 FUNCTION: double ffi_test_7 double x double y ;
 143 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
 144
 145 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
 146 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
 147
 148 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
 149 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
 150
 151 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 152     double y1, double y2, double y3,
 153     double z1, double z2, double z3 ;
 154
 155 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
 156
 157 ! Make sure XT doesn't get clobbered in stack frame
 158
 159 : 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 )
 160     "int"
 161     "f-cdecl" "ffi_test_31"
 162     { "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" }
 163     alien-invoke gc 3 ;
 164
 165 [ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
 166
 167 : 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 )
 168     "float"
 169     "f-cdecl" "ffi_test_31_point_5"
 170     { "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" }
 171     alien-invoke ;
 172
 173 [ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
 174
 175 FUNCTION: longlong ffi_test_21 long x long y ;
 176
 177 [ 121932631112635269 ]
 178 [ 123456789 987654321 ffi_test_21 ] unit-test
 179
 180 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
 181
 182 [ 987655432 ]
 183 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
 184
 185 [ 1111 f 123456789 ffi_test_22 ] must-fail
 186
 187 STRUCT: RECT
 188     { x float } { y float }
 189     { w float } { h float } ;
 190
 191 : <RECT> ( x y w h -- rect )
 192     RECT <struct>
 193         swap >>h
 194         swap >>w
 195         swap >>y
 196         swap >>x ;
 197
 198 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
 199
 200 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
 201
 202 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
 203
 204 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 205
 206 [ 32.0 ] [
 207     { 1.0 2.0 3.0 } >float-array
 208     { 4.0 5.0 6.0 } >float-array
 209     ffi_test_23
 210 ] unit-test
 211
 212 ! Test odd-size structs
 213 STRUCT: test-struct-1 { x char[1] } ;
 214
 215 FUNCTION: test-struct-1 ffi_test_24 ;
 216
 217 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
 218
 219 STRUCT: test-struct-2 { x char[2] } ;
 220
 221 FUNCTION: test-struct-2 ffi_test_25 ;
 222
 223 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
 224
 225 STRUCT: test-struct-3 { x char[3] } ;
 226
 227 FUNCTION: test-struct-3 ffi_test_26 ;
 228
 229 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
 230
 231 STRUCT: test-struct-4 { x char[4] } ;
 232
 233 FUNCTION: test-struct-4 ffi_test_27 ;
 234
 235 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
 236
 237 STRUCT: test-struct-5 { x char[5] } ;
 238
 239 FUNCTION: test-struct-5 ffi_test_28 ;
 240
 241 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
 242
 243 STRUCT: test-struct-6 { x char[6] } ;
 244
 245 FUNCTION: test-struct-6 ffi_test_29 ;
 246
 247 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
 248
 249 STRUCT: test-struct-7 { x char[7] } ;
 250
 251 FUNCTION: test-struct-7 ffi_test_30 ;
 252
 253 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
 254
 255 STRUCT: test-struct-8 { x double } { y double } ;
 256
 257 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
 258
 259 [ 9.0 ] [
 260     test-struct-8 <struct>
 261     1.0 >>x
 262     2.0 >>y
 263     3 ffi_test_32
 264 ] unit-test
 265
 266 STRUCT: test-struct-9 { x float } { y float } ;
 267
 268 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
 269
 270 [ 9.0 ] [
 271     test-struct-9 <struct>
 272     1.0 >>x
 273     2.0 >>y
 274     3 ffi_test_33
 275 ] unit-test
 276
 277 STRUCT: test-struct-10 { x float } { y int } ;
 278
 279 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
 280
 281 [ 9.0 ] [
 282     test-struct-10 <struct>
 283     1.0 >>x
 284     2 >>y
 285     3 ffi_test_34
 286 ] unit-test
 287
 288 STRUCT: test-struct-11 { x int } { y int } ;
 289
 290 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 291
 292 [ 9.0 ] [
 293     test-struct-11 <struct>
 294     1 >>x
 295     2 >>y
 296     3 ffi_test_35
 297 ] unit-test
 298
 299 STRUCT: test-struct-12 { a int } { x double } ;
 300
 301 : make-struct-12 ( x -- alien )
 302     test-struct-12 <struct>
 303         swap >>x ;
 304
 305 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 306
 307 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 308
 309 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 310
 311 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 312
 313 ! Test callbacks
 314
 315 : callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
 316
 317 [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
 318
 319 [ t ] [ callback-1 alien? ] unit-test
 320
 321 : callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
 322
 323 [ ] [ callback-1 callback_test_1 ] unit-test
 324
 325 : callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
 326
 327 [ ] [ callback-2 callback_test_1 ] unit-test
 328
 329 : callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
 330
 331 [ t ] [
 332     namestack*
 333     3 "x" set callback-3 callback_test_1
 334     namestack* eq?
 335 ] unit-test
 336
 337 [ 5 ] [
 338     [
 339         3 "x" set callback-3 callback_test_1 "x" get
 340     ] with-scope
 341 ] unit-test
 342
 343 : callback-4 ( -- callback )
 344     "void" { } "cdecl" [ "Hello world" write ] alien-callback
 345     gc ;
 346
 347 [ "Hello world" ] [
 348     [ callback-4 callback_test_1 ] with-string-writer
 349 ] unit-test
 350
 351 : callback-5 ( -- callback )
 352     "void" { } "cdecl" [ gc ] alien-callback ;
 353
 354 [ "testing" ] [
 355     "testing" callback-5 callback_test_1
 356 ] unit-test
 357
 358 : callback-5b ( -- callback )
 359     "void" { } "cdecl" [ compact-gc ] alien-callback ;
 360
 361 [ "testing" ] [
 362     "testing" callback-5b callback_test_1
 363 ] unit-test
 364
 365 : callback-6 ( -- callback )
 366     "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
 367
 368 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 369
 370 : callback-7 ( -- callback )
 371     "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
 372
 373 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 374
 375 [ f ] [ namespace global eq? ] unit-test
 376
 377 : callback-8 ( -- callback )
 378     "void" { } "cdecl" [
 379         [ continue ] callcc0
 380     ] 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 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 560
 561 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
 562
 563 FUNCTION: complex-double ffi_test_46 ( int x ) ;
 564
 565 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
 566
 567 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
 568
 569 [ C{ 4.0 4.0 } ] [
 570     C{ 1.0 2.0 }
 571     C{ 1.5 1.0 } ffi_test_47
 572 ] unit-test
 573
 574 ! Reported by jedahu
 575 STRUCT: bool-field-test
 576     { name char* }
 577     { on bool }
 578     { parents short } ;
 579
 580 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 581
 582 [ 123 ] [
 583     bool-field-test <struct>
 584         123 >>parents
 585     ffi_test_48
 586 ] unit-test
 587
 588 ! Regression: calling an undefined function would raise a protection fault
 589 FUNCTION: void this_does_not_exist ( ) ;
 590
 591 [ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
 592