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