t/op/calling.t

   1 #!perl
   2 # Copyright (C) 2001-2009, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8
   9 use Test::More;
  10 use Parrot::Test tests => 97;
  11
  12 =head1 NAME
  13
  14 t/op/calling.t - Parrot Calling Conventions
  15
  16 =head1 SYNOPSIS
  17
  18     % prove t/op/calling.t
  19
  20 =head1 DESCRIPTION
  21
  22 Tests Parrot calling conventions.
  23
  24 =cut
  25
  26 pasm_output_is( <<'CODE', <<'OUTPUT', "set_args - parsing" );
  27     noop
  28     set_args "0, 0", P0, I0
  29     print "Ok 1\n"
  30     set_args ""
  31     print "Ok 2\n"
  32     end
  33 CODE
  34 Ok 1
  35 Ok 2
  36 OUTPUT
  37
  38 pasm_output_is( <<'CODE', <<'OUTPUT', "var_args - parsing" );
  39 .pcc_sub main:
  40     print "Ok 1\n"
  41     set_args "0, 0", P0, I0
  42     get_results "0", I0
  43     find_name P1, "foo"
  44     print "Ok 2\n"
  45     invokecc P1
  46     print "Ok 5\n"
  47     end
  48 .pcc_sub foo:
  49     get_params "0, 0", P0, I0
  50     print "Ok 3\n"
  51     set_returns "0", 42
  52     print "Ok 4\n"
  53     returncc
  54 CODE
  55 Ok 1
  56 Ok 2
  57 Ok 3
  58 Ok 4
  59 Ok 5
  60 OUTPUT
  61
  62 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic" );
  63 .pcc_sub main:
  64     set I16, 77
  65     set_args "0, 0", 42, I16
  66     find_name P1, "foo"
  67     invokecc P1
  68     print "back\n"
  69     end
  70 .pcc_sub foo:
  71     get_params "0, 0", I16, I17
  72     print I16
  73     print "\n"
  74     print I17
  75     print "\n"
  76     returncc
  77 CODE
  78 42
  79 77
  80 back
  81 OUTPUT
  82
  83 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic, return i, ic" );
  84 .pcc_sub main:
  85     set I16, 77
  86     set_args "0, 0", 42, I16
  87     get_results "0, 0", I16, I17
  88     find_name P1, "foo"
  89     invokecc P1
  90     print I16
  91     print "\n"
  92     print I17
  93     print "\nback\n"
  94     end
  95 .pcc_sub foo:
  96     get_params "0, 0", I16, I17
  97     print I16
  98     print "\n"
  99     print I17
 100     print "\n"
 101     set I16, 88
 102     set_returns "0, 0", 99, I16
 103     returncc
 104 CODE
 105 42
 106 77
 107 99
 108 88
 109 back
 110 OUTPUT
 111
 112 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic, return i, ic - adjust sig" );
 113 .pcc_sub main:
 114     set I16, 77
 115     set_args "0, 0", 42, I16
 116     get_results "0, 0", I16, I17
 117     find_name P1, "foo"
 118     invokecc P1
 119     print I16
 120     print "\n"
 121     print I17
 122     print "\nback\n"
 123     end
 124 .pcc_sub foo:
 125     get_params "0, 0", I16, I17
 126     print I16
 127     print "\n"
 128     print I17
 129     print "\n"
 130     set I16, 88
 131     set_returns "0, 0", 99, I16
 132     returncc
 133 CODE
 134 42
 135 77
 136 99
 137 88
 138 back
 139 OUTPUT
 140
 141 pasm_output_is( <<'CODE', <<'OUTPUT', "all together now" );
 142 .pcc_sub main:
 143     set I16, 77
 144     set N16, 2.3
 145     set S16, "ok 1\n"
 146     new P16, 'Integer'
 147     set P16, 101
 148     set_args "0, 0, 0, 0, 0, 0, 0", 42, I16, 4.5, N16, S16, "ok 2\n", P16
 149     get_results "0, 0, 0, 0", I16, N16, S16, P16
 150     find_name P1, "foo"
 151     invokecc P1
 152     print I16
 153     print "\n"
 154     print N16
 155     print "\n"
 156     print S16
 157     print P16
 158     end
 159 .pcc_sub foo:
 160     get_params "0, 0, 0, 0, 0, 0, 0", I16, I17, N16, N17, S16, S17, P16
 161     print I16
 162     print "\n"
 163     print I17
 164     print "\n"
 165     print N16
 166     print "\n"
 167     print N17
 168     print "\n"
 169     print S16
 170     print S17
 171     print P16
 172     print "\n"
 173     set I16, 88
 174     set N16, 5.5
 175     set S16, "ok 3\n"
 176     new P16, 'String'
 177     set P16, "ok 4\n"
 178     set_returns "0, 0, 0, 0", I16, N16, S16, P16
 179     returncc
 180 CODE
 181 42
 182 77
 183 4.5
 184 2.3
 185 ok 1
 186 ok 2
 187 101
 188 88
 189 5.5
 190 ok 3
 191 ok 4
 192 OUTPUT
 193
 194 pasm_output_is( <<'CODE', <<'OUTPUT', "flatten arg" );
 195 .pcc_sub main:
 196     new P16, 'String'
 197     set P16, "ok 1\n"
 198     new P17, 'ResizablePMCArray'
 199     push P17, "ok 2\n"
 200     push P17, "ok 3\n"
 201     push P17, "ok 4\n"
 202     new P18, 'String'
 203     set P18, "ok 5\n"
 204     set_args "0, 0x20, 0", P16, P17, P18
 205     find_name P1, "foo"
 206     invokecc P1
 207     print "back\n"
 208     end
 209 .pcc_sub foo:
 210     get_params "0, 0, 0, 0, 0", P1, P2, P3, P4, P5
 211     print P1
 212     print P2
 213     print P3
 214     print P4
 215     print P5
 216     returncc
 217 CODE
 218 ok 1
 219 ok 2
 220 ok 3
 221 ok 4
 222 ok 5
 223 back
 224 OUTPUT
 225
 226 pasm_output_is( <<'CODE', <<'OUTPUT', "slurpy param" );
 227 .pcc_sub main:
 228     new P16, 'String'
 229     set P16, "ok 1\n"
 230     new P17, 'String'
 231     set P17, "ok 2\n"
 232     new P18, 'String'
 233     set P18, "ok 3\n"
 234     set_args "0, 0, 0", P16, P17, P18
 235     find_name P1, "foo"
 236     invokecc P1
 237     print "back\n"
 238     end
 239 .pcc_sub foo:
 240     get_params "0, 0x20", P1, P2
 241     print P1
 242     set I0, P2
 243     print I0
 244     print "\n"
 245     set S0, P2[0]
 246     print S0
 247     set S0, P2[1]
 248     print S0
 249     returncc
 250 CODE
 251 ok 1
 252 2
 253 ok 2
 254 ok 3
 255 back
 256 OUTPUT
 257
 258 pir_output_is( <<'CODE', <<'OUTPUT', "use it in PIR" );
 259 .sub main :main
 260     $P0 = new 'String'
 261     $P0 = "hello\n"
 262     find_name $P1, "foo"
 263     # set_args and invoke must be adjacent
 264     set_args "0", $P0
 265     invokecc $P1
 266 .end
 267 .sub foo
 268     get_params "0", $P0
 269     print $P0
 270 .end
 271 CODE
 272 hello
 273 OUTPUT
 274
 275 pasm_output_is( <<'CODE', <<'OUTPUT', "flatten + slurpy param" );
 276 .pcc_sub main:
 277     new P16, 'String'
 278     set P16, "ok 1\n"
 279     new P19, 'ResizablePMCArray'
 280     new P17, 'String'
 281     set P17, "ok 2\n"
 282     push P19, P17
 283     new P18, 'String'
 284     set P18, "ok 3\n"
 285     push P19, P18
 286     new P20, 'ResizablePMCArray'
 287     new P17, 'String'
 288     set P17, "ok 4\n"
 289     push P20, P17
 290     new P18, 'String'
 291     set P18, "ok 5\n"
 292     push P20, P18
 293     new P21, 'String'
 294     set P21, "ok 6\n"
 295     set_args "0, 0x20, 0x20, 0", P16, P19, P20, P21
 296     find_name P1, "foo"
 297     invokecc P1
 298     print "back\n"
 299     end
 300 .pcc_sub foo:
 301     get_params "0, 0x20", P1, P2
 302     print P1
 303     set I0, P2
 304     print I0
 305     print "\n"
 306     set S0, P2[0]
 307     print S0
 308     set S0, P2[1]
 309     print S0
 310     set S0, P2[2]
 311     print S0
 312     set S0, P2[3]
 313     print S0
 314     set S0, P2[4]
 315     print S0
 316     set P0, P2[5]
 317     if_null P0, ok
 318     print "not ok 7\n"
 319  ok:
 320     returncc
 321 CODE
 322 ok 1
 323 5
 324 ok 2
 325 ok 3
 326 ok 4
 327 ok 5
 328 ok 6
 329 back
 330 OUTPUT
 331
 332 pir_output_is( <<'CODE', <<'OUTPUT', "use it in PIR" );
 333 .sub main :main
 334     $P0 = new 'String'
 335     $P0 = "hello\n"
 336     find_name $P1, "foo"
 337     # set_args and invoke must be adjacent
 338     set_args "0", $P0
 339     invokecc $P1
 340 .end
 341 .sub foo
 342     get_params "0", $P0
 343     print $P0
 344 .end
 345 CODE
 346 hello
 347 OUTPUT
 348
 349 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - autobox" );
 350 .sub main :main
 351     $P0 = new 'String'
 352     $P0 = "hello"
 353     find_name $P1, "foo"
 354     # set_args and invoke must be adjacent
 355     set_args "0,0,0", $P0, 42, "bar"
 356     invokecc $P1
 357 .end
 358 .sub foo
 359     get_params "0x20", $P0
 360     $S0 = $P0[0]
 361     print $S0
 362     print ' '
 363     $S0 = $P0[1]
 364     print $S0
 365     print ' '
 366     $S0 = $P0[2]
 367     print $S0
 368     print "\n"
 369 .end
 370 CODE
 371 hello 42 bar
 372 OUTPUT
 373
 374 pir_output_is( <<'CODE', <<'OUTPUT', "more autobox" );
 375 .sub main :main
 376         foo( 101, 0.77, 'seven and seven is' )
 377 .end
 378
 379 .sub foo
 380         .param pmc some_int
 381         .param pmc some_float
 382         .param pmc some_string
 383
 384         $S0 = typeof some_int
 385         print $S0
 386         print "\n"
 387
 388         $S0 = typeof some_float
 389         print $S0
 390         print "\n"
 391
 392         $S0 = typeof some_string
 393         print $S0
 394         print "\n"
 395
 396         .return()
 397 .end
 398 CODE
 399 Integer
 400 Float
 401 String
 402 OUTPUT
 403
 404 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - fetch" );
 405 .sub main :main
 406     $P0 = new 'String'
 407     $P0 = "hello"
 408     $P1 = new 'Integer'
 409     $P1 = 42
 410     $P2 = new 'String'
 411     $P2 = "again"
 412     $P3 = new 'Float'
 413     $P3 = 47.11
 414     find_name $P10, "foo"
 415     # set_args and invoke must be adjacent
 416     set_args "0,0,0,0", $P0, $P1, $P2, $P3
 417     invokecc $P10
 418 .end
 419 .sub foo
 420     get_params "0,0,0,0", $P0, $I0, $S0, $N0
 421     print $P0
 422     print ' '
 423     print $I0
 424     print ' '
 425     print $S0
 426     print ' '
 427     print $N0
 428     print "\n"
 429     returncc
 430 .end
 431 CODE
 432 hello 42 again 47.11
 433 OUTPUT
 434
 435 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too few" );
 436 .sub main :main
 437     .include "errors.pasm"
 438     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 439     $P0 = new 'String'
 440     $P0 = "hello\n"
 441     find_name $P1, "foo"
 442     set_args "0", $P0
 443     invokecc $P1
 444 .end
 445 .sub foo
 446     get_params "0,0", $P0, $P1
 447     print $P0
 448 .end
 449 CODE
 450 /too few positional arguments/
 451 OUTPUT
 452
 453 pir_output_like(
 454     <<'CODE', <<'OUTPUT', "argc mismatch, too many - no getparams", todo => 'no get_params at all' );
 455 .sub main :main
 456     .include "errors.pasm"
 457     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 458     foo(5)
 459 .end
 460 .sub foo
 461     print "nada"
 462 .end
 463 CODE
 464 /too many arguments passed/
 465 OUTPUT
 466
 467 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - force get_params" );
 468 .macro no_params
 469     get_params '()'
 470 .endm
 471 .sub main :main
 472     .include "errors.pasm"
 473     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 474     foo(5)
 475 .end
 476 .sub foo
 477     .no_params
 478     print "nada"
 479 .end
 480 CODE
 481 /too many positional arguments/
 482 OUTPUT
 483
 484 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many" );
 485 .sub main :main
 486     .include "errors.pasm"
 487     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 488     $P0 = new 'String'
 489     $P0 = "hello\n"
 490     find_name $P1, "foo"
 491     set_args "0,0", $P0, 77
 492     invokecc $P1
 493 .end
 494 .sub foo
 495     get_params "0", $P0
 496     print $P0
 497 .end
 498 CODE
 499 /too many positional arguments/
 500 OUTPUT
 501
 502 pir_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - catch exception" );
 503 .sub main :main
 504     .include "errors.pasm"
 505     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 506     $P0 = new 'String'
 507     $P0 = "hello\n"
 508     find_name $P1, "foo"
 509     set_args "0,0", $P0, 77
 510     invokecc $P1
 511 .end
 512 .sub foo
 513     push_eh arg_handler
 514     get_params "0", $P0
 515     print $P0
 516     print "never\n"
 517 arg_handler:
 518     get_results "0", $P1
 519     $S0 = $P1
 520     print "caught: "
 521     print $S0
 522 #    $S1 = typeof $P1
 523 #    print "\nexception type: "
 524 #    print $S1
 525 .end
 526 CODE
 527 /^caught: too many positional arguments/
 528 OUTPUT
 529
 530 pir_output_is( <<'CODE', <<'OUTPUT', "argc mismatch, optional" );
 531 .sub main :main
 532     .include "errors.pasm"
 533     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 534     $P0 = new 'String'
 535     $P0 = "hello\n"
 536     find_name $P1, "foo"
 537     set_args "0", $P0
 538     invokecc $P1
 539 .end
 540 .sub foo
 541     get_params "0,0x80,0x100", $P0, $P1, $I0
 542     print $P0
 543     if_null $P1, ok
 544     print "not "
 545 ok:
 546     print "ok\n"
 547 .end
 548 CODE
 549 hello
 550 ok
 551 OUTPUT
 552
 553 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, optional" );
 554 .sub main :main
 555     .include "errors.pasm"
 556     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
 557     .local pmc ar
 558     ar = new 'ResizableIntegerArray'
 559     push ar, 1
 560     push ar, 2
 561     push ar, 3
 562     push ar, 4
 563     foo(ar :flat)
 564     print "never\n"
 565 .end
 566 .sub foo
 567     .param int i
 568     .param int j     :optional
 569     .param int got_j :opt_flag
 570     .param int k     :optional
 571     .param int got_k :opt_flag
 572 .end
 573 CODE
 574 /too many positional arguments/
 575 OUTPUT
 576
 577 pasm_output_is( <<'CODE', <<'OUTPUT', "get_param later" );
 578 .pcc_sub main:
 579     set I16, 77
 580     set_args "0, 0", 42, I16
 581     get_results "0, 0", I16, I17
 582     find_name P1, "foo"
 583     invokecc P1
 584     print I16
 585     print "\n"
 586     print I17
 587     print "\nback\n"
 588     end
 589 .pcc_sub foo:
 590     noop
 591     get_params "0, 0", I16, I17
 592     print I16
 593     print "\n"
 594     print I17
 595     print "\n"
 596     set I16, 88
 597     set_returns "4, 0", 99, I16
 598     returncc
 599 CODE
 600 42
 601 77
 602 99
 603 88
 604 back
 605 OUTPUT
 606
 607 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 1" );
 608 .sub main :main
 609     .const 'Sub' f = "foo"
 610     print "main\n"
 611     get_results "0", $S0
 612     invokecc f
 613     print $S0
 614 .end
 615 .sub foo
 616     .const 'Sub' b = "bar"
 617     print "foo\n"
 618     tailcall b
 619 .end
 620 .sub bar
 621     print "bar\n"
 622     set_returns "0", "bar_ret\n"
 623     returncc
 624 .end
 625 CODE
 626 main
 627 foo
 628 bar
 629 bar_ret
 630 OUTPUT
 631
 632 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 2 - pass arg" );
 633 .sub main :main
 634     .const 'Sub' f = "foo"
 635     print "main\n"
 636     get_results "0", $S0
 637     invokecc f
 638     print $S0
 639 .end
 640 .sub foo
 641     .const 'Sub' b = "bar"
 642     print "foo\n"
 643     set_args "0", "from_foo\n"
 644     tailcall b
 645 .end
 646 .sub bar
 647     get_params "0", $S0
 648     print "bar\n"
 649     print $S0
 650     set_returns "0", "bar_ret\n"
 651     returncc
 652 .end
 653 CODE
 654 main
 655 foo
 656 bar
 657 from_foo
 658 bar_ret
 659 OUTPUT
 660
 661 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 3 - pass arg" );
 662 .sub main :main
 663     .const 'Sub' f = "foo"
 664     print "main\n"
 665     get_results "0", $S0
 666     invokecc f
 667     print $S0
 668 .end
 669 .sub foo
 670     .const 'Sub' b = "bar"
 671     print "foo\n"
 672     set_args "0", "from_foo\n"
 673     tailcall b
 674 .end
 675 .sub bar
 676     get_params "0", $S0
 677     print "bar\n"
 678     print $S0
 679     set_returns "0", "bar_ret\n"
 680     returncc
 681 .end
 682 CODE
 683 main
 684 foo
 685 bar
 686 from_foo
 687 bar_ret
 688 OUTPUT
 689
 690 pir_output_is( <<'CODE', <<'OUTPUT', "empty args" );
 691 .sub main :main
 692     $P0 = new 'String'
 693     $P0 = "hello\n"
 694     find_name $P1, "foo"
 695     set_args ""
 696     invokecc $P1
 697 .end
 698 .sub foo
 699     get_params "0x80, 0x100", $P1, $I0
 700     if_null $P1, ok
 701     print "not "
 702 ok:
 703     print "ok\n"
 704 .end
 705 CODE
 706 ok
 707 OUTPUT
 708
 709 pir_output_is( <<'CODE', <<'OUTPUT', "optional args" );
 710 .sub main :main
 711     $P0 = new 'String'
 712     $P0 = "hello\n"
 713     find_name $P1, "foo"
 714     set_args "0x0", $P0
 715     invokecc $P1
 716 .end
 717 .sub foo
 718     get_params "0x80, 0x100", $P1, $I0
 719     unless_null $P1, ok
 720     print "not "
 721 ok:
 722     print "ok\n"
 723 .end
 724 CODE
 725 ok
 726 OUTPUT
 727
 728 pir_output_is( <<'CODE', <<'OUTPUT', "pir uses no ops" );
 729 .sub main :main
 730     $I0 = 77
 731     foo(42, $I0)
 732     print "back\n"
 733 .end
 734
 735 .sub foo
 736     get_params "0, 0", $I16, $I17
 737     print $I16
 738     print "\n"
 739     print $I17
 740     print "\n"
 741     set_returns ""
 742     returncc
 743 .end
 744 CODE
 745 42
 746 77
 747 back
 748 OUTPUT
 749
 750 pir_output_is( <<'CODE', <<'OUTPUT', "pir call evaled code" );
 751 .sub main :main
 752     .local string s
 753     s  = ".sub foo\n"
 754     s .= ".param int i\n"
 755     s .= ".param int j\n"
 756     s .= "print i\n"
 757     s .= "print ' '\n"
 758     s .= "print j\n"
 759     s .= "print \"\\n\"\n"
 760     s .= ".return(99)\n"
 761     s .= ".end\n"
 762     .local pmc comp
 763     comp = compreg "PIR"
 764     $P0 = comp(s)
 765     $I0 = 77
 766     $I0 = foo(42, $I0)
 767     print $I0
 768     print "\n"
 769 .end
 770
 771 CODE
 772 42 77
 773 99
 774 OUTPUT
 775
 776 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 4 - pir calls" );
 777 .sub main :main
 778     .const 'Sub' f = "foo"
 779     print "main\n"
 780     $S0 = f()
 781     print $S0
 782 .end
 783 .sub foo
 784     .const 'Sub' b = "bar"
 785     print "foo\n"
 786     .tailcall b("from_foo\n")
 787 .end
 788 .sub bar
 789     .param string s
 790     print "bar\n"
 791     print s
 792     .return ("bar_ret\n")
 793 .end
 794 CODE
 795 main
 796 foo
 797 bar
 798 from_foo
 799 bar_ret
 800 OUTPUT
 801
 802 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - native" );
 803 .sub main :main
 804     foo_int(42, "42", 42.20)
 805     foo_float(42, "42", 42.20)
 806     foo_string(42, "42", 42.20)
 807 .end
 808 .sub foo_int
 809     get_params "0,0,0", $I0, $I1, $I2
 810     print $I0
 811     print ' '
 812     print $I1
 813     print ' '
 814     print $I2
 815     print "\n"
 816 .end
 817 .sub foo_float
 818     get_params "0,0,0", $N0, $N1, $N2
 819     print $N0
 820     print ' '
 821     print $N1
 822     print ' '
 823     print $N2
 824     print "\n"
 825 .end
 826 .sub foo_string
 827     get_params "0,0,0", $S0, $S1, $S2
 828     print $S0
 829     print ' '
 830     print $S1
 831     print ' '
 832     print $S2
 833     print "\n"
 834 .end
 835 CODE
 836 42 42 42
 837 42 42 42.2
 838 42 42 42.2
 839 OUTPUT
 840
 841 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - PIR const" );
 842 .const int MYCONST = -2
 843 .sub main :main
 844     $P0 = new 'String'
 845     "foo"(MYCONST)
 846 .end
 847 .sub "foo"
 848     .param string str1 :optional
 849     .param int has_s   :opt_flag
 850     print str1
 851     print "\n"
 852 .end
 853 CODE
 854 -2
 855 OUTPUT
 856
 857 pir_output_is( <<'CODE', <<'OUTPUT', "optional args, :opt_flag" );
 858 .sub main :main
 859     $P0 = new 'String'
 860     $P0 = "hello\n"
 861     foo($P0)
 862     foo()
 863 .end
 864 .sub foo
 865     .param pmc p1  :optional
 866     .param int i1  :opt_flag
 867
 868     if_null p1, skip
 869     print p1
 870 skip:
 871     print i1
 872     print "\n"
 873 .end
 874 CODE
 875 hello
 876 1
 877 0
 878 OUTPUT
 879
 880 pir_output_is( <<'CODE', <<'OUTPUT', "optional multiple :opt_flag" );
 881 .sub main :main
 882     $P0 = new 'String'
 883     $P0 = "ok 1\n"
 884     foo($P0, "ok 2\n", "ok 3\n")
 885 .end
 886 .sub foo
 887     .param pmc p1  :optional
 888     .param int i1  :opt_flag
 889     .param pmc p2  :optional
 890     .param int i2  :opt_flag
 891     .param pmc p3  :optional
 892     .param int i3  :opt_flag
 893     .param pmc p4  :optional
 894     .param int i4  :opt_flag
 895
 896     print p1
 897     print p2
 898     print p3
 899     if_null p4, ok
 900     print "not "
 901 ok:
 902     print "ok 4\n"
 903     print i1
 904     print ' '
 905     print i2
 906     print ' '
 907     print i3
 908     print ' '
 909     print i4
 910     print "\n"
 911 .end
 912
 913
 914 CODE
 915 ok 1
 916 ok 2
 917 ok 3
 918 ok 4
 919 1 1 1 0
 920 OUTPUT
 921
 922 pir_output_is( <<'CODE', <<'OUTPUT', "optional returns, void ret" );
 923 .sub main :main
 924     .local pmc f
 925     $I0 = 99
 926     f = get_global "foo"
 927     .begin_call
 928     .call f
 929     .get_result   $P0 :optional
 930     .get_result   $I0 :opt_flag
 931     .end_call
 932     unless $I0,  ex
 933     print "not "
 934 ex:
 935     print "ok 1\n"
 936 .end
 937 .sub foo
 938 .end
 939 CODE
 940 ok 1
 941 OUTPUT
 942
 943 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 5 - arg/param conflict" );
 944 .sub main :main
 945     .local pmc a, b
 946     a = new 'Integer'
 947     a = 1
 948     b = new 'Integer'
 949     b = 2
 950     .local pmc c, d
 951     (c, d) = foo(a, b)
 952     eq_addr a, c, ok1
 953     print "not "
 954 ok1:
 955     print "ok 1\n"
 956     eq_addr b, d, ok2
 957     print "not "
 958 ok2:
 959     print "ok 2\n"
 960 .end
 961
 962 .sub foo
 963     .param pmc a
 964     .param pmc b
 965     $P0 = new 'Integer'
 966     $P0 = 3
 967     .tailcall bar($P0, a, b)
 968 .end
 969
 970 .sub bar
 971     .param pmc x
 972     .param pmc a
 973     .param pmc b
 974     .return (a, b)
 975 .end
 976 CODE
 977 ok 1
 978 ok 2
 979 OUTPUT
 980
 981 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing" );
 982 .sub main :main
 983     .local pmc cl, o, f
 984     cl = newclass "Foo"
 985     o = new "Foo"
 986     o."bar"("ok 1\n")
 987     f = get_global ["Foo"], "bar"
 988     f(o, "ok 2\n")
 989     o."baz"("ok 3\n")
 990     f = get_global ["Foo"], "baz"
 991     f(o, "ok 4\n")
 992 .end
 993 .namespace ["Foo"]
 994 .sub bar :method
 995     .param string s
 996     print self
 997     print " "
 998     print s
 999 .end
1000 .sub baz :method
1001     .param string s
1002     print self
1003     print " "
1004     print s
1005 .end
1006 .sub get_string :vtable :method
1007     $S0 = typeof self
1008     .return ($S0)
1009 .end
1010 CODE
1011 Foo ok 1
1012 Foo ok 2
1013 Foo ok 3
1014 Foo ok 4
1015 OUTPUT
1016
1017 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing - 2" );
1018 .sub main :main
1019     .local pmc cl, o, f
1020     cl = newclass "Foo"
1021     o = new "Foo"
1022     $S0 = o
1023     print $S0
1024     $S1 = o[2]
1025     print $S1
1026     print $S0
1027 .end
1028 .namespace ["Foo"]
1029 .sub get_string :vtable :method
1030     $S0 = typeof self
1031     print $S0
1032     print " "
1033     .return ("ok 1\n")
1034 .end
1035 .sub get_string_keyed_int :vtable :method
1036     .param int key
1037     $S0 = "ok "
1038     $S1 = key
1039     $S0 .= $S1
1040     $S0 .= "\n"
1041     .return ($S0)
1042 .end
1043 CODE
1044 Foo ok 1
1045 ok 2
1046 ok 1
1047 OUTPUT
1048
1049 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing - 3" );
1050 .sub main :main
1051     .local pmc cl, o, f
1052     cl = newclass "Foo"
1053     o = new "Foo"
1054     $S0 = foo(o)
1055     print $S0
1056 .end
1057 .sub foo
1058     .param pmc arg
1059     .return (arg) # force conversion to string
1060 .end
1061 .namespace ["Foo"]
1062 .sub get_string :vtable :method
1063     $S0 = typeof self
1064     print $S0
1065     print " "
1066     .return ("ok 1\n")
1067 .end
1068
1069 CODE
1070 Foo ok 1
1071 OUTPUT
1072
1073 # see also tcl in leo-ctx5 by Coke; Date 28.08.2005
1074 pir_output_is( <<'CODE', <<'OUTPUT', "bug - :slurpy promotes to :flatten" );
1075 .sub main :main
1076     $P0 = new 'String'
1077     $P0 = "ok 1\n"
1078     $P1 = new 'String'
1079     $P1 = "ok 2\n"
1080     $P0 = foo($P0, $P1)
1081     print $P0
1082 .end
1083 .sub foo
1084     .param pmc p :slurpy
1085     .tailcall bar(p)
1086 .end
1087 .sub bar
1088     .param pmc p
1089     .local pmc q
1090     q = p[0]
1091     print q
1092     q = p[1]
1093     .return (q)
1094 .end
1095 CODE
1096 ok 1
1097 ok 2
1098 OUTPUT
1099
1100 pir_output_is( <<'CODE', <<'OUTPUT', "call :slurpy with :flat" );
1101 .sub _fn1
1102         .param pmc rest_arg :slurpy
1103         print "[in _fn1]\n"
1104         print rest_arg
1105         print "\n"
1106 .end
1107 .sub main :main
1108         $P34 = new 'Array'
1109         $P34 = 0
1110         ## normal flattening direct call, non-slurpy returns
1111         $P35 = _fn1($P34 :flat)
1112 .end
1113 CODE
1114 [in _fn1]
1115 0
1116 OUTPUT
1117
1118 pir_output_is( <<'CODE', <<'OUTPUT', "call with :flat in the middle" );
1119 .sub _fn1
1120     .param int arg1
1121     .param int arg2
1122     .param int arg3
1123     .param int arg4
1124     print arg1
1125     print ' '
1126     print arg2
1127     print ' '
1128     print arg3
1129     print ' '
1130     print arg4
1131     print "\n"
1132 .end
1133 .sub main :main
1134     $P30 = new 'Integer'
1135     $P30 = 2
1136     $P31 = new 'Integer'
1137     $P31 = 3
1138     $P34 = new 'Array'
1139     $P34 = 2
1140     $P34[0] = $P30
1141     $P34[1] = $P31
1142     $I4 = 4
1143     $P35 = _fn1(1, $P34 :flat, $I4)
1144 .end
1145 CODE
1146 1 2 3 4
1147 OUTPUT
1148
1149 pir_output_is( <<'CODE', <<'OUTPUT', "right number of args via :flat" );
1150 .sub _fn1
1151     .param int arg1
1152     .param int arg2
1153     .param int arg3
1154     .param int arg4
1155     print arg1
1156     print ' '
1157     print arg2
1158     print ' '
1159     print arg3
1160     print ' '
1161     print arg4
1162     print "\n"
1163 .end
1164 .sub main :main
1165     .include "errors.pasm"
1166     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1167     $P30 = new 'Integer'
1168     $P30 = 2
1169     $P31 = new 'Integer'
1170     $P31 = 3
1171     $P34 = new 'Array'
1172     $P34 = 3
1173     $P34[0] = $P30
1174     $P34[1] = $P31
1175     $P34[2] = $P30
1176     $P35 = _fn1(1, $P34 :flat)
1177 .end
1178 CODE
1179 1 2 3 2
1180 OUTPUT
1181
1182 pir_error_output_like( <<'CODE', <<'OUTPUT', "too many args via :flat" );
1183 .sub _fn1
1184     .param int arg1
1185     .param int arg2
1186     .param int arg3
1187     .param int arg4
1188     print arg1
1189     print ' '
1190     print arg2
1191     print ' '
1192     print arg3
1193     print ' '
1194     print arg4
1195     print "\n"
1196 .end
1197 .sub main :main
1198     .include "errors.pasm"
1199     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1200     $P30 = new 'Integer'
1201     $P30 = 2
1202     $P31 = new 'Integer'
1203     $P31 = 3
1204     $P34 = new 'Array'
1205     $P34 = 4
1206     $P34[0] = $P30
1207     $P34[1] = $P31
1208     $P34[2] = $P30
1209     $P34[3] = $P31
1210     $P35 = _fn1(1, $P34 :flat)
1211 .end
1212 CODE
1213 /too many positional arguments: 5 passed, 4 expected/
1214 OUTPUT
1215
1216 pir_error_output_like( <<'CODE', <<'OUTPUT', "too few args via :flat" );
1217 .sub _fn1
1218     .param int arg1
1219     .param int arg2
1220     .param int arg3
1221     .param int arg4
1222     print arg1
1223     print ' '
1224     print arg2
1225     print ' '
1226     print arg3
1227     print ' '
1228     print arg4
1229     print "\n"
1230 .end
1231 .sub main :main
1232     .include "errors.pasm"
1233     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1234     $P30 = new 'Integer'
1235     $P30 = 2
1236     $P31 = new 'Integer'
1237     $P31 = 3
1238     $P34 = new 'Array'
1239     $P34 = 2
1240     $P34[0] = $P30
1241     $P34[1] = $P31
1242     $P35 = _fn1(1, $P34 :flat)
1243 .end
1244 CODE
1245 /too few positional arguments: 3 passed, 4 \(or more\) expected/
1246 OUTPUT
1247
1248 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall to NCI" );
1249 .sub main :main
1250     .local pmc s
1251     s = new 'String'
1252     s = "OK 1\n"
1253     $S0 = s."lower"()
1254     print $S0
1255     s = "OK 2\n"
1256     $S1 = foo(s)
1257     print $S1
1258 .end
1259 .sub foo
1260     .param pmc s
1261     $S0 = s."lower"()
1262     .return ($S0)
1263 .end
1264 CODE
1265 ok 1
1266 ok 2
1267 OUTPUT
1268
1269 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall to NCI - 2" );
1270 .sub main :main
1271     $P0 = eval("print \"Foo!\\n\"")
1272     $P0()
1273     end
1274 .end
1275
1276 .sub eval
1277     .param string code
1278     code = ".sub main :main :anon\n" . code
1279     code = code . "\n.end\n"
1280     $P0 = compreg "PIR"
1281     .tailcall $P0(code)
1282 .end
1283 CODE
1284 Foo!
1285 OUTPUT
1286
1287 # bug - repeated calls to eval'd sub crashes (pmichaud, 2005.10.27)
1288 pir_output_is( <<'CODE', <<'OUTPUT', "repeated calls to eval'd sub" );
1289 .sub main :main
1290     .local string s
1291     .local pmc outer
1292     s =  ".namespace [ \"XYZ\" ]\n"
1293     s .= ".sub outer\n"
1294     s .= "    .param int n\n"
1295     s .= "    $I0 = n % 1000\n"
1296     s .= "    if $I0 goto end\n"
1297     s .= "    print n\n"
1298     s .= "    print \"\\n\"\n"
1299     s .= "  end:\n"
1300     s .= ".end\n"
1301     $P0 = compreg "PIR"
1302     $P0(s)
1303     outer = get_global ["XYZ"], "outer"
1304     $I1 = 0
1305   loop:
1306     inc $I1
1307     if $I1 > 10000 goto end
1308     outer($I1)
1309     goto loop
1310   end:
1311 .end
1312 CODE
1313 1000
1314 2000
1315 3000
1316 4000
1317 5000
1318 6000
1319 7000
1320 8000
1321 9000
1322 10000
1323 OUTPUT
1324
1325 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - overlapping Ix" );
1326 .sub main :main
1327     ($I0, $I1) = foo()
1328     print $I0
1329     print $I1
1330     print "\n"
1331 .end
1332 .sub foo
1333     .const 'Sub' b = "bar"
1334     $I0 = 10
1335     $I1 = 20
1336     set_args "0,0", $I1, $I0
1337     tailcall b
1338 .end
1339 .sub bar
1340     get_params "0,0", $I0, $I1
1341     .return ($I0, $I1)
1342 .end
1343 CODE
1344 2010
1345 OUTPUT
1346
1347 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - optional not set" );
1348 .sub main :main
1349     foo()
1350     print "ok\n"
1351 .end
1352 .sub foo
1353     .const 'Sub' b = "bar"
1354     .tailcall b(10, 20)
1355 .end
1356 .sub bar
1357     .param int a
1358     .param int b
1359     .param int c :optional
1360     .param int has_c :opt_flag
1361     print a
1362     print ' '
1363     print b
1364     print ' '
1365     unless has_c goto no_c
1366     print c
1367     goto got_c
1368 no_c:
1369     print 'no'
1370 got_c:
1371     print "\n"
1372 .end
1373 CODE
1374 10 20 no
1375 ok
1376 OUTPUT
1377
1378 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - optional set" );
1379 .sub main :main
1380     foo()
1381     print "ok\n"
1382 .end
1383 .sub foo
1384     .const 'Sub' b = "bar"
1385     .tailcall b(10, 20, 30)
1386 .end
1387 .sub bar
1388     .param int a
1389     .param int b
1390     .param int c :optional
1391     .param int has_c :opt_flag
1392     print a
1393     print ' '
1394     print b
1395     print ' '
1396     unless has_c goto no_c
1397     print c
1398     goto got_c
1399 no_c:
1400     print 'no'
1401 got_c:
1402     print "\n"
1403 .end
1404 CODE
1405 10 20 30
1406 ok
1407 OUTPUT
1408
1409 my @todo = ( todo => 'broken with JIT (TT #983)' )
1410     if ( defined $ENV{TEST_PROG_ARGS} and
1411         $ENV{TEST_PROG_ARGS} =~ /--runcore=jit/ );
1412 pir_output_is( <<'CODE', <<'OUTPUT', "clone_key_arg", @todo );
1413 .sub main :main
1414     foo()
1415     print "ok\n"
1416 .end
1417
1418 .sub foo
1419     .local pmc cl, o
1420     cl = newclass "MyClass"
1421     o = new "MyClass"
1422     $S0 = "key"
1423     $I0 = 3
1424     o[$S0;$I0] = 42
1425 .end
1426
1427 .namespace ["MyClass"]
1428
1429 # key arguments in register have to be expanded into their
1430 # values because in the called sub frame the original refered
1431 # registers just don't exist              #' for vim
1432
1433 .sub set_integer_keyed :vtable :method
1434     .param pmc key
1435     .param int val
1436     print key             # print first key
1437     print ' '
1438     key = shift key       # get next key
1439     print key
1440     print ' '
1441     print val
1442     print "\n"
1443 .end
1444 CODE
1445 key 3 42
1446 ok
1447 OUTPUT
1448
1449 # result_info op
1450
1451 pir_output_is( <<'CODE', <<'OUTPUT', "result_info op" );
1452 .sub main :main
1453     test()
1454     $I0 = test()
1455     ($I1, $I2, $I3) = test()
1456 .end
1457
1458 .sub test
1459     $P0 = result_info
1460     $I0 = elements $P0
1461     print $I0
1462     print "\n"
1463     .return (0)
1464 .end
1465 CODE
1466 0
1467 1
1468 3
1469 OUTPUT
1470
1471 pir_output_is( <<'CODE', <<'OUTPUT', "result_info op with eval" );
1472 .sub main :main
1473     $S0 = <<"TESTSUB"
1474 .sub test
1475     $P0 = result_info
1476     $I0 = elements $P0
1477     print $I0
1478     print "\\n"
1479 .end
1480 TESTSUB
1481     $P0 = compreg "PIR"
1482     $P1 = $P0($S0)
1483     test()
1484     $I0 = test()
1485     ($I1, $I2, $I3) = test()
1486 .end
1487 CODE
1488 0
1489 1
1490 3
1491 OUTPUT
1492
1493 pir_output_is( <<'CODE', <<'OUTPUT', ":slurpy result" );
1494 .sub main :main
1495    ($P0 :slurpy) = foo()
1496    $S0 = $P0[0]
1497    print $S0
1498    $S0 = $P0[1]
1499    print $S0
1500 .end
1501 .sub foo
1502    .return("ok 1\n", "ok 2\n")
1503 .end
1504 CODE
1505 ok 1
1506 ok 2
1507 OUTPUT
1508
1509 pir_output_is( <<'CODE', <<'OUTPUT', ":optional result" );
1510 .sub main :main
1511    ($S0 :optional, $I1 :opt_flag) = foo()
1512    unless $I1 goto no_ret
1513    print "ok 1\n"
1514    print $S0
1515    end
1516 no_ret:
1517    print "not ok 1\n"
1518 .end
1519 .sub foo
1520    .return("ok 2\n")
1521 .end
1522 CODE
1523 ok 1
1524 ok 2
1525 OUTPUT
1526
1527 pir_output_is( <<'CODE', <<'OUTPUT', ":optional result" );
1528 .sub main :main
1529    ($S0 :optional, $I1 :opt_flag) = foo()
1530    if $I1 goto has_ret
1531    print "ok 1\n"
1532    end
1533 has_ret:
1534    print "not ok 1\n"
1535 .end
1536 .sub foo
1537    .return()
1538 .end
1539 CODE
1540 ok 1
1541 OUTPUT
1542
1543 pir_output_is( <<'CODE', <<'OUTPUT', "set_args via continuation -> results" );
1544 .sub main :main
1545     .local string result
1546     result = foo("ok 1\n")
1547     print result
1548 .end
1549
1550 .sub foo
1551     .param string s
1552     .local pmc cc
1553     .include 'interpinfo.pasm'
1554     cc = interpinfo .INTERPINFO_CURRENT_CONT
1555     bar(cc, s)
1556 .end
1557
1558 .sub bar
1559     .param pmc cc
1560     .param string s
1561     print s
1562     cc("ok 2\n")
1563 .end
1564 CODE
1565 ok 1
1566 ok 2
1567 OUTPUT
1568
1569 pir_output_is( <<'CODE', <<'OUTPUT', "set_args via explicit continuation" );
1570 .sub main :main
1571     .local string result
1572     result = "not ok 2\n"
1573     .local pmc cont
1574     cont = new 'Continuation'
1575     set_addr cont, cont_dest
1576     bar(cont, "ok 1\n")
1577     print "oops\n"
1578 cont_dest:
1579     .get_results (result)
1580     print result
1581 .end
1582
1583 .sub bar
1584     .param pmc cc
1585     .param string s
1586     print s
1587     cc("ok 2\n")
1588 .end
1589 CODE
1590 ok 1
1591 ok 2
1592 OUTPUT
1593
1594 # this is a regression test for a bug in which tail-calling without set_args
1595 # used the args of the sub.
1596 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall explicit continuation, no args" );
1597 .sub main :main
1598     .local string result
1599     result = "not ok 2\n"
1600     .local pmc cont
1601     cont = new 'Continuation'
1602     set_addr cont, cont_dest
1603     bar(cont, "ok 1\n")
1604     print "oops\n"
1605 cont_dest:
1606     print "ok 2\n"
1607 .end
1608
1609 .sub bar
1610     .param pmc cc
1611     .param string s
1612     print s
1613     .tailcall cc()
1614 .end
1615 CODE
1616 ok 1
1617 ok 2
1618 OUTPUT
1619
1620 pir_output_is( <<'CODE', <<'OUTPUT', "newclosure followed by tailcall" );
1621 ## regression test for newclosure followed by tailcall, which used to recycle
1622 ## the context too soon.  it looks awful because (a) the original version was
1623 ## produced by a compiler, and (b) in order to detect regression, we must force
1624 ## parrot to reuse the context, which seems to requires having other calls that
1625 ## use particular numbers of registers (and probably a fair amount of luck).
1626 .sub _main :main
1627         ## debug 0x80
1628         .lex "MAIN-CONT", $P41
1629         $I42 = 10
1630         $P41 = new 'Continuation'
1631         set_addr $P41, L2
1632         goto L3
1633 L2:
1634         get_results '0', $P45
1635         print "got "
1636         print $P45
1637         print ".\n"
1638         .return ()
1639 L3:
1640         .const 'Sub' $P49 = "___internal_main_test_"
1641         newclosure $P48, $P49
1642         .tailcall _try_it($I42, $P48)
1643 .end
1644
1645 .sub ___internal_main_test_ :outer('_main')
1646         .param pmc arg1
1647         print "[in test]\n"
1648         find_lex $P41, "MAIN-CONT"
1649         $P55 = new "Undef"
1650         if arg1 != 3 goto L3
1651         $P58 = arg1
1652         $P59 = arg1
1653         $P57 = mul $P58, $P59
1654         set_args '(0)', $P57
1655         tailcall $P41
1656 L3:
1657         print "not "
1658         print arg1
1659         print "\n"
1660 .end
1661
1662
1663 .sub _try_it
1664         .param int n
1665         .param pmc closure
1666         $P42 = new "Undef"
1667         $P42 = 0
1668         goto L4
1669 L2:
1670         closure($P42)
1671         $P42 = $P42 + 1
1672 L4:
1673         if $P42 < n goto L2
1674 .end
1675 CODE
1676 [in test]
1677 not 0
1678 [in test]
1679 not 1
1680 [in test]
1681 not 2
1682 [in test]
1683 got 9.
1684 OUTPUT
1685
1686 pir_output_is( <<'CODE', <<'OUTPUT', "call evaled vtable code" );
1687 .sub main :main
1688     .local string s
1689     .local pmc cl, o
1690     cl = newclass "Foo"
1691     s = <<"END_PIR"
1692 .namespace ['Foo']
1693 .sub get_integer_keyed_int :vtable :method
1694     .param int i
1695     i += 5
1696     .return(i)
1697 .end
1698 END_PIR
1699     .local pmc comp
1700     comp = compreg "PIR"
1701     $P0 = comp(s)
1702     o = new 'Foo'
1703     $I0 = o[12]
1704     print $I0
1705     print "\n"
1706 .end
1707 CODE
1708 17
1709 OUTPUT
1710
1711 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 1" );
1712 .pcc_sub main:
1713     set_args "0x200, 0, 0x200, 0", "b", 10, "a", 20
1714     get_results ""
1715     find_name P1, "foo"
1716     invokecc P1
1717     print "ok\n"
1718     end
1719 .pcc_sub foo:
1720     get_params "0x200, 0, 0x200, 0", "a", I0, "b", I1
1721     print I1
1722     print ' '
1723     print I0
1724     print "\n"
1725     returncc
1726 CODE
1727 10 20
1728 ok
1729 OUTPUT
1730
1731 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 2 flatten" );
1732 .pcc_sub main:
1733     new P0, 'Hash'
1734     set P0['a'], 20
1735     set P0['b'], 10
1736     set_args "0x220", P0            # :flatten :named
1737     get_results ""
1738     find_name P1, "foo"
1739     invokecc P1
1740     print "ok\n"
1741     end
1742 .pcc_sub foo:
1743     get_params "0x200, 0, 0x200, 0", "a", I0, "b", I1
1744     print I1
1745     print ' '
1746     print I0
1747     print "\n"
1748     returncc
1749 CODE
1750 10 20
1751 ok
1752 OUTPUT
1753
1754 pir_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash PIR" );
1755 .sub main :main
1756     foo('a' => 10 , 'b' => 20, 'c' => 30)
1757     print "ok\n"
1758     end
1759 .end
1760 .sub foo
1761     .param int a :named('a')
1762     .param pmc bar :slurpy :named
1763     print a
1764     print ' '
1765     elements $I1, bar
1766     print $I1
1767     print ' '
1768     typeof $S0, bar
1769     print $S0
1770     print ' '
1771     set $I2, bar['b']
1772     print $I2
1773     print ' '
1774     set $I2, bar['c']
1775     print $I2
1776     print "\n"
1777 .end
1778
1779 CODE
1780 10 2 Hash 20 30
1781 ok
1782 OUTPUT
1783
1784 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash" );
1785 .pcc_sub main:
1786     set_args "0x200, 0, 0x200, 0,0x200, 0", "a", 10, "b", 20, 'c', 30
1787     get_results ""
1788     find_name P1, "foo"
1789     invokecc P1
1790     print "ok\n"
1791     end
1792 .pcc_sub foo:
1793     get_params "0x200, 0, 0x220", "a", I0, P0
1794     print I0
1795     print ' '
1796     elements I1, P0
1797     print I1
1798     print ' '
1799     typeof S0, P0
1800     print S0
1801     print ' '
1802     set I2, P0['b']
1803     print I2
1804     print ' '
1805     set I2, P0['c']
1806     print I2
1807     print "\n"
1808     returncc
1809
1810 CODE
1811 10 2 Hash 20 30
1812 ok
1813 OUTPUT
1814
1815 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 4 positional -> named" );
1816 .pcc_sub main:
1817     set_args  "0, 0, 0", 10, 20, 30
1818     get_results ""
1819     find_name P1, "foo"
1820     invokecc P1
1821     print "ok\n"
1822     end
1823 .pcc_sub foo:
1824     get_params "0x200, 0, 0x200, 0, 0x200, 0", "a", I0, "b", I1, 'c', I2
1825     print I0
1826     print ' '
1827     print I1
1828     print ' '
1829     print I2
1830     print "\n"
1831     returncc
1832 CODE
1833 10 20 30
1834 ok
1835 OUTPUT
1836
1837 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 5 slurpy array -> named" );
1838 .pcc_sub main:
1839     set_args  "0, 0, 0, 0x200, 0, 0x200, 0", 10, 20, 30, 'a', 40, 'b', 50
1840     get_results ""
1841     find_name P1, "foo"
1842     invokecc P1
1843     print "ok\n"
1844     end
1845 .pcc_sub foo:
1846     get_params "0, 0x20, 0x200, 0, 0x200, 0", I0, P0, "b", I1, "a", I2
1847     print I0
1848     print ' '
1849     set I0, P0[0]
1850     print I0
1851     print ' '
1852     set I0, P0[1]
1853     print I0
1854     print ' '
1855     print I1
1856     print ' '
1857     print I2
1858     print "\n"
1859     returncc
1860 CODE
1861 10 20 30 50 40
1862 ok
1863 OUTPUT
1864
1865 pir_output_is( <<'CODE', <<'OUTPUT', ":optional followed by :slurpy (empty)" );
1866 .sub main :main
1867         _write_thing(3)
1868 .end
1869 .sub _write_thing
1870         .param pmc arg1 :optional
1871         .param pmc rest_arg :slurpy
1872         print arg1
1873         print ' '
1874         print rest_arg
1875         print "\n"
1876 .end
1877 CODE
1878 3 0
1879 OUTPUT
1880
1881 pir_output_is( <<'CODE', <<'OUTPUT', ":optional followed by :slurpy (used)" );
1882 .sub main :main
1883         _write_thing(3, 4, 5)
1884 .end
1885 .sub _write_thing
1886         .param pmc arg1 :optional
1887         .param pmc rest_arg :slurpy
1888         print arg1
1889         print ' '
1890         print rest_arg
1891         print "\n"
1892 .end
1893 CODE
1894 3 2
1895 OUTPUT
1896
1897 ## Named
1898 pir_output_is( <<'CODE', <<'OUTPUT', ":named(\"...\") syntax for .param and sub call" );
1899 .sub main :main
1900         foo( 10 :named("b"), 20 :named("a"))
1901         print "ok\n"
1902         end
1903 .end
1904
1905 .sub foo
1906         .param int c :named("a")
1907         .param int d :named("b")
1908
1909         print d
1910         print ' '
1911         print c
1912         print "\n"
1913         .return()
1914 .end
1915 CODE
1916 10 20
1917 ok
1918 OUTPUT
1919
1920 ## Named
1921 pir_output_is( <<'CODE', <<'OUTPUT', ":named(\"...\") syntax for the 4 kind" );
1922 .sub main :main
1923         ($I0 :named("b"), $I1 :named("a")) = foo( 10 :named("b"), 20 :named("a"))
1924         print $I0
1925         print ' '
1926         print $I1
1927         print "\n"
1928         print "ok\n"
1929
1930         end
1931 .end
1932
1933 .sub foo
1934         .param int c :named("a")
1935         .param int d :named("b")
1936
1937         print d
1938         print ' '
1939         print c
1940         print "\n"
1941
1942         .return ( 10 :named("a"), 20 :named("b"))
1943 .end
1944 CODE
1945 10 20
1946 20 10
1947 ok
1948 OUTPUT
1949
1950 ## Named
1951 pir_output_is( <<'CODE', <<'OUTPUT', " 'foo' => 10 syntax for function call" );
1952 .sub main :main
1953         foo ('a'=>20,'b'=>10)
1954         print "ok\n"
1955
1956         end
1957 .end
1958
1959 .sub foo
1960         .param int c :named("a")
1961         .param int d :named("b")
1962
1963         print d
1964         print ' '
1965         print c
1966         print "\n"
1967
1968         .return ()
1969 .end
1970 CODE
1971 10 20
1972 ok
1973 OUTPUT
1974
1975 pir_error_output_like( <<'CODE', <<'OUTPUT', "named => pos passing" );
1976 .sub main :main
1977         foo( "b" => 10 , "a" => 20)
1978         print "never\n"
1979         end
1980 .end
1981
1982 .sub foo
1983         .param int a
1984         .param int b
1985 .end
1986 CODE
1987 /too few positional/
1988 OUTPUT
1989
1990 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - set" );
1991 .sub main :main
1992         foo ('a'=>20,'b'=>10)
1993         print "ok\n"
1994 .end
1995
1996 .sub foo
1997         .param int d :named('b')
1998         .param int c :named('a') :optional
1999         print d
2000         print ' '
2001         print c
2002         print "\n"
2003 .end
2004 CODE
2005 10 20
2006 ok
2007 OUTPUT
2008
2009 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - set, :opt_flag" );
2010 .sub main :main
2011         foo ('a'=>20,'b'=>10)
2012         print "ok\n"
2013 .end
2014
2015 .sub foo
2016         .param int d :named('b') :optional
2017         .param int has_d :opt_flag
2018         .param int c :named('a') :optional
2019         .param int has_c :opt_flag
2020         print d
2021         print ' '
2022         print has_d
2023         print ' '
2024         print c
2025         print ' '
2026         print has_c
2027         print "\n"
2028 .end
2029 CODE
2030 10 1 20 1
2031 ok
2032 OUTPUT
2033
2034 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - mix" );
2035 .sub main :main
2036         foo ('a'=>20,'b'=>10)
2037         foo ('b'=>10)
2038         foo ('a'=>20)
2039         foo ()
2040         print "ok\n"
2041 .end
2042
2043 .sub foo
2044         .param int d :named('b') :optional
2045         .param int has_d :opt_flag
2046         .param int c :named('a') :optional
2047         .param int has_c :opt_flag
2048         print d
2049         print ' '
2050         print has_d
2051         print ' '
2052         print c
2053         print ' '
2054         print has_c
2055         print "\n"
2056 .end
2057 CODE
2058 10 1 20 1
2059 10 1 0 0
2060 0 0 20 1
2061 0 0 0 0
2062 ok
2063 OUTPUT
2064
2065 pir_output_is( <<'CODE', <<'OUTPUT', "named flat/slurpy" );
2066 .sub main :main
2067         .local pmc h
2068         h = new 'Hash'
2069         h['a'] = 20
2070         h['b'] = 10
2071         foo( h :named :flat )
2072         print "ok\n"
2073         end
2074 .end
2075
2076 .sub foo
2077         .param pmc h :named :slurpy
2078         $I0 = h['a']
2079         $I1 = h['b']
2080         print $I0
2081         print ' '
2082         print $I1
2083         print "\n"
2084 .end
2085 CODE
2086 20 10
2087 ok
2088 OUTPUT
2089
2090 pir_error_output_like( <<'CODE', <<'OUTPUT', "param .. 'a' => v :named('foo')" );
2091 .sub main :main
2092         foo( "b" => 10, "a" => 20)
2093         print "never\n"
2094         end
2095 .end
2096
2097 .sub foo
2098         .param int  c :named("foo") :named("bar")
2099         .param int "b" => d
2100 .end
2101 CODE
2102 /Named parameter with more than one name/
2103 OUTPUT
2104
2105 pir_output_is( <<'CODE', <<'OUTPUT', "default value for an unused :optional" );
2106 .sub main :main
2107         print 1
2108         foo(1)
2109         foo(2)
2110         foo()
2111         print "\n"
2112 .end
2113 .sub foo
2114         .param int var :optional
2115         print var
2116 .end
2117 CODE
2118 1120
2119 OUTPUT
2120
2121 pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
2122 .sub main :main
2123     .include "errors.pasm"
2124     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2125         foo ('b'=>10)
2126         print "ok\n"
2127 .end
2128
2129 .sub foo
2130         .param int d :named('b')
2131         .param int c :named('a')
2132         print d
2133         print ' '
2134         print c
2135         print "\n"
2136 .end
2137 CODE
2138
2139 pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
2140 .sub main :main
2141     .include "errors.pasm"
2142     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2143         foo ('a'=>10)
2144         print "ok\n"
2145 .end
2146
2147 .sub foo
2148         .param int d :named('b')
2149         .param int c :named('a')
2150         print d
2151         print ' '
2152         print c
2153         print "\n"
2154 .end
2155 CODE
2156
2157 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - too many named" );
2158 .sub main :main
2159     .include "errors.pasm"
2160     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2161         foo ('a'=>10, 'b'=>20, 'c'=>30)
2162         print "ok\n"
2163 .end
2164
2165 .sub foo
2166         .param int d :named('b')
2167         .param int c :named('a')
2168         print d
2169         print ' '
2170         print c
2171         print "\n"
2172 .end
2173 CODE
2174 /too many/
2175 OUTPUT
2176
2177 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - duplicate named" );
2178 .sub main :main
2179     .include "errors.pasm"
2180     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2181         foo ('a'=>10, 'b'=>20, 'a'=>30)
2182         print "ok\n"
2183 .end
2184
2185 .sub foo
2186         .param int d :named('b')
2187         .param int c :named('a')
2188         print d
2189         print ' '
2190         print c
2191         print "\n"
2192 .end
2193 CODE
2194 /duplicate name/
2195 OUTPUT
2196
2197 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named after slurpy array" );
2198 .sub main :main
2199     foo(0, 'abc' => 1)
2200     foo('abc' => 2)
2201     $P0 = new 'ResizablePMCArray'
2202     push $P0, 1
2203     foo($P0 :flat, 'abc' => 3)
2204     $P0 = new 'ResizablePMCArray'
2205     foo($P0 :flat, 'abc' => 4)
2206 .end
2207
2208 .sub foo
2209         .param pmc array :slurpy
2210         .param pmc hash :slurpy :named
2211         print "ok "
2212         $P0 = hash['abc']
2213         print $P0
2214         print "\n"
2215 .end
2216 CODE
2217 ok 1
2218 ok 2
2219 ok 3
2220 ok 4
2221 OUTPUT
2222
2223 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named loses :flat arg (#39044)" );
2224 .sub main :main
2225     $P0 = new 'Hash'
2226     $P0['a'] = 11
2227     $P0['b'] = 22
2228     $P0['c'] = 33
2229     foo(0, 1, $P0 :flat :named)
2230 .end
2231
2232 .sub foo
2233     .param pmc array :slurpy
2234     .param pmc hash :slurpy :named
2235     $I0 = elements array
2236     print $I0
2237     print "\n"
2238     $P0 = hash['a']
2239     say $P0
2240     $P0 = hash['b']
2241     say $P0
2242     $P0 = hash['c']
2243     say $P0
2244 .end
2245 CODE
2246 2
2247 11
2248 22
2249 33
2250 OUTPUT
2251
2252 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named loses :flat arg" );
2253 .sub main :main
2254     $P0 = new 'Hash'
2255     $P0['a'] = 11
2256     $P0['b'] = 22
2257     $P0['c'] = 33
2258     foo(0, 1, 'z'=>2626, $P0 :flat :named)
2259 .end
2260
2261 .sub foo
2262     .param pmc array :slurpy
2263     .param pmc hash :slurpy :named
2264     $P0 = hash['a']
2265     say $P0
2266     $P0 = hash['b']
2267     say $P0
2268     $P0 = hash['c']
2269     say $P0
2270     $P0 = hash['z']
2271     say $P0
2272 .end
2273 CODE
2274 11
2275 22
2276 33
2277 2626
2278 OUTPUT
2279
2280 pir_error_output_like( <<'CODE', <<'OUTPUT', "unexpected positional arg" );
2281 .sub 'main'
2282     'foo'('abc', 'def', 'ghi'=>1)
2283 .end
2284
2285 .sub 'foo'
2286     .param string name
2287     .param pmc args :slurpy :named
2288 .end
2289 CODE
2290 /too many positional arguments/
2291 OUTPUT
2292
2293 pir_error_output_like( <<'CODE', <<'OUTPUT', "unexpected positional arg" );
2294 .sub 'main'
2295     'foo'('abc', 'def'=>1, 'ghi', 'jkl'=>1)
2296 .end
2297
2298 .sub 'foo'
2299     .param string name
2300     .param pmc args :slurpy :named
2301 .end
2302 CODE
2303 /named arguments must follow all positional arguments/
2304 OUTPUT
2305
2306 pir_output_is( <<'CODE', <<'OUTPUT', "flat/slurpy named arguments" );
2307 .sub 'main' :main
2308         .local pmc args
2309         args = new 'Hash'
2310         args['foo'] = 1
2311         args['bar'] = 2
2312
2313         bar_only( args :flat :named )
2314 .end
2315
2316 .sub 'bar_only'
2317         .param string bar  :named( 'bar' )
2318         .param pmc    args :named :slurpy
2319
2320         print "Have bar: "
2321         print bar
2322         print "\n"
2323 .end
2324 CODE
2325 Have bar: 2
2326 OUTPUT
2327
2328 pir_output_is(
2329     <<'CODE', <<'OUTPUT', "Tail call without arguments should not free the context when a closure depends on it" );
2330 .sub main :main
2331     $P0 = create_closure_and_run_it()
2332 .end
2333
2334 .sub create_closure_and_run_it
2335     $P0 = new "Integer"
2336     $P0 = 3
2337     .lex "val", $P0
2338     $P2 = get_global "myclosure"
2339     $P1 = newclosure $P2
2340     # There is a closure depending on our current context, so this shouldn't
2341     # free it.
2342     .tailcall $P1()
2343 .end
2344
2345 .sub myclosure :outer(create_closure_and_run_it)
2346     $P1 = find_lex "val"
2347     say $P1
2348     donothing()
2349     $P1 = find_lex "val"
2350     say $P1
2351     .return ()
2352 .end
2353
2354 .sub donothing
2355     $P0 = new "Integer"
2356     $P0 = 5
2357     # This creates a new binding that is not accessible by the
2358     # caller (myclosure)
2359     .lex "val", $P0
2360     null $P2
2361     null $P1
2362 .end
2363 CODE
2364 3
2365 3
2366 OUTPUT
2367
2368 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named after :optional" );
2369 .sub main :main
2370     foo(0, 'abc' => 1)
2371     foo('abc' => 2)
2372     $P0 = new 'ResizablePMCArray'
2373     push $P0, 1
2374     foo($P0 :flat, 'abc' => 3)
2375     $P0 = new 'ResizablePMCArray'
2376     foo($P0 :flat, 'abc' => 4)
2377     $P0 = new 'Hash'
2378     $P0['abc'] = 5
2379     foo($P0 :named :flat)
2380 .end
2381
2382 .sub foo
2383         .param pmc val     :optional
2384         .param int has_val :opt_flag
2385         .param pmc hash    :slurpy :named
2386         print "ok "
2387         $P0 = hash['abc']
2388         print $P0
2389         print "\n"
2390 .end
2391 CODE
2392 ok 1
2393 ok 2
2394 ok 3
2395 ok 4
2396 ok 5
2397 OUTPUT
2398
2399 pir_output_is( <<'CODE', <<'OUTPUT', "named optional after :optional" );
2400 .sub main :main
2401     foo()
2402     foo(1 :named('y'))
2403     $P0 = new 'Integer'
2404     $P0 = 2
2405     'foo'($P0 :named('y'))
2406 .end
2407
2408 .sub foo
2409     .param pmc x :optional
2410     .param int has_x :opt_flag
2411     .param pmc y :optional :named('y')
2412     .param int has_y :opt_flag
2413     if has_y goto have_y
2414     y = new 'Integer'
2415     y = 0
2416 have_y:
2417     say y
2418 .end
2419 CODE
2420 0
2421 1
2422 2
2423 OUTPUT
2424
2425 pir_error_output_like( <<'CODE', <<'OUTPUT', "arg mismatch with no params", todo=> 'TT #1033' );
2426 .sub main :main
2427   foo(1)
2428 .end
2429
2430 .sub foo
2431 .end
2432 CODE
2433 /too many arguments passed\(1\) - 0 params expected/
2434 OUTPUT
2435
2436 # See Rakudo queue http://rt.perl.org/rt3/Ticket/Display.html?id=62730
2437 pir_output_is( <<'CODE', <<'OUTPUT', "named from register, not constant" );
2438 .sub 'main'
2439     $S0 = 'foo'
2440     example('foo' => 42)              # normal named parameter
2441     example( $S0  => 42)              # parameter named by non-const register
2442     just_a_string( $S0, 'foo' => 42 ) # nameyness should not stick on register
2443 .end
2444
2445 .sub 'example'
2446     .param pmc foo :named('foo')
2447     say foo
2448 .end
2449
2450 .sub 'just_a_string'
2451     .param pmc bar
2452     .param int baz :named( 'foo' )
2453     say bar
2454     say baz
2455 .end
2456 CODE
2457 42
2458 42
2459 foo
2460 42
2461 OUTPUT
2462
2463 # See Rakudo queue http://rt.perl.org/rt3/Ticket/Display.html?id=62730
2464 pir_output_is( <<'CODE', <<'OUTPUT', "Handling :flat of emtpy arguments" );
2465 .sub 'main'
2466     $P0   = new ['Undef']
2467     ($P0) = foo()
2468     $S0   = typeof $P0
2469     say $S0
2470 .end
2471
2472 .sub 'foo'
2473     .param pmc arg :slurpy
2474     $S0 = typeof arg
2475     say $S0
2476     .return (arg :flat)
2477 .end
2478 CODE
2479 ResizablePMCArray
2480 Undef
2481 OUTPUT
2482
2483 pir_output_is( <<'CODE', <<'OUTPUT', "Tailcall from vtable" );
2484
2485 .sub main :main
2486 $P1 = newclass "Foo"
2487 $P2 = new "Foo"
2488
2489 ## Should return 2, but doesn't.
2490 $I1 = elements $P2
2491 $S1 = $I1
2492 say $S1
2493 .end
2494
2495 .namespace ["Foo"]
2496
2497 .sub elements :vtable
2498 $I0 = 13
2499 $I1 = 2
2500 .tailcall identity($I1)
2501 .end
2502
2503 .sub identity
2504 .param int arg
2505 .return (arg)
2506 .end
2507 CODE
2508 2
2509 OUTPUT
2510
2511 # Local Variables:
2512 #   mode: cperl
2513 #   cperl-indent-level: 4
2514 #   fill-column: 100
2515 # End:
2516 # vim: expandtab shiftwidth=4: