t/op/lexicals.t

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