basis/compiler/tests/alien.factor

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