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