t/pmc/sub.t

   1 #! perl
   2 # Copyright (C) 2001-2008, The Perl 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 => 65;
  11 use Parrot::Config;
  12
  13 =head1 NAME
  14
  15 t/pmc/sub.t - Subroutine PMCs
  16
  17 =head1 SYNOPSIS
  18
  19     % prove t/pmc/sub.t
  20
  21 =head1 DESCRIPTION
  22
  23 Tests the creation and invocation of C<Sub>, C<Closure> and
  24 C<Continuation> PMCs.
  25
  26 =cut
  27
  28 my $temp = "temp.pasm";
  29
  30 END {
  31     unlink( $temp, 'temp.pbc', 'temp.pasm' );
  32 }
  33
  34 pasm_output_is( <<'CODE', <<'OUTPUT', "PASM subs - invokecc" );
  35     .const .Sub P0 = "func"
  36
  37     set I5, 3
  38     set_args "0", I5
  39     invokecc P0
  40     print I5
  41     print "\n"
  42     end
  43
  44 .pcc_sub func:
  45     get_params "0", I5
  46     print I5
  47     print "\n"
  48
  49     eq I5, 0, endfunc
  50     dec I5
  51
  52 .include "interpinfo.pasm"
  53     interpinfo P0, .INTERPINFO_CURRENT_SUB
  54     set_args "0", I5
  55     invokecc P0  # recursive invoke
  56
  57 endfunc:
  58     returncc
  59 CODE
  60 3
  61 2
  62 1
  63 0
  64 3
  65 OUTPUT
  66
  67 pasm_output_is( <<'CODE', <<'OUTPUT', "Continuation" );
  68     new P5, 'Integer'
  69     set P5, 3
  70     set_global "foo", P5
  71     new P1, 'Continuation'
  72     set_addr P1, endcont
  73 endcont:
  74     get_global P4, "foo"
  75     print "here "
  76     print P4
  77     print "\n"
  78     unless P4, done
  79     dec P4
  80     set_global "foo", P4
  81     print "going to cont\n"
  82     clone P0, P1
  83     invokecc P0
  84 done:
  85     print "done\n"
  86     end
  87
  88 CODE
  89 here 3
  90 going to cont
  91 here 2
  92 going to cont
  93 here 1
  94 going to cont
  95 here 0
  96 done
  97 OUTPUT
  98
  99 pasm_output_is( <<'CODE', <<'OUTPUT', "definedness of Continuation" );
 100     new P1, 'Continuation'
 101     defined I1, P1
 102     print I1
 103     print "\n"
 104     set_addr P1, cont
 105     defined I1, P1
 106     print I1
 107     print "\n"
 108     end
 109
 110 cont:
 111     print "I'm a very boring continuation"
 112     end
 113
 114 CODE
 115 0
 116 1
 117 OUTPUT
 118
 119 pasm_output_is( <<'CODE', <<'OUTPUT', "pcc sub" );
 120     get_global P0, "_the_sub"
 121     defined I0, P0
 122     if I0, ok
 123     print "not "
 124 ok:
 125     print "ok 1\n"
 126     invokecc P0
 127     print "back\n"
 128     end
 129 .pcc_sub _the_sub:
 130     print "in sub\n"
 131     returncc
 132 CODE
 133 ok 1
 134 in sub
 135 back
 136 OUTPUT
 137
 138 pasm_output_is( <<'CODE', <<'OUTPUT', "pcc sub, tail call" );
 139     get_global P0, "_the_sub"
 140     defined I0, P0
 141     if I0, ok
 142     print "not "
 143 ok:
 144     print "ok 1\n"
 145     invokecc P0
 146     print "back\n"
 147     end
 148
 149 .pcc_sub _the_sub:
 150     print "in sub\n"
 151     get_global P0, "_next_sub"
 152     get_addr I0, P0
 153     jump I0
 154     print "never here\n"
 155
 156 .pcc_sub _next_sub:
 157     print "in next sub\n"
 158     returncc
 159     print "never here\n"
 160     end
 161 CODE
 162 ok 1
 163 in sub
 164 in next sub
 165 back
 166 OUTPUT
 167
 168 pasm_output_is( <<'CODE', <<'OUTPUT', "pcc sub perl::syn::tax" );
 169     get_global P0, "_the::sub::some::where"
 170     defined I0, P0
 171     if I0, ok
 172     print "not "
 173 ok:
 174     print "ok 1\n"
 175     invokecc P0
 176     print "back\n"
 177     end
 178 .pcc_sub _the::sub::some::where:
 179     print "in sub\n"
 180     returncc
 181 CODE
 182 ok 1
 183 in sub
 184 back
 185 OUTPUT
 186
 187 open my $S, '>', "$temp" or die "Can't write $temp";
 188 print $S <<'EOF';
 189   .pcc_sub _sub1:
 190   print "in sub1\n"
 191   end
 192 EOF
 193 close $S;
 194
 195 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode call sub" );
 196 .pcc_sub _main:
 197     print "main\n"
 198     load_bytecode "temp.pasm"
 199     print "loaded\n"
 200     get_global P0, "_sub1"
 201     defined I0, P0
 202     if I0, ok1
 203     print "not "
 204 ok1:
 205     print "found sub\n"
 206     invokecc P0
 207     print "never\n"
 208     end
 209 CODE
 210 main
 211 loaded
 212 found sub
 213 in sub1
 214 OUTPUT
 215
 216 open $S, '>', "$temp" or die "Can't write $temp";
 217 print $S <<'EOF';
 218   .pcc_sub _sub1:
 219   print "in sub1\n"
 220   returncc
 221 EOF
 222 close $S;
 223
 224 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode call sub, ret" );
 225 .pcc_sub _main:
 226     print "main\n"
 227     load_bytecode "temp.pasm"
 228     print "loaded\n"
 229     get_global P0, "_sub1"
 230     defined I0, P0
 231     if I0, ok1
 232     print "not "
 233 ok1:
 234     print "found sub\n"
 235     invokecc P0
 236     print "back\n"
 237     end
 238 CODE
 239 main
 240 loaded
 241 found sub
 242 in sub1
 243 back
 244 OUTPUT
 245
 246 open $S, '>', "$temp" or die "Can't write $temp";
 247 print $S <<'EOF';
 248   .pcc_sub _sub1:
 249   print "in sub1\n"
 250   returncc
 251   .pcc_sub _sub2:
 252   print "in sub2\n"
 253   returncc
 254 EOF
 255 close $S;
 256
 257 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode call different subs, ret" );
 258 .pcc_sub _main:
 259     print "main\n"
 260     load_bytecode "temp.pasm"
 261     print "loaded\n"
 262     get_global P0, "_sub1"
 263     defined I0, P0
 264     if I0, ok1
 265     print "not "
 266 ok1:
 267     print "found sub1\n"
 268     set P10, P0
 269     invokecc P0
 270     print "back\n"
 271     get_global P0, "_sub2"
 272     defined I0, P0
 273     if I0, ok2
 274     print "not "
 275 ok2:
 276     print "found sub2\n"
 277     invokecc P0
 278     print "back\n"
 279     set P0, P10
 280     invokecc P0
 281     print "back\n"
 282     end
 283 CODE
 284 main
 285 loaded
 286 found sub1
 287 in sub1
 288 back
 289 found sub2
 290 in sub2
 291 back
 292 in sub1
 293 back
 294 OUTPUT
 295
 296 system(".$PConfig{slash}parrot$PConfig{exe} -o temp.pbc $temp");
 297
 298 pir_output_is( <<'CODE', <<'OUTPUT', "load_bytecode Sx" );
 299 .sub main :main
 300     $S0 = 'temp.pasm'
 301     load_bytecode $S0
 302     _sub1()
 303     $S0 = 'temp.pbc'
 304     load_bytecode $S0
 305     _sub2()
 306 .end
 307 CODE
 308 in sub1
 309 in sub2
 310 OUTPUT
 311
 312 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode PBC call different subs, ret" );
 313 .pcc_sub _main:
 314     print "main\n"
 315     load_bytecode "temp.pbc"
 316     print "loaded\n"
 317     get_global P0, "_sub1"
 318     defined I0, P0
 319     if I0, ok1
 320     print "not "
 321 ok1:
 322     print "found sub1\n"
 323     set P10, P0
 324     invokecc P0
 325     print "back\n"
 326     get_global P0, "_sub2"
 327     defined I0, P0
 328     if I0, ok2
 329     print "not "
 330 ok2:
 331     print "found sub2\n"
 332     invokecc P0
 333     print "back\n"
 334     set P0, P10
 335     invokecc P0
 336     print "back\n"
 337     end
 338 CODE
 339 main
 340 loaded
 341 found sub1
 342 in sub1
 343 back
 344 found sub2
 345 in sub2
 346 back
 347 in sub1
 348 back
 349 OUTPUT
 350
 351 pasm_output_is( <<'CODE', <<'OUTPUT', "equality of closures" );
 352 .pcc_sub main:
 353       .const .Sub P3 = "f1"
 354       newclosure P0, P3
 355       clone P1, P0
 356       eq P0, P1, OK1
 357       print "not "
 358 OK1:  print "ok 1\n"
 359
 360       .const .Sub P4 = "f2"
 361       newclosure P2, P4
 362       eq P0, P2, BAD2
 363       branch OK2
 364 BAD2: print "not "
 365 OK2:  print "ok 2\n"
 366       end
 367
 368 .pcc_sub :outer(main) f1:
 369       print "Test\n"
 370       end
 371
 372 .pcc_sub :outer(main) f2:
 373       new P1, 'Undef'
 374       end
 375 CODE
 376 ok 1
 377 ok 2
 378 OUTPUT
 379
 380 pasm_output_is( <<'CODE', <<'OUTPUT', "equality of subs" );
 381       .const .Sub P0 = "f1"
 382       clone P1, P0
 383       eq P0, P1, OK1
 384       print "not "
 385 OK1:  print "ok 1\n"
 386
 387       .const .Sub P2 = "f2"
 388       clone P1, P0
 389       eq P0, P2, BAD2
 390       branch OK2
 391 BAD2: print "not "
 392 OK2:  print "ok 2\n"
 393       end
 394
 395 .pcc_sub f1:
 396       print "Test\n"
 397       end
 398
 399 .pcc_sub f2:
 400       new P1, 'Undef'
 401       end
 402 CODE
 403 ok 1
 404 ok 2
 405 OUTPUT
 406
 407 pasm_output_is( <<'CODE', <<'OUT', "MAIN pragma, syntax only" );
 408 .pcc_sub :main _main:
 409     print "ok\n"
 410     end
 411 CODE
 412 ok
 413 OUT
 414
 415 open $S, '>', "$temp" or die "Can't write $temp";
 416 print $S <<'EOF';
 417   .pcc_sub :load _sub1:
 418   print "in sub1\n"
 419   returncc
 420 EOF
 421 close $S;
 422
 423 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode :load' );
 424 .pcc_sub _main:
 425     print "main\n"
 426     load_bytecode "temp.pasm"
 427     print "back\n"
 428     end
 429 CODE
 430 main
 431 in sub1
 432 back
 433 OUTPUT
 434
 435 open $S, '>', "$temp" or die "Can't write $temp";
 436 print $S <<'EOF';
 437   .pcc_sub _error:
 438   print "error\n"
 439   .pcc_sub :load _sub1:
 440   print "in sub1\n"
 441   returncc
 442 EOF
 443 close $S;
 444
 445 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode :load second sub' );
 446 .pcc_sub _main:
 447     print "main\n"
 448     load_bytecode "temp.pasm"
 449     print "back\n"
 450     end
 451 CODE
 452 main
 453 in sub1
 454 back
 455 OUTPUT
 456
 457 system(".$PConfig{slash}parrot$PConfig{exe} -o temp.pbc $temp");
 458
 459 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode :load in pbc' );
 460 .pcc_sub _main:
 461     print "main\n"
 462     load_bytecode "temp.pbc"
 463     print "back\n"
 464     end
 465 CODE
 466 main
 467 in sub1
 468 back
 469 OUTPUT
 470
 471 open $S, '>', "$temp" or die "Can't write $temp";
 472 print $S <<'EOF';
 473   .pcc_sub :load _sub1:
 474   print "in sub1\n"
 475   returncc
 476   .pcc_sub _sub2:
 477   print "in sub2\n"
 478   returncc
 479 EOF
 480 close $S;
 481
 482 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun first" );
 483 .pcc_sub _main:
 484     print "main\n"
 485     load_bytecode "temp.pasm"
 486     print "loaded\n"
 487     get_global P0, "_sub2"
 488     invokecc P0
 489     print "back\n"
 490     end
 491 CODE
 492 main
 493 in sub1
 494 loaded
 495 in sub2
 496 back
 497 OUTPUT
 498
 499 system(".$PConfig{slash}parrot$PConfig{exe} -o temp.pbc $temp");
 500
 501 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun first in pbc" );
 502 .pcc_sub _main:
 503     print "main\n"
 504     load_bytecode "temp.pbc"
 505     print "loaded\n"
 506     get_global P0, "_sub2"
 507     invokecc P0
 508     print "back\n"
 509     end
 510 CODE
 511 main
 512 in sub1
 513 loaded
 514 in sub2
 515 back
 516 OUTPUT
 517
 518 open $S, '>', "$temp" or die "Can't write $temp";
 519 print $S <<'EOF';
 520   .pcc_sub _sub1:
 521   print "in sub1\n"
 522   returncc
 523   .pcc_sub :load _sub2:
 524   print "in sub2\n"
 525   returncc
 526 EOF
 527 close $S;
 528
 529 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun second" );
 530 .pcc_sub _main:
 531     print "main\n"
 532     load_bytecode "temp.pasm"
 533     print "loaded\n"
 534     get_global P0, "_sub1"
 535     invokecc P0
 536     print "back\n"
 537     end
 538 CODE
 539 main
 540 in sub2
 541 loaded
 542 in sub1
 543 back
 544 OUTPUT
 545
 546 system(".$PConfig{slash}parrot$PConfig{exe} -o temp.pbc $temp");
 547
 548 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun second in pbc" );
 549 .pcc_sub _main:
 550     print "main\n"
 551     load_bytecode "temp.pbc"
 552     print "loaded\n"
 553     get_global P0, "_sub1"
 554     invokecc P0
 555     print "back\n"
 556     end
 557 CODE
 558 main
 559 in sub2
 560 loaded
 561 in sub1
 562 back
 563 OUTPUT
 564
 565 open $S, '>', "$temp" or die "Can't write $temp";
 566 print $S <<'EOF';
 567   .pcc_sub :load _sub1:
 568   print "in sub1\n"
 569   returncc
 570   .pcc_sub :load _sub2:
 571   print "in sub2\n"
 572   returncc
 573 EOF
 574 close $S;
 575
 576 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun both" );
 577 .pcc_sub _main:
 578     print "main\n"
 579     load_bytecode "temp.pasm"
 580     print "loaded\n"
 581     get_global P0, "_sub1"
 582     invokecc P0
 583     print "back\n"
 584     end
 585 CODE
 586 main
 587 in sub1
 588 in sub2
 589 loaded
 590 in sub1
 591 back
 592 OUTPUT
 593
 594 system(".$PConfig{slash}parrot$PConfig{exe} -o temp.pbc $temp");
 595
 596 pasm_output_is( <<'CODE', <<'OUTPUT', "load_bytecode autorun both in pbc" );
 597 .pcc_sub _main:
 598     print "main\n"
 599     load_bytecode "temp.pbc"
 600     print "loaded\n"
 601     get_global P0, "_sub1"
 602     invokecc P0
 603     print "back\n"
 604     end
 605 CODE
 606 main
 607 in sub1
 608 in sub2
 609 loaded
 610 in sub1
 611 back
 612 OUTPUT
 613
 614 pasm_output_is( <<'CODE', <<'OUTPUT', ':main pragma' );
 615 .pcc_sub _first:
 616     print "first\n"
 617     returncc
 618 .pcc_sub :main _main:
 619     print "main\n"
 620     end
 621 CODE
 622 main
 623 OUTPUT
 624
 625 pasm_output_is( <<'CODE', <<'OUTPUT', 'two :main pragmas' );
 626 .pcc_sub _first:
 627     print "first\n"
 628     returncc
 629 .pcc_sub :main _main:
 630     print "main\n"
 631     end
 632 .pcc_sub :main _second:
 633     print "second\n"
 634     returncc
 635 CODE
 636 main
 637 OUTPUT
 638
 639 pasm_output_is( <<'CODE', <<'OUTPUT', ':main pragma call subs' );
 640 .pcc_sub _first:
 641     print "first\n"
 642     returncc
 643 .pcc_sub _second:
 644     print "second\n"
 645     returncc
 646 .pcc_sub :main _main:
 647     print "main\n"
 648     get_global P0, "_first"
 649     invokecc P0
 650     get_global P0, "_second"
 651     invokecc P0
 652     end
 653 CODE
 654 main
 655 first
 656 second
 657 OUTPUT
 658
 659 pir_error_output_like( <<'CODE', <<'OUTPUT', "implicit :main with wrong # args." );
 660 .sub a
 661   .param int op1
 662   .param int op2
 663 .end
 664 CODE
 665 /too few arguments passed \(1\) - 2 params expected/
 666 OUTPUT
 667
 668 pir_error_output_like( <<'CODE', <<'OUTPUT', "explicit :main with wrong # args." );
 669 .sub a :main
 670   .param int op1
 671   .param int op2
 672 .end
 673 CODE
 674 /too few arguments passed \(1\) - 2 params expected/
 675 OUTPUT
 676
 677 $temp = "temp.pir";
 678 open $S, '>', "$temp" or die "Can't write $temp";
 679 print $S <<'EOF';
 680 .sub _sub1 :load
 681   print "in sub1\n"
 682   returncc
 683 .end
 684 EOF
 685 close $S;
 686
 687 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode :load first sub - pir' );
 688 .pcc_sub _main:
 689     print "main\n"
 690     load_bytecode "temp.pir"
 691     print "back\n"
 692     end
 693 CODE
 694 main
 695 in sub1
 696 back
 697 OUTPUT
 698
 699 open $S, '>', "$temp" or die "Can't write $temp";
 700 print $S <<'EOF';
 701 .sub _foo
 702   print "error\n"
 703 .end
 704
 705 # :load or other pragmas are only evaluated on the first
 706 # instruction of a compilation unit
 707 .sub _sub1 :load
 708   print "in sub1\n"
 709   returncc
 710 .end
 711 EOF
 712 close $S;
 713
 714 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode :load second sub - pir' );
 715 .pcc_sub _main:
 716     print "main\n"
 717     load_bytecode "temp.pir"
 718     print "back\n"
 719     end
 720 CODE
 721 main
 722 in sub1
 723 back
 724 OUTPUT
 725
 726 open $S, '>', "$temp" or die "Can't write $temp";
 727 print $S <<'EOF';
 728 .sub _foo
 729   print "error\n"
 730 .end
 731 .sub _sub1
 732   print "in sub1\n"
 733   returncc
 734 .end
 735 EOF
 736 close $S;
 737
 738 pasm_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode no :load - pir' );
 739 .pcc_sub _main:
 740     print "main\n"
 741     load_bytecode "temp.pir"
 742     print "back\n"
 743     end
 744 CODE
 745 main
 746 back
 747 OUTPUT
 748
 749 # This is the behavior of Parrot 0.4.3
 750 # RT#46817 Should there be a warning ?
 751 pir_output_is( <<'CODE', '', 'warn on in main' );
 752 .sub _main :main
 753 .include "warnings.pasm"
 754     warningson .PARROT_WARNINGS_UNDEF_FLAG
 755     _f1()
 756 .end
 757 .sub _f1
 758     $P0 = new 'Undef'
 759     print $P0
 760 .end
 761 CODE
 762
 763 pir_output_is( <<'CODE', <<'OUTPUT', "warn on in sub" );
 764 .sub _main :main
 765 .include "warnings.pasm"
 766     _f1()
 767     $P0 = new 'Undef'
 768     print $P0
 769     print "ok\n"
 770 .end
 771 .sub _f1
 772     warningson .PARROT_WARNINGS_UNDEF_FLAG
 773 .end
 774 CODE
 775 ok
 776 OUTPUT
 777
 778 # RT#46819 This is the behavior of Parrot 0.4.3
 779 # It looks like core PMCs never emit warning.
 780 # Look in perlundef.t for a more sane test of 'warningson' in subs
 781 pir_output_is( <<'CODE', <<'OUTPUT', "warn on in sub, turn off in f2" );
 782 .sub _main :main
 783 .include "warnings.pasm"
 784     _f1()
 785     $P0 = new 'Undef'
 786     print "back\n"
 787     print $P0
 788     print "ok\n"
 789 .end
 790 .sub _f1
 791     warningson .PARROT_WARNINGS_UNDEF_FLAG
 792     _f2()
 793     $P0 = new 'Undef'
 794     print $P0
 795 .end
 796 .sub _f2
 797     warningsoff .PARROT_WARNINGS_UNDEF_FLAG
 798 .end
 799 CODE
 800 back
 801 ok
 802 OUTPUT
 803
 804 pasm_output_is( <<'CODE', <<'OUTPUT', "sub names" );
 805 .pcc_sub main:
 806     .include "interpinfo.pasm"
 807     interpinfo P20, .INTERPINFO_CURRENT_SUB
 808     print P20
 809     print "\n"
 810     get_global P0, "the_sub"
 811     invokecc P0
 812     interpinfo P20, .INTERPINFO_CURRENT_SUB
 813     print P20
 814     print "\n"
 815     end
 816 .pcc_sub the_sub:
 817     interpinfo P20, .INTERPINFO_CURRENT_SUB
 818     print P20
 819     print "\n"
 820     interpinfo P1, .INTERPINFO_CURRENT_CONT
 821     returncc
 822 CODE
 823 main
 824 the_sub
 825 main
 826 OUTPUT
 827
 828 pasm_output_is( <<'CODE', <<'OUTPUT', "sub names w MAIN" );
 829 .pcc_sub dummy:
 830     print "never\n"
 831     noop
 832 .pcc_sub :main main:
 833     .include "interpinfo.pasm"
 834     interpinfo P20, .INTERPINFO_CURRENT_SUB
 835     print P20
 836     print "\n"
 837     get_global P0, "the_sub"
 838     invokecc P0
 839     interpinfo P20, .INTERPINFO_CURRENT_SUB
 840     print P20
 841     print "\n"
 842     end
 843 .pcc_sub the_sub:
 844     interpinfo P20, .INTERPINFO_CURRENT_SUB
 845     print P20
 846     print "\n"
 847     interpinfo P1, .INTERPINFO_CURRENT_CONT
 848     returncc
 849 CODE
 850 main
 851 the_sub
 852 main
 853 OUTPUT
 854
 855 pir_output_is( <<'CODE', <<'OUTPUT', "caller introspection via interp" );
 856 .sub main :main
 857 .include "interpinfo.pasm"
 858     # this test will fail when run with -Oc
 859     # as the call chain is cut down with tail calls
 860     foo()
 861
 862     $P0 = get_hll_global ["Bar"], "foo"
 863     $P0()
 864     print "ok\n"
 865 .end
 866 .sub foo
 867     print "main foo\n"
 868     $P0 = get_hll_global ["Bar"], "bar"
 869     $P0()
 870 .end
 871 .namespace ["Bar"]
 872 .sub bar
 873     print "Bar bar\n"
 874     $P1 = getinterp
 875     $P0 = $P1["sub"]
 876     print "subname: "
 877     print $P0
 878     print "\n"
 879     foo()
 880 .end
 881 .sub foo
 882     print "Bar foo\n"
 883     $P1 = getinterp
 884     $I0 = 0
 885     push_eh tb_end
 886 tb_loop:
 887     $P0 = $P1["sub"; $I0]
 888     print "caller "
 889     print $I0
 890     print " "
 891     print $P0
 892     print "\n"
 893     inc $I0
 894     goto tb_loop
 895 tb_end:
 896 .end
 897 CODE
 898 main foo
 899 Bar bar
 900 subname: bar
 901 Bar foo
 902 caller 0 foo
 903 caller 1 bar
 904 caller 2 foo
 905 caller 3 main
 906 Bar foo
 907 caller 0 foo
 908 caller 1 main
 909 ok
 910 OUTPUT
 911
 912 {
 913
 914     # the test has different output when run with --run-pbc (make testr)
 915     # actually not - compiling creates 2 'initial'
 916     #                running emts 'main'
 917
 918     my $code = <<'CODE';
 919 .sub optc :immediate :postcomp
 920     print "initial\n"
 921 .end
 922 .sub _main :main
 923     print "main\n"
 924 .end
 925 CODE
 926     my $descr = ':immediate :postcomp';
 927     if ( exists $ENV{TEST_PROG_ARGS} and $ENV{TEST_PROG_ARGS} =~ m/-r/ ) {
 928         pir_output_is( $code, <<'OUT', $descr );
 929 initial
 930 initial
 931 main
 932 OUT
 933     }
 934     else {
 935         pir_output_is( $code, <<'OUT', $descr );
 936 initial
 937 initial
 938 main
 939 OUT
 940     }
 941 }
 942
 943 pir_output_like( <<'CODE', <<'OUTPUT', ':anon' );
 944 .sub main :main
 945     "foo"()
 946     print "ok\n"
 947     $P0 = global "new"
 948     $I0 = defined $P0
 949     print $I0
 950     print "\n"
 951     $P0 = global "foo"
 952     unless null $P0 goto foo
 953     print "nofoo\n"
 954   foo:
 955 .end
 956
 957 .sub "foo" :anon
 958     print "foo\n"
 959     "new"()
 960 .end
 961
 962 .sub "new"
 963     print "new\n"
 964 .end
 965 CODE
 966 /^foo
 967 new
 968 ok
 969 1
 970 nofoo/
 971 OUTPUT
 972
 973 open $S, '>', "test_l1.pir" or die "Can't write test_l1.pir";
 974 print $S <<'EOF';
 975 .sub l11 :load
 976     print "l11\n"
 977 .end
 978
 979 .sub l12 :load
 980     print "l12\n"
 981 .end
 982 EOF
 983 close $S;
 984
 985 open $S, '>', "test_l2.pir" or die "Can't write test_l2.pir";
 986 print $S <<'EOF';
 987 .sub l21 :load
 988     print "l21\n"
 989 .end
 990
 991 .sub l22 :load
 992     print "l22\n"
 993 .end
 994 EOF
 995 close $S;
 996
 997 system(".$PConfig{slash}parrot$PConfig{exe} -o test_l1.pbc test_l1.pir");
 998 system(".$PConfig{slash}parrot$PConfig{exe} -o test_l2.pbc test_l2.pir");
 999
1000 END { unlink(qw/ test_l1.pir test_l2.pir test_l1.pbc test_l2.pbc /); }
1001
1002 pir_output_is( <<'CODE', <<'OUTPUT', 'multiple :load' );
1003 .sub main :main
1004     print "main 1\n"
1005     load_bytecode "test_l1.pir"
1006     load_bytecode "test_l2.pir"
1007     print "main 2\n"
1008     load_bytecode "test_l1.pbc" # these have to be ignored
1009     load_bytecode "test_l2.pbc"
1010     print "main 3\n"
1011 .end
1012 CODE
1013 main 1
1014 l11
1015 l12
1016 l21
1017 l22
1018 main 2
1019 main 3
1020 OUTPUT
1021
1022 pir_output_is( <<'CODE', <<'OUTPUT', "immediate code as const" );
1023 .sub make_pi :immediate :anon
1024     $N0 = atan 1.0, 1.0
1025     $N0 *= 4
1026     $P0 = new 'Float'
1027     $P0 = $N0
1028     .return ($P0)
1029 .end
1030
1031 .sub main :main
1032     .const .Sub pi = "make_pi"
1033     print pi
1034     print "\n"
1035 .end
1036 CODE
1037 3.14159
1038 OUTPUT
1039
1040 pir_output_is( <<'CODE', <<'OUTPUT', "immediate code as const - obj" );
1041 .sub make_obj :immediate :anon
1042     .local pmc cl, o
1043     cl = newclass "Foo"
1044     addattribute cl, 'x'
1045     o = new 'Foo'
1046     $P0 = new 'String'
1047     $P0 = "ok 1\n"
1048     setattribute o, 'x', $P0
1049     .return (o)
1050 .end
1051
1052 .sub main :main
1053     .const .Sub o = "make_obj"
1054     $P0 = getattribute o, 'x'
1055     print $P0
1056 .end
1057
1058 CODE
1059 ok 1
1060 OUTPUT
1061
1062 pir_output_is( <<'CODE', <<'OUTPUT', "__get_regs_used 1" );
1063 .sub main :main
1064     .local pmc m
1065     .include "interpinfo.pasm"
1066     m = interpinfo .INTERPINFO_CURRENT_SUB
1067     $I0 = m."__get_regs_used"('N')
1068     print $I0
1069     $I0 = m."__get_regs_used"('I')
1070     print $I0
1071     $I0 = m."__get_regs_used"('S')
1072     print $I0
1073     $I0 = m."__get_regs_used"('P')
1074     print $I0
1075     print "\n"
1076 .end
1077
1078 CODE
1079 0101
1080 OUTPUT
1081
1082 pir_output_is( <<'CODE', <<'OUTPUT', "__get_regs_used 2" );
1083 .sub main :main
1084     foo()
1085 .end
1086 .sub foo
1087     .local pmc m
1088     .include "interpinfo.pasm"
1089     m = interpinfo .INTERPINFO_CURRENT_SUB
1090     set N0, 1.0
1091     set N7, 1.0
1092     add N7, N7, N0
1093     set I9, 1
1094     add I10, I9, I9
1095     $I0 = m."__get_regs_used"('N')
1096     print $I0
1097     $I0 = m."__get_regs_used"('I')
1098     print $I0
1099     $I0 = m."__get_regs_used"('S')
1100     print $I0
1101     $I0 = m."__get_regs_used"('P')
1102     print $I0
1103     print "\n"
1104 .end
1105
1106
1107 CODE
1108 2301
1109 OUTPUT
1110
1111 pir_output_like(
1112     <<"CODE", <<'OUTPUT', 'warn on in main', todo => "RT#46819 core undef doesn't warn here. Should it?" );
1113 .sub 'test' :main
1114 .include "warnings.pasm"
1115     warningson .PARROT_WARNINGS_UNDEF_FLAG
1116     _f1()
1117 .end
1118 .sub _f1
1119     P0 = new 'Undef'
1120     print P0
1121 .end
1122 CODE
1123 /uninit/
1124 OUTPUT
1125
1126 pir_output_is( <<"CODE", <<'OUTPUT', 'warn on in sub' );
1127 .sub 'test' :main
1128 .include "warnings.pasm"
1129     _f1()
1130     P0 = new 'Undef'
1131     print P0
1132     print "ok\\n"
1133 .end
1134 .sub _f1
1135     warningson .PARROT_WARNINGS_UNDEF_FLAG
1136 .end
1137 CODE
1138 ok
1139 OUTPUT
1140
1141 pir_output_like(
1142     <<"CODE", <<'OUTPUT', 'warn on in sub, turn off in f2', todo => "RT#46819 core undef doesn't warn here. Should it?" );
1143 .sub 'test' :main
1144 .include "warnings.pasm"
1145     _f1()
1146     P0 = new 'Undef'
1147     print "back\\n"
1148     print P0
1149     print "ok\\n"
1150 .end
1151 .sub _f1
1152     warningson .PARROT_WARNINGS_UNDEF_FLAG
1153     _f2()
1154     P0 = new 'Undef'
1155     print P0
1156 .end
1157 .sub _f2
1158     warningsoff .PARROT_WARNINGS_UNDEF_FLAG
1159 .end
1160 CODE
1161 /uninit.*\n.*\nback\nok/
1162 OUTPUT
1163
1164 pir_output_is( <<'CODE', <<'OUTPUT', ':postcomp' );
1165 .sub main :main
1166     print "main\n"
1167 .end
1168 .sub pc :postcomp
1169     print "pc\n"
1170 .end
1171 .sub im :immediate
1172     print "im\n"
1173 .end
1174 .sub pc2 :postcomp
1175     print "pc2\n"
1176 .end
1177 .sub im2 :immediate
1178     print "im2\n"
1179 .end
1180 CODE
1181 im
1182 im2
1183 pc
1184 pc2
1185 main
1186 OUTPUT
1187
1188 # see also #38964
1189 pir_output_is( <<'CODE', <<'OUTPUT', 'unicode sub names, compilation' );
1190 .sub unicode:"\u7777"
1191    print "ok\n"
1192 .end
1193 CODE
1194 ok
1195 OUTPUT
1196
1197 pir_output_is( <<'CODE', <<'OUTPUT', 'unicode sub names, invocation' );
1198 .sub unicode:"\u7777"
1199     print "ok\n"
1200 .end
1201
1202 .sub test :main
1203     unicode:"\u7777"()
1204 .end
1205 CODE
1206 ok
1207 OUTPUT
1208
1209 pir_output_is( <<'CODE', <<'OUTPUT', 'unicode sub names, dynamic' );
1210 .sub unicode:"\u7777"
1211     print "ok\n"
1212 .end
1213
1214 .sub test :main
1215     $P1 = find_name unicode:"\u7777"
1216     $P1()
1217 .end
1218 CODE
1219 ok
1220 OUTPUT
1221
1222 pir_output_is( <<'CODE', <<'OUTPUT', 'unicode sub names' );
1223 .sub unicode:"\u7777"
1224     print "ok\n"
1225 .end
1226
1227 .sub test :main
1228     # unicode:"\u7777" ends up as a string nicode:"\u7777
1229     # (or it did, in r12860)
1230     $P1 = find_name 'nicode:"\u7777'
1231     unless null $P1 goto bad
1232     print "not found\n"
1233   bad:
1234 .end
1235 CODE
1236 not found
1237 OUTPUT
1238
1239 pir_output_is( <<'CODE', <<'OUTPUT', 'unicode sub constant' );
1240 .sub main :main
1241     .const .Sub s = unicode:"\u7777"
1242     s()
1243 .end
1244
1245 .sub unicode:"\u7777"
1246    print "ok\n"
1247 .end
1248 CODE
1249 ok
1250 OUTPUT
1251
1252 pir_output_is( <<'CODE', <<'OUTPUT', 'literal \u in sub name (not unicode)' );
1253 .sub '\u2193'
1254     say 'ok'
1255 .end
1256 CODE
1257 ok
1258 OUTPUT
1259
1260 pir_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode with .pir (RT #39807)' );
1261 .sub main :main
1262     load_bytecode 'PGE.pbc'
1263     load_bytecode 'dumper.pir'
1264     load_bytecode 'PGE/Dumper.pir'
1265
1266     $P0 = compreg 'PGE::P5Regex'
1267     $P1 = $P0('aabb*')
1268     $P2 = $P1('fooaabbbar')
1269
1270     _dumper($P2)
1271 .end
1272 CODE
1273 "VAR1" => PMC 'PGE::Match' => "aabbb" @ 3
1274 OUTPUT
1275
1276 pir_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode with .pbc (RT #39807)' );
1277 .sub main :main
1278     load_bytecode 'PGE.pbc'
1279     load_bytecode 'dumper.pbc'
1280     load_bytecode 'PGE/Dumper.pbc'
1281
1282     $P0 = compreg 'PGE::P5Regex'
1283     $P1 = $P0('aabb*')
1284     $P2 = $P1('fooaabbbar')
1285
1286     _dumper($P2)
1287 .end
1288 CODE
1289 "VAR1" => PMC 'PGE::Match' => "aabbb" @ 3
1290 OUTPUT
1291
1292 pir_error_output_like( <<'CODE', qr/Null PMC access in invoke()/, 'invoking null pmc' );
1293 .sub main :main
1294     null $P0
1295     $P0()
1296 .end
1297 CODE
1298
1299 pir_output_is( <<'CODE', <<'OUTPUT', ":init" );
1300 .sub a :init
1301     print "in inited\n"
1302 .end
1303
1304 .sub main :main
1305     print "main\n"
1306 .end
1307 CODE
1308 in inited
1309 main
1310 OUTPUT
1311
1312 pir_output_is( <<'CODE', <<'OUTPUT', 'assign' );
1313 .sub main :main
1314     $P0 = get_global 'ok'
1315
1316     $P1 = new 'Undef'
1317     assign $P1, $P0
1318
1319     $P1()
1320 .end
1321
1322 .sub ok
1323     say "ok"
1324 .end
1325 CODE
1326 ok
1327 OUTPUT
1328
1329 pir_output_is( <<'CODE', <<'OUTPUT', 'assign w/:outer' );
1330 .sub main :main
1331     $P0 = get_global 'ok'
1332
1333     $P1 = new 'Undef'
1334     assign $P1, $P0
1335
1336     $P1()
1337 .end
1338
1339 .sub ok :outer('main')
1340     say "ok"
1341 .end
1342 CODE
1343 ok
1344 OUTPUT
1345
1346 pir_output_is( <<'CODE', <<'OUTPUT', 'get_namespace()' );
1347 .sub main :main
1348     $P0 = get_global 'main'
1349     $P0 = $P0.'get_namespace'()
1350     $P0 = $P0.'get_name'()
1351     $S0 = join ';', $P0
1352     say $S0
1353
1354     $P0 = get_global ['Foo'; 'Bar'], 'foo'
1355     $P0 = $P0.'get_namespace'()
1356     $P0 = $P0.'get_name'()
1357     $S0 = join ';', $P0
1358     say $S0
1359 .end
1360
1361 .namespace ['Foo'; 'Bar']
1362 .sub foo
1363     noop
1364 .end
1365 CODE
1366 parrot
1367 parrot;Foo;Bar
1368 OUTPUT
1369
1370 pir_output_is( <<'CODE', <<'OUTPUT', 'arity()' );
1371 .sub main :main
1372     $P0 = get_global 'none'
1373     $I0 = $P0.arity()
1374     say $I0
1375
1376     $P0 = get_global 'one'
1377     $I0 = $P0.arity()
1378     say $I0
1379
1380     $P0 = get_global 'four'
1381     $I0 = $P0.arity()
1382     say $I0
1383
1384     $P0 = get_global 'all_slurpy'
1385     $I0 = $P0.arity()
1386     say $I0
1387
1388     $P0 = get_global 'some_optional'
1389     $I0 = $P0.arity()
1390     say $I0
1391
1392     $P0 = get_global 'some_named'
1393     $I0 = $P0.arity()
1394     say $I0
1395
1396     $P0 = get_global 'allsorts'
1397     $I0 = $P0.arity()
1398     say $I0
1399 .end
1400
1401 .sub none
1402 .end
1403
1404 .sub one
1405     .param int a
1406 .end
1407
1408 .sub four
1409     .param int a
1410     .param pmc b
1411     .param string c
1412     .param num d
1413 .end
1414
1415 .sub all_slurpy
1416     .param pmc s :slurpy
1417 .end
1418
1419 .sub some_optional
1420     .param int a
1421     .param int b :optional
1422     .param int bo :opt_flag
1423     .param int c
1424 .end
1425
1426 .sub some_named
1427     .param int a :named
1428     .param int b
1429     .param int c :named
1430 .end
1431
1432 .sub allsorts
1433     .param int a :named
1434     .param int b :optional
1435     .param int bo :opt_flag
1436     .param int c
1437     .param pmc s :slurpy
1438 .end
1439 CODE
1440 0
1441 1
1442 4
1443 0
1444 2
1445 3
1446 2
1447 OUTPUT
1448
1449 pir_output_is( <<'CODE', <<'OUTPUT', 'set_outer' );
1450 .sub main :main
1451     $P0 = find_global "example_outer"
1452     $P1 = find_global "example_inner"
1453     $P1.set_outer($P0)
1454     $P0()
1455     $P1()
1456 .end
1457
1458 .sub example_outer
1459     .lex "Foo", $P0
1460     $P0 = new 'String'
1461     $P0 = 'I can has outer?'
1462 .end
1463
1464 .sub example_inner
1465     $P0 = find_lex "Foo"
1466     say $P0
1467 .end
1468 CODE
1469 I can has outer?
1470 OUTPUT
1471
1472 pir_output_is( <<'CODE', <<'OUTPUT', ':outer with identical sub names' );
1473 .sub 'main' :main
1474     $P0 = get_hll_global ['ABC'], 'outer'
1475     $P0('ABC lex')
1476
1477     $P0 = get_hll_global ['DEF'], 'outer'
1478     $P0('DEF lex')
1479 .end
1480
1481 .namespace ['ABC']
1482 .sub 'outer' :lexid('abc_outer')
1483     .param pmc x
1484     .lex '$abc', x
1485     say 'ABC::outer'
1486     'inner'()
1487 .end
1488
1489 .sub 'inner' :outer('abc_outer')
1490     say 'ABC::inner'
1491     $P0 = find_lex '$abc'
1492     say $P0
1493 .end
1494
1495 .namespace ['DEF']
1496 .sub 'outer' :lexid('def_outer')
1497     .param pmc x
1498     .lex '$def', x
1499     say 'DEF::outer'
1500     'inner'()
1501 .end
1502
1503 .sub 'inner' :outer('def_outer')
1504     say 'DEF::inner'
1505     $P0 = find_lex '$def'
1506     say $P0
1507 .end
1508 CODE
1509 ABC::outer
1510 ABC::inner
1511 ABC lex
1512 DEF::outer
1513 DEF::inner
1514 DEF lex
1515 OUTPUT
1516
1517 pir_output_is( <<'CODE', <<'OUTPUT', ':lexid and identical string constants' );
1518 .sub 'main'
1519     'foo'()
1520     'bar'()
1521 .end
1522
1523 .sub 'foo'
1524     new $P0, "String"
1525     assign $P0, "abc"
1526     say $P0
1527 .end
1528
1529 .sub 'bar'  :lexid("abc")
1530     new $P0, "String"
1531     assign $P0, "abc"
1532     say $P0
1533 .end
1534 CODE
1535 abc
1536 abc
1537 OUTPUT
1538
1539 # Local Variables:
1540 #   mode: cperl
1541 #   cperl-indent-level: 4
1542 #   fill-column: 100
1543 # End:
1544 # vim: expandtab shiftwidth=4: