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 [ 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" 9 f f } = ] must-fail-with