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