t/op/lexicals.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 => 47;
  11
  12 =head1 NAME
  13
  14 t/op/lexicals.t - Lexical Ops
  15
  16 =head1 SYNOPSIS
  17
  18     % prove t/op/lexicals.t
  19
  20 =head1 DESCRIPTION
  21
  22 Tests various lexical scratchpad operations, as described in PDD20.
  23
  24 =cut
  25
  26 pasm_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PASM (\'$a\') succeeds' );
  27 .pcc_sub main:
  28     .lex "$a", P0
  29     print "ok\n"
  30     end
  31 CODE
  32 ok
  33 OUTPUT
  34
  35 pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR' );
  36 .sub main
  37     .lex "$a", P0
  38     print "ok\n"
  39 .end
  40 CODE
  41 ok
  42 OUTPUT
  43
  44 pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR, $P' );
  45 .sub main :main
  46     .lex '$a', $P0
  47     null $P0
  48     print "ok\n"
  49 .end
  50 CODE
  51 ok
  52 OUTPUT
  53
  54 pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR, local var' );
  55 .sub main :main
  56     .local pmc a
  57     .lex "$a", a
  58     print "ok\n"
  59 .end
  60 CODE
  61 ok
  62 OUTPUT
  63
  64 pasm_output_is( <<'CODE', <<'OUTPUT', '.lex - same PMC twice (PASM)' );
  65 .pcc_sub main:
  66     .lex '$a', P0
  67     .lex '$b', P0
  68     new P0, 'String'
  69     set P0, "ok\n"
  70     find_lex P1, '$a'
  71     print P1
  72     find_lex P2, '$a'
  73     print P2
  74     end
  75 CODE
  76 ok
  77 ok
  78 OUTPUT
  79
  80 pir_output_is( <<'CODE', <<'OUTPUT', '.lex - same PMC twice fails (.local pmc ab)' );
  81 .sub main :main
  82     .local pmc ab, a, b
  83     .lex '$a', ab
  84     .lex '$b', ab
  85     ab = new 'String'
  86     ab = "ok\n"
  87     a = find_lex '$a'
  88     print a
  89     b = find_lex '$b'
  90     print b
  91 .end
  92 CODE
  93 ok
  94 ok
  95 OUTPUT
  96
  97 pir_output_is( <<'CODE', <<'OUTPUT', '.lex - same lex twice' );
  98 .sub main
  99  .lex '$a', $P0
 100  .lex '$a', $P1
 101  say "ok"
 102 .end
 103 CODE
 104 ok
 105 OUTPUT
 106
 107 pir_output_is( <<'CODE', <<'OUTPUT', 'api parsing' );
 108 .sub main :main
 109     .lex 'a', $P0
 110     store_lex 'a', $P0
 111     $P0 = find_lex 'a'
 112     print "ok\n"
 113 .include 'interpinfo.pasm'
 114     load_bytecode "pcore.pir"      # TODO autoload/preload
 115     interpinfo $P1, .INTERPINFO_CURRENT_SUB
 116     $P2 = $P1.'get_lexinfo'()
 117     $P2 = $P1.'get_lexenv'()
 118     print "ok\n"
 119 .end
 120 CODE
 121 ok
 122 ok
 123 OUTPUT
 124
 125 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo' );
 126 .sub main :main
 127     .lex '$a', $P0
 128     .lex '$b', $P9
 129 .include "interpinfo.pasm"
 130     interpinfo $P1, .INTERPINFO_CURRENT_SUB
 131     $P2 = $P1.'get_lexinfo'()
 132     $S0 = typeof $P2
 133     print $S0
 134     print ' '
 135     $I0 = elements $P2
 136     say $I0
 137 .end
 138 CODE
 139 LexInfo 2
 140 OUTPUT
 141
 142 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo - no lexicals' );
 143 .sub main :main
 144 .include "interpinfo.pasm"
 145     interpinfo $P1, .INTERPINFO_CURRENT_SUB
 146     $P2 = $P1.'get_lexinfo'()
 147     if null $P2 goto ok
 148     print "LexInfo not NULL\n"
 149     end
 150 ok:
 151     print "ok\n"
 152 .end
 153 CODE
 154 ok
 155 OUTPUT
 156
 157 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - no pad' );
 158 .sub main :main
 159     .local pmc pad, interp
 160     interp = getinterp
 161     pad = interp["lexpad"]
 162     if null pad goto ok
 163     print "pad not NULL\n"
 164     end
 165 ok:
 166     print "ok\n"
 167     end
 168 .end
 169 CODE
 170 ok
 171 OUTPUT
 172
 173 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - no pad inherited in coro' );
 174 .sub main
 175      coro()
 176 .end
 177 .sub coro
 178     .local pmc pad, interp
 179     interp = getinterp
 180     pad = interp["lexpad"]
 181     if null pad goto ok
 182     print "pad not NULL\n"
 183     .yield()
 184 ok:
 185     print "ok\n"
 186     .yield()
 187 .end
 188 CODE
 189 ok
 190 OUTPUT
 191
 192 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - set var via pad' );
 193 .sub main
 194     .local pmc pad, interp
 195     interp = getinterp
 196     pad = interp["lexpad"]
 197     .lex '$a', P0
 198     unless null pad goto ok
 199     print "pad is NULL\n"
 200     end
 201 ok:
 202     print "ok\n"
 203     P1 = new 'Integer'
 204     P1 = 13013
 205     pad['$a'] = P1
 206     print P0
 207     print "\n"
 208     end
 209 .end
 210 CODE
 211 ok
 212 13013
 213 OUTPUT
 214
 215 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - set two vars via pad (2 lex -> 2 pmc)' );
 216 .sub main
 217     .lex '$a', P0
 218     .lex '$b', P2
 219     .local pmc pad, interp
 220     interp = getinterp
 221     pad = interp["lexpad"]
 222     .local pmc pad
 223     unless null pad goto ok
 224     print "pad is NULL\n"
 225     end
 226 ok:
 227     print "ok\n"
 228     P1 = new 'Integer'
 229     P1 = 13013
 230     pad['$a'] = P1
 231     print P0
 232     print "\n"
 233     P1 = 42
 234     pad['$b'] = P1
 235     print P2
 236     print "\n"
 237     end
 238 .end
 239 CODE
 240 ok
 241 13013
 242 42
 243 OUTPUT
 244
 245 pir_output_is( <<'CODE', <<'OUTPUT', 'synopsis example' );
 246 .sub main
 247     .lex '$a', P0
 248     P1 = new 'Integer'
 249     P1 = 13013
 250     store_lex '$a', P1
 251     print P0
 252     print "\n"
 253     end
 254 .end
 255 CODE
 256 13013
 257 OUTPUT
 258
 259 pasm_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - PASM' );
 260 .pcc_sub main:
 261     print "ok\n"
 262     end
 263 .pcc_sub :lex foo:
 264     returncc
 265 CODE
 266 ok
 267 OUTPUT
 268
 269 pir_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - PIR' );
 270 .sub main
 271     print "ok\n"
 272 .end
 273 .sub foo :lex
 274 .end
 275 CODE
 276 ok
 277 OUTPUT
 278
 279 pasm_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - PASM' );
 280 .pcc_sub main:
 281     print "ok\n"
 282     end
 283 .pcc_sub :outer('main') foo:
 284     returncc
 285 CODE
 286 ok
 287 OUTPUT
 288
 289 pir_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - PIR' );
 290 .sub main
 291     print "ok\n"
 292 .end
 293 .sub foo :outer('main')
 294 .end
 295 CODE
 296 ok
 297 OUTPUT
 298
 299 pir_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - ident' );
 300 .sub main
 301     .local pmc a
 302     .lex "$a", a
 303     print "ok\n"
 304     end
 305 .end
 306 .sub foo :outer(main)
 307 .end
 308 CODE
 309 ok
 310 OUTPUT
 311
 312 pir_error_output_like( <<'CODE', <<'OUTPUT', ':outer parsing - missing :outer' );
 313 .sub main
 314     print "ok\n"
 315 .end
 316 .sub foo :outer(oops)
 317 .end
 318 CODE
 319 /Undefined :outer sub 'oops'\./
 320 OUTPUT
 321
 322 pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo from pad' );
 323 .sub main
 324     .lex '$a', P0
 325     .local pmc pad, interp, info
 326     interp = getinterp
 327     pad = interp["lexpad"]
 328     unless null pad goto ok
 329     print "pad is NULL\n"
 330     end
 331 ok:
 332     print "ok\n"
 333     info = pad.'get_lexinfo'()
 334     typeof $S0, info
 335     print $S0
 336     print "\n"
 337     end
 338 .end
 339 CODE
 340 ok
 341 LexInfo
 342 OUTPUT
 343
 344 pir_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - verify info and pad' );
 345 .sub main
 346     foo()
 347     print "ok\n"
 348 .end
 349 .sub foo :lex
 350     .local pmc pad, interp, info
 351     interp = getinterp
 352     pad = interp["lexpad"]
 353     unless null pad goto ok
 354     print "pad is NULL\n"
 355     end
 356 ok:
 357     print "ok\n"
 358     typeof $S0, pad
 359     print $S0
 360     print "\n"
 361     info = pad.'get_lexinfo'()
 362     typeof $S0, info
 363     print $S0
 364     print "\n"
 365 .end
 366 CODE
 367 ok
 368 LexPad
 369 LexInfo
 370 ok
 371 OUTPUT
 372
 373 pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer' );
 374 .sub "main"
 375     foo()
 376 .end
 377 .sub foo :outer('main')
 378     .include "interpinfo.pasm"
 379     interpinfo $P1, .INTERPINFO_CURRENT_SUB
 380     $P2 = $P1."get_outer"()
 381     print $P2
 382     print "\n"
 383 .end
 384 CODE
 385 main
 386 OUTPUT
 387
 388 pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer 2' );
 389 .sub "main"
 390     foo()
 391 .end
 392 .sub foo  :outer('main')
 393     bar()
 394 .end
 395 .sub bar   :outer('foo')
 396     .include "interpinfo.pasm"
 397     interpinfo $P1, .INTERPINFO_CURRENT_SUB
 398     $P2 = $P1."get_outer"()
 399     print $P2
 400     print "\n"
 401     $P3 = $P2."get_outer"()
 402     print $P3
 403     print "\n"
 404 .end
 405 CODE
 406 foo
 407 main
 408 OUTPUT
 409
 410 pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer via interp' );
 411 .sub "main"
 412     .const .Sub foo = "foo"
 413     .local pmc foo_cl
 414     .lex "a", $P0
 415     foo_cl = newclosure foo
 416     foo_cl()
 417     print $P0
 418 .end
 419 .sub foo  :outer('main')
 420     .const .Sub bar = "bar"
 421     .local pmc bar_cl
 422     bar_cl = newclosure bar
 423     bar_cl()
 424 .end
 425 .sub bar   :outer('foo')
 426     .local pmc sub, interp, pad
 427     interp = getinterp
 428     sub = interp["outer"]
 429     print sub
 430     print "\n"
 431     sub = interp["outer"; "sub"]
 432     print sub
 433     print "\n"
 434     sub = interp["outer"; 2]
 435     print sub
 436     print "\n"
 437     sub = interp["outer"; "sub"; 2]
 438     print sub
 439     print "\n"
 440     $P0 = new 'String'
 441     $P0 = "I messed with your var\n"
 442     pad = interp["outer"; "lexpad"; 2]
 443     pad['a'] = $P0
 444 .end
 445 CODE
 446 foo
 447 foo
 448 main
 449 main
 450 I messed with your var
 451 OUTPUT
 452
 453 pir_output_is( <<'CODE', <<'OUTPUT', 'closure 3' );
 454 # sub foo {
 455 #     my ($n) = @_;
 456 #     sub {$n += shift}
 457 # }
 458 # my $f = foo(5);
 459 # print &$f(3), "\n";
 460 # my $g = foo(20);
 461 # print &$g(3), "\n";
 462 # print &$f(3), "\n";
 463 # print &$g(4), "\n";
 464
 465 .sub foo
 466     .param pmc arg
 467     .local pmc n
 468     .lex '$n', n
 469     n = arg
 470     .const .Sub anon = "anon"
 471     $P0 = newclosure anon
 472     .return ($P0)
 473 .end
 474
 475 .sub anon :outer(foo)
 476     .param pmc arg
 477     $P0 = find_lex '$n'
 478     # in practice we need copying the arg but as it is passed
 479     # as native int, we already have a fresh pmc
 480     $P0 += arg
 481     .return ($P0)
 482 .end
 483
 484 .sub main :main
 485     .local pmc f, g
 486     .lex '$f', f
 487     .lex '$g', g
 488     f = foo(5)
 489     $P0 = f(3)
 490     print $P0
 491     print "\n"
 492     g = foo(20)
 493     $P0 = g(3)
 494     print $P0
 495     print "\n"
 496     $P0 = f(3)
 497     print $P0
 498     print "\n"
 499     $P0 = g(4)
 500     print $P0
 501     print "\n"
 502 .end
 503 CODE
 504 8
 505 23
 506 11
 507 27
 508 OUTPUT
 509
 510 pir_output_is( <<'CODE', <<'OUTPUT', 'closure 4' );
 511 # code by Piers Cawley
 512 =pod
 513
 514   ;;; Indicate that the computation has failed, and that the program
 515   ;;; should try another path.  We rebind this variable as needed.
 516   (define fail
 517     (lambda () (error "Program failed")))
 518
 519   ;;; Choose an arbitrary value and return it, with backtracking.
 520   ;;; You are not expected to understand this.
 521   (define (choose . all-choices)
 522     (let ((old-fail fail))
 523       (call-with-current-continuation
 524        (lambda (continuation)
 525          (define (try choices)
 526            (if (null? choices)
 527                (begin
 528                  (set! fail old-fail)
 529                  (fail))
 530                (begin
 531                  (set! fail
 532                       (lambda () (continuation (try (cdr choices)))))
 533                  (car choices))))
 534          (try all-choices)))))
 535
 536   ;;; Find two numbers with a product of 15.
 537   (let ((x (choose 1 3 5))
 538         (y (choose 1 5 9)))
 539     (for-each display `("Trying " ,x " and " ,y #\newline))
 540     (unless (= (* x y) 15)
 541       (fail))
 542     (for-each display `("Found " ,x " * " ,y " = 15" #\newline)))
 543
 544 =cut
 545
 546 .sub main :main
 547      .local pmc fail, arr1, arr2, x, y, choose
 548      .lex 'fail', fail
 549      .lex 'arr1', arr1
 550      .lex 'arr2', arr2
 551      .lex 'x', x
 552      .lex 'y', y
 553      .lex 'choose', choose
 554      .const .Sub choose_sub = "_choose"
 555      .const .Sub fail_sub = "_fail"
 556      fail = newclosure fail_sub
 557      arr1 = new 'ResizablePMCArray'
 558      arr1[0] = 1
 559      arr1[1] = 3
 560      arr1[2] = 5
 561      arr2 = new 'ResizablePMCArray'
 562      arr2[0] = 1
 563      arr2[1] = 5
 564      arr2[2] = 9
 565
 566      choose = newclosure choose_sub
 567      x = choose(arr1)
 568      #print "Chosen "
 569      #print x
 570      #print " from arr1\n"
 571
 572      # need to create a new closure: these closures have different state
 573      choose = newclosure choose_sub
 574      y = choose(arr2)
 575      #print "Chosen "
 576      #print y
 577      #print " from arr2\n"
 578      $I1 = x
 579      $I2 = y
 580      $I0 = $I1 * $I2
 581      if $I0 == 15 goto success
 582      fail()
 583      print "Shouldn't get here without a failure report\n"
 584      branch the_end
 585 success:
 586      print x
 587      print " * "
 588      print y
 589      print " == 15!\n"
 590 the_end:
 591      end
 592 .end
 593
 594 .sub _choose :outer(main)
 595      .param pmc choices
 596
 597      .local pmc our_try, old_fail, cc, try
 598      .lex 'old_fail', old_fail
 599      .lex 'cc', cc
 600      .lex 'try', try
 601      #print "In choose\n"
 602      old_fail = find_lex "fail"
 603      .include "interpinfo.pasm"
 604      $P1 = interpinfo .INTERPINFO_CURRENT_CONT
 605      store_lex  "cc", $P1
 606      .const .Sub tr_sub = "_try"
 607      newclosure our_try, tr_sub
 608      store_lex "try", our_try
 609      $P2 = our_try(choices)
 610      .return($P2)
 611 .end
 612
 613 .sub _try :outer(_choose)
 614      .param pmc choices
 615
 616      .lex 'choices', $P0
 617      #print "In try\n"
 618      clone $P0, choices
 619      if choices goto have_choices
 620      $P1 = find_lex "old_fail"
 621      store_lex "fail", $P1
 622      $P1()
 623 have_choices:
 624      .const .Sub f = "new_fail"
 625      newclosure $P2, f
 626      store_lex "fail", $P2
 627      $P3 = find_lex "choices"
 628      shift $P4, $P3
 629
 630      .return($P4)
 631 .end
 632
 633 .sub new_fail :outer(_try)
 634      .local pmc our_try
 635      .local pmc our_cc
 636      #print "In new_fail\n"
 637      our_cc = find_lex "cc"
 638      our_try = find_lex "try"
 639      $P2 = find_lex "choices"
 640      $P3 = our_try($P2)
 641      our_cc($P3)
 642 .end
 643
 644 .sub _fail :outer(main)
 645      print "Program failed\n"
 646 .end
 647 CODE
 648 3 * 5 == 15!
 649 OUTPUT
 650
 651 pir_output_is( <<'CODE', <<'OUTPUT', 'closure 5' );
 652 # FIXME - we need to detect the destruction of the P registers
 653 # associated with the Contexts for the calls of xyzzy and plugh.
 654 # Otherwise, this test is just a repeat of others
 655
 656 .sub main :main
 657     .local pmc f
 658     f = xyzzy()
 659     f()
 660     f()
 661     f()
 662 .end
 663
 664 .sub xyzzy
 665     $P1 = plugh()
 666     .return ($P1)
 667 .end
 668
 669 .sub plugh
 670     $P1 = foo()
 671     .return ($P1)
 672 .end
 673
 674 .sub foo
 675     .lex 'a', $P0
 676     $P0 = new 'Integer'
 677     $P0 = 0
 678
 679     .const .Sub bar_sub = "bar"
 680     $P1 = newclosure bar_sub
 681     .return ($P1)
 682 .end
 683
 684 .sub bar :anon :outer(foo)
 685     $P0 = find_lex 'a'
 686     inc $P0
 687     print "bar: "
 688     print $P0
 689     print "\n"
 690 .end
 691 CODE
 692 bar: 1
 693 bar: 2
 694 bar: 3
 695 OUTPUT
 696
 697 pir_output_is( <<'CODE', <<'OUTPUT', 'closure 6' );
 698 # Leo's version of xyzzy original by particle, p5 by chip     #'
 699
 700 .sub main :main
 701     .local pmc f,g
 702     f = xyzzy(42)
 703     $P0 = f()
 704     $P0 = f()
 705     $P0 = f()
 706     g = xyzzy(13013)
 707     $P0 = g()
 708     $P0 = f()
 709 .end
 710
 711 .sub xyzzy
 712     .param int i
 713     .local pmc f
 714     f = plugh(i)
 715     .return (f)
 716 .end
 717
 718 .sub plugh
 719     .param int i
 720     .local pmc f
 721     f = foo(i)
 722     .return (f)
 723 .end
 724
 725 .sub foo
 726     .param int i
 727     .lex 'a', $P0
 728     $P1 = new 'Integer'
 729     $P1 = i
 730     store_lex 'a', $P1
 731     print "foo: "
 732     print $P0
 733     print "\n"
 734     .const .Sub closure = 'bar'
 735     $P2 = newclosure closure
 736     .return($P2)
 737 .end
 738
 739 .sub bar :anon :outer(foo)
 740     $P0 = find_lex 'a'
 741     inc $P0
 742     store_lex 'a', $P0
 743     print "bar: "
 744     print $P0
 745     print "\n"
 746 .end
 747 CODE
 748 foo: 42
 749 bar: 43
 750 bar: 44
 751 bar: 45
 752 foo: 13013
 753 bar: 13014
 754 bar: 46
 755 OUTPUT
 756
 757 pir_output_is( <<'CODE', <<'OUTPUT', 'closure 7 - evaled' );
 758 .sub main :main
 759     .local pmc f,g
 760     f = xyzzy(42)
 761     $P0 = f()
 762     $P0 = f()
 763     $P0 = f()
 764     g = xyzzy(13013)
 765     $P0 = g()
 766     $P0 = f()
 767 .end
 768
 769 .sub xyzzy
 770     .param int i
 771     .local pmc f
 772     f = plugh(i)
 773     .return (f)
 774 .end
 775
 776 .sub plugh
 777     .param int i
 778     .local pmc f
 779     f = foo(i)
 780     .return (f)
 781 .end
 782
 783 .sub foo
 784     .param int i
 785     .lex 'a', $P0
 786     $P1 = new 'Integer'
 787     $P1 = i
 788     store_lex 'a', $P1
 789     print "foo: "
 790     print $P0
 791     print "\n"
 792     .local string code
 793     code = <<'EOC'
 794         .sub bar :anon :outer(foo)
 795             $P0 = find_lex 'a'
 796             inc $P0
 797             store_lex 'a', $P0
 798             print "bar: "
 799             print $P0
 800             print "\n"
 801         .end
 802 EOC
 803     .local pmc compiler
 804     compiler = compreg "PIR"
 805     $P1 = compiler(code)
 806     $P2 = $P1[0]   # first sub of eval
 807     $P3 = newclosure $P2
 808     .return($P3)
 809 .end
 810 CODE
 811 foo: 42
 812 bar: 43
 813 bar: 44
 814 bar: 45
 815 foo: 13013
 816 bar: 13014
 817 bar: 46
 818 OUTPUT
 819
 820 pir_error_output_like( <<'CODE', <<'OUT', 'closure 8' );
 821
 822 # p6 example from pmichaud
 823 # { my $x = 5;  { print $x; my $x = 4; print $x; } }
 824
 825 ## According to S04 this is an error
 826
 827 .sub main :main
 828     .lex '$x', $P0
 829     $P0 = new 'Integer'
 830     $P0 = 5
 831     anon_1()
 832 .end
 833
 834 .sub anon_1 :anon :outer(main)
 835     # anon closure
 836     $P0 = find_lex '$x'
 837     print $P0
 838     .lex '$x', $P1
 839     $P1 = new 'Integer'
 840     $P1 = 4
 841     print $P1
 842 .end
 843 CODE
 844 /Null PMC access/
 845 OUT
 846
 847 pir_error_output_like( <<'CODE', <<'OUTPUT', 'get non existing' );
 848 .sub "main" :main
 849     .lex 'a', $P0
 850     foo()
 851 .end
 852 .sub foo  :outer('main')
 853     .lex 'b', $P0
 854     bar()
 855 .end
 856 .sub bar   :outer('foo')
 857     .lex 'c', $P0
 858     $P2 = find_lex 'no_such'
 859 .end
 860 CODE
 861 /Lexical 'no_such' not found/
 862 OUTPUT
 863
 864 pir_output_is( <<'CODE', <<'OUTPUT', 'find_name on lexicals' );
 865 .sub main :main
 866     .lex 'a', $P0
 867     $P1 = new 'String'
 868     $P1 = "ok\n"
 869     store_lex 'a', $P1
 870     $P2 = find_name 'a'
 871     print $P0
 872     print $P1
 873     print $P2
 874 .end
 875 CODE
 876 ok
 877 ok
 878 ok
 879 OUTPUT
 880
 881 pir_output_is( <<'CODE', <<'OUTPUT', 'multiple names' );
 882 .sub main :main
 883     .lex 'a', $P0
 884     .lex 'b', $P0
 885     .lex 'c', $P0
 886     $P1 = new 'String'
 887     $P1 = "ok\n"
 888     store_lex 'a', $P1
 889     $P2 = find_name 'b'
 890     print $P0
 891     print $P1
 892     print $P2
 893     $P3 = find_lex 'c'
 894     print $P3
 895 .end
 896 CODE
 897 ok
 898 ok
 899 ok
 900 ok
 901 OUTPUT
 902
 903 pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 1' );
 904 # my $x;
 905 # sub f{$x++}
 906 # f()
 907 # print "$x\n"
 908 .sub '&main' :main :anon
 909     .local pmc sx
 910     .lex '$x', sx
 911     sx = new 'Integer'
 912     sx = 33
 913     '&f'()
 914     print sx    # no find_lex needed - 'sx' is defined here
 915     print "\n"
 916
 917     '&f'()
 918     print sx
 919     print "\n"
 920
 921     '&f'()
 922     print sx
 923     print "\n"
 924 .end
 925
 926 .sub '&f' :outer('&main')
 927     $P0 = find_lex '$x'           # find_lex needed
 928     inc $P0
 929 .end
 930 CODE
 931 34
 932 35
 933 36
 934 OUTPUT
 935
 936 pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 2' );
 937 # my $x;
 938 # sub f{$x++}
 939 # sub g{f();f()}
 940 # g()
 941 # print "$x\n"
 942 .sub '&main' :main :anon
 943     .local pmc sx
 944     .lex '$x', sx
 945     sx = new 'Integer'
 946     sx = -32
 947     '&g'()
 948     print sx
 949     print "\n"
 950
 951     '&g'()
 952     print sx
 953     print "\n"
 954
 955     '&g'()
 956     print sx
 957     print "\n"
 958
 959 .end
 960
 961 .sub '&f' :outer('&main')
 962     $P0 = find_lex '$x'
 963     inc $P0
 964 .end
 965
 966 .sub '&g' :outer('&main') # :outer not needed - no find_lex
 967     '&f'()
 968     '&f'()
 969 .end
 970 CODE
 971 -30
 972 -28
 973 -26
 974 OUTPUT
 975
 976 pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 3 - autoclose' );
 977 #     sub f ($x) {
 978 #         sub g ($y) { $x + $y }; g($x);
 979 #     }
 980 #     f(10); # 20
 981 #     g(100); # 110
 982 .sub '&f'
 983     .param pmc x
 984     .lex '$x', x
 985     $P0 = '&g'(x)
 986     .return ($P0)
 987 .end
 988
 989 .sub '&g' :outer('&f')
 990     .param pmc y
 991     .lex '$y', y
 992     .local pmc x
 993     x = find_lex '$x'
 994     $P0 = n_add x, y
 995     .return ($P0)
 996 .end
 997
 998 .sub '&main' :main :anon
 999     $P0 = '&f'(10)
1000     print $P0
1001     print "\n"
1002     $P0 = '&g'(100)
1003     print $P0
1004     print "\n"
1005 .end
1006
1007
1008 CODE
1009 20
1010 110
1011 OUTPUT
1012
1013 pir_error_output_like( <<'CODE', <<'OUTPUT', 'package-scoped closure 4 - autoclose' );
1014 #     sub f ($x) {
1015 #         sub g () { print $x };
1016 #     }
1017 #     g();
1018 .sub '&f'
1019     .param pmc x
1020     .lex '$x', x
1021 .end
1022
1023 .sub '&g' :outer('&f')
1024     .local pmc x
1025     x = find_lex '$x'
1026     print x
1027 .end
1028
1029 .sub '&main' :main :anon
1030     '&g'()
1031     print "never\n"
1032 .end
1033 CODE
1034 /Null PMC access/
1035 OUTPUT
1036
1037 pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 5 - autoclose' );
1038 #     sub f ($x) {
1039 #         sub g () { print "$x\n" };
1040 #     }
1041 #     f(10);
1042 #     g();
1043 .sub '&f'
1044     .param pmc x
1045     .lex '$x', x
1046 .end
1047
1048 .sub '&g' :outer('&f')
1049     .local pmc x
1050     x = find_lex '$x'
1051     print x
1052     print "\n"
1053 .end
1054
1055 .sub '&main' :main :anon
1056     '&f'(10)
1057     '&g'()
1058 .end
1059 CODE
1060 10
1061 OUTPUT
1062
1063 pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 6 - autoclose' );
1064 #     sub f ($x) {
1065 #         sub g () { print "$x\n" };
1066 #     }
1067 #     f(10);
1068 #     f(20);
1069 #     g();
1070 .sub '&f'
1071     .param pmc x
1072     .lex '$x', x
1073 .end
1074
1075 .sub '&g' :outer('&f')
1076     .local pmc x
1077     x = find_lex '$x'
1078     print x
1079     print "\n"
1080 .end
1081
1082 .sub '&main' :main :anon
1083     '&f'(10)
1084     '&f'(20)
1085     '&g'()
1086 .end
1087 CODE
1088 20
1089 OUTPUT
1090
1091 pir_output_is( <<'CODE', <<'OUTPUT', 'find_lex: (Perl6 OUTER::)', todo => 'not yet implemented' );
1092 .sub main :main
1093     .lex '$x', 42
1094     get_outer()
1095 .end
1096
1097 .sub 'get_outer' :outer('main')
1098     .lex '$x', 13
1099     $P0 = find_lex '$x', 1
1100     say $P0
1101 .end
1102 CODE
1103 42
1104 OUTPUT
1105
1106 pir_output_is( <<'CODE', <<'OUTPUT', 'Example for RT #44395' );
1107
1108 =for never
1109
1110 # The following PIR should be like:
1111
1112 use strict;
1113
1114 test_closures();
1115
1116 sub test_closures
1117 {
1118     my @closures;
1119
1120     # create some closures, outer scope
1121     {
1122          my $shared = 1;
1123
1124          # inner scope
1125          for (1..3) {
1126             my $not_shared = 1;
1127             my $sub_num    = $_;
1128             push @closures,
1129                  sub {
1130                      print "Sub $sub_num was called $not_shared times. Any sub was called $shared times.\n";
1131                      $shared++;
1132                      $not_shared++;
1133                  };
1134          }
1135     }
1136
1137     for ( 1 .. 4 ) {
1138          foreach ( @closures ) {
1139              $_->();
1140          }
1141     }
1142
1143 }
1144
1145 =cut
1146
1147 .sub test_closures :main
1148
1149     .lex '@closures', $P0
1150     $P0 = new 'ResizablePMCArray'
1151
1152     # create some closures, outer scope
1153     outer_scope()
1154
1155     # and call them in turn.
1156     $I0 = 0
1157     NEXT_LOOP0:
1158     if $I0 >= 4 goto DONE_LOOP0
1159         $I1 = 0
1160         NEXT_LOOP1:
1161         if $I1 >= 3 goto DONE_LOOP1
1162            $P1 = $P0[$I1]
1163            $P1()
1164            inc $I1
1165            goto NEXT_LOOP1
1166         DONE_LOOP1:
1167         inc $I0
1168         goto NEXT_LOOP0
1169     DONE_LOOP0:
1170
1171 .end
1172
1173 # Return n closures, each with lexical references to "$n" and "$sub_num".
1174 .sub 'outer_scope' :outer('test_closures')
1175
1176     .lex '$shared', $P0
1177     $P0 = new 'Integer'
1178     $P0 = 1
1179
1180     $I3 = 1
1181     NEXT:
1182     if $I3 > 3 goto DONE
1183         inner_scope( $I3 )
1184         inc $I3
1185         goto NEXT
1186     DONE:
1187
1188 .end
1189
1190
1191 .sub 'inner_scope' :outer('outer_scope')
1192     .param int topic
1193
1194     .lex '$sub_num', $P0
1195     $P0 = new 'Integer'
1196     $P0 = topic
1197
1198     .lex '$not_shared', $P1
1199     $P1 = new 'Integer'
1200     $P1 = 1
1201
1202     find_lex $P2, '@closures'
1203     .const .Sub $P3 = 'anonymous'
1204     newclosure $P4, $P3
1205     push $P2, $P4
1206
1207     .return ()
1208 .end
1209
1210 .sub 'anonymous' :outer('inner_scope')
1211
1212     find_lex $P0, '$sub_num'
1213     find_lex $P1, '$not_shared'
1214     find_lex $P2, '$shared'
1215
1216     print "Sub "
1217     print $P0
1218     print " was called "
1219     print $P1
1220     print " times. Any sub was called "
1221     print $P2
1222     print " times.\n"
1223
1224     inc $P1
1225     inc $P2
1226
1227     .return ()
1228 .end
1229
1230
1231 CODE
1232 Sub 1 was called 1 times. Any sub was called 1 times.
1233 Sub 2 was called 1 times. Any sub was called 2 times.
1234 Sub 3 was called 1 times. Any sub was called 3 times.
1235 Sub 1 was called 2 times. Any sub was called 4 times.
1236 Sub 2 was called 2 times. Any sub was called 5 times.
1237 Sub 3 was called 2 times. Any sub was called 6 times.
1238 Sub 1 was called 3 times. Any sub was called 7 times.
1239 Sub 2 was called 3 times. Any sub was called 8 times.
1240 Sub 3 was called 3 times. Any sub was called 9 times.
1241 Sub 1 was called 4 times. Any sub was called 10 times.
1242 Sub 2 was called 4 times. Any sub was called 11 times.
1243 Sub 3 was called 4 times. Any sub was called 12 times.
1244 OUTPUT
1245
1246 pir_output_is( <<'CODE', <<'OUTPUT', 'Double-inner scope called from closure (RT #56184)' );
1247 .sub 'main' :main
1248     .local pmc x
1249     x = 'foo'()
1250     x('world')
1251 .end
1252
1253 .sub 'foo' :outer('main')
1254     .local pmc a, bar
1255     a = new 'String'
1256     a = 'hello '
1257     .lex '$a', a
1258     $P0 = get_global 'bar'
1259     bar = newclosure $P0
1260     .return (bar)
1261 .end
1262
1263 .sub 'bar' :outer('foo')
1264     .param pmc b
1265     .lex '$b', b
1266     .local pmc a
1267     a = find_lex '$a'
1268     print a
1269     say b
1270     'bar_inner'()
1271 .end
1272
1273 .sub 'bar_inner' :outer('bar')
1274     .local pmc a, b
1275     a = find_lex '$a'
1276     b = find_lex '$b'
1277     print a
1278     say b
1279 .end
1280 CODE
1281 hello world
1282 hello world
1283 OUTPUT
1284
1285 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398:  Patrick's request" );
1286 .sub 'main' :main
1287         foo('try 1')
1288         foo('try 2')
1289         foo('try 3')
1290 .end
1291
1292 .sub 'foo' :lexid('foo')
1293         .param pmc x
1294         .lex '$x', x
1295         print "outer foo "
1296         say x
1297         'inner'()
1298 .end
1299
1300 .sub 'inner' :outer('foo')
1301         .local pmc x
1302         x = find_lex '$x'
1303         print "inner foo "
1304         say x
1305         $P0 = new 'String'
1306         $P0 = 'BOGUS!'
1307         store_lex '$x', $P0
1308 .end
1309 CODE
1310 outer foo try 1
1311 inner foo try 1
1312 outer foo try 2
1313 inner foo try 2
1314 outer foo try 3
1315 inner foo try 3
1316 OUTPUT
1317
1318 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398: Bob's recursion bug");
1319 .sub main :main
1320         rpwi(0)
1321 .end
1322
1323 .sub rpwi
1324         .param int recursive_p
1325         unless recursive_p goto do_lex
1326         print "rpwi:  recursive case\n"
1327         .return ()
1328 do_lex:
1329         .lex "(SAVED *SHARP-EQUAL-ALIST*)", $P40
1330         $P40 = new 'Integer'
1331         $P40 = 99
1332         .const .Sub $P80 = "(:INTERNAL rpwi 0)"
1333         newclosure $P81, $P80
1334         ## $P81 = clone $P80
1335         ## pushaction $P81
1336         print "rpwi:  lex case\n"
1337         rpwi(1)
1338         $P81()
1339 .end
1340
1341 .sub "(:INTERNAL rpwi 0)" :anon :outer('rpwi')
1342         print "[restoring *SHARP-EQUAL-ALIST*]\n"
1343         find_lex $P40, "(SAVED *SHARP-EQUAL-ALIST*)"
1344         print "[got "
1345         print $P40
1346         print "]\n"
1347 .end
1348 CODE
1349 rpwi:  lex case
1350 rpwi:  recursive case
1351 [restoring *SHARP-EQUAL-ALIST*]
1352 [got 99]
1353 OUTPUT
1354
1355 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398: Jonathan's recursive case" );
1356 .sub 'main' :main
1357     $P0 = new 'ResizablePMCArray'
1358     push $P0, 'a'
1359     $P1 = new 'ResizablePMCArray'
1360     $P2 = new 'ResizablePMCArray'
1361     push $P2, 'simple'
1362     push $P1, $P2
1363     push $P1, 'test'
1364     $P3 = new 'ResizablePMCArray'
1365     push $P3, 'for'
1366     push $P3, 'a'
1367     push $P3, 'simple'
1368     push $P1, $P3
1369     push $P0, $P1
1370     push $P0, 'script'
1371     'dump_thing'($P0, '# ')
1372 .end
1373
1374 .sub 'dump_thing'
1375     .param pmc thing
1376     .param pmc prefix
1377     .lex '$thing', thing
1378     .lex '$prefix', prefix
1379
1380     $P0 = find_global 'anon_1'
1381     $P1 = newclosure $P0
1382     .lex '$recur', $P1
1383
1384     $P2 = find_lex '$thing'
1385     $I0 = isa $P2, 'ResizablePMCArray'
1386     unless $I0 goto not_ResizablePMCArray
1387
1388     $P3 = find_lex '$prefix'
1389     print $P3
1390     print "[\n"
1391     $P4 = find_global 'anon_2'
1392     $P5 = newclosure $P4
1393     $P6 = find_lex '$thing'
1394     'map'($P5, $P6)
1395     $P7 = find_lex '$prefix'
1396     print $P7
1397     print "]\n"
1398     goto end_if
1399
1400   not_ResizablePMCArray:
1401     $P8 = find_lex '$prefix'
1402     print $P8
1403     $P9 = find_lex '$thing'
1404     print $P9
1405     print "\n"
1406   end_if:
1407 .end
1408
1409 .sub 'anon_1' :outer('dump_thing')
1410     .param pmc subthing
1411     .lex '$subthing', subthing
1412     $P0 = find_lex '$subthing'
1413     $P1 = find_lex '$prefix'
1414     $P2 = new 'String'
1415     $P2 = concat $P1, '    '
1416    'dump_thing'($P0, $P2)
1417 .end
1418
1419 .sub 'anon_2' :outer('dump_thing')
1420     .param pmc topic
1421     .lex "$_", topic
1422     $P0 = find_lex '$recur'
1423     $P1 = find_lex '$_'
1424     $P0($P1)
1425 .end
1426
1427 .sub 'map'
1428     .param pmc block
1429     .param pmc array
1430     .local pmc result, it
1431     result = new 'ResizablePMCArray'
1432     it = iter array
1433     loop:
1434     unless it goto loop_end
1435     $P0 = shift it
1436     $P0 = block($P0)
1437     push result, $P0
1438     goto loop
1439     loop_end:
1440     .return (result)
1441 .end
1442 CODE
1443 # [
1444 #     a
1445 #     [
1446 #         [
1447 #             simple
1448 #         ]
1449 #         test
1450 #         [
1451 #             for
1452 #             a
1453 #             simple
1454 #         ]
1455 #     ]
1456 #     script
1457 # ]
1458 OUTPUT
1459
1460 # Local Variables:
1461 #   mode: cperl
1462 #   cperl-indent-level: 4
1463 #   fill-column: 100
1464 # End:
1465 # vim: expandtab shiftwidth=4: