lexicals.t

#!perl
# Copyright (C) 2001-2006, The Perl Foundation.
# $Id$

use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );

use Test::More;
use Parrot::Test tests => 42;

=head1 NAME

t/op/lexicals.t - Lexical Ops

=head1 SYNOPSIS

    % prove t/op/lexicals.t

=head1 DESCRIPTION

Tests various lexical scratchpad operations, as described in PDD20.

=cut

pasm_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PASM (\'$a\') succeeds' );
.pcc_sub main:
    .lex "$a", P0
    print "ok\n"
    end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR' );
.sub main
    .lex "$a", P0
    print "ok\n"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR, $P' );
.sub main :main
    .lex '$a', $P0
    null $P0
    print "ok\n"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', '.lex parsing - PIR, local var' );
.sub main :main
    .local pmc a
    .lex "$a", a
    print "ok\n"
.end
CODE
ok
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', '.lex - same PMC twice (PASM)' );
.pcc_sub main:
    .lex '$a', P0
    .lex '$b', P0
    new P0, .String
    set P0, "ok\n"
    find_lex P1, '$a'
    print P1
    find_lex P2, '$a'
    print P2
    end
CODE
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', '.lex - same PMC twice fails (.local pmc ab)' );
.sub main :main
    .local pmc ab, a, b
    .lex '$a', ab
    .lex '$b', ab
    ab = new .String
    ab = "ok\n"
    a = find_lex '$a'
    print a
    b = find_lex '$b'
    print b
.end
CODE
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', '.lex - same lex twice' );
.sub main
 .lex '$a', $P0
 .lex '$a', $P1
 say "ok"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'api parsing' );
.sub main :main
    .lex 'a', $P0
    store_lex 'a', $P0
    $P0 = find_lex 'a'
    print "ok\n"
.include 'interpinfo.pasm'
    load_bytecode "pcore.pir"      # TODO autoload/preload
    interpinfo $P1, .INTERPINFO_CURRENT_SUB
    $P2 = $P1.'get_lexinfo'()
    $P2 = $P1.'get_lexenv'()
    print "ok\n"
.end
CODE
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo' );
.sub main :main
    .lex '$a', $P0
    .lex '$b', $P9
.include "interpinfo.pasm"
    interpinfo $P1, .INTERPINFO_CURRENT_SUB
    $P2 = $P1.'get_lexinfo'()
    $S0 = typeof $P2
    print $S0
    print ' '
    $I0 = elements $P2
    print $I0
    print_newline
.end
CODE
LexInfo 2
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo - no lexicals' );
.sub main :main
.include "interpinfo.pasm"
    interpinfo $P1, .INTERPINFO_CURRENT_SUB
    $P2 = $P1.'get_lexinfo'()
    if null $P2 goto ok
    print "LexInfo not NULL\n"
    end
ok:
    print "ok\n"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - no pad' );
.sub main :main
    .local pmc pad, interp
    interp = getinterp
    pad = interp["lexpad"]
    if null pad goto ok
    print "pad not NULL\n"
    end
ok:
    print "ok\n"
    end
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - no pad inherited in coro' );
.sub main
     coro()
.end
.sub coro
    .local pmc pad, interp
    interp = getinterp
    pad = interp["lexpad"]
    if null pad goto ok
    print "pad not NULL\n"
    .yield()
ok:
    print "ok\n"
    .yield()
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - set var via pad' );
.sub main
    .local pmc pad, interp
    interp = getinterp
    pad = interp["lexpad"]
    .lex '$a', P0
    unless null pad goto ok
    print "pad is NULL\n"
    end
ok:
    print "ok\n"
    P1 = new .Integer
    P1 = 13013
    pad['$a'] = P1
    print P0
    print "\n"
    end
.end
CODE
ok
13013
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexpad - set two vars via pad (2 lex -> 2 pmc)' );
.sub main
    .lex '$a', P0
    .lex '$b', P2
    .local pmc pad, interp
    interp = getinterp
    pad = interp["lexpad"]
    .local pmc pad
    unless null pad goto ok
    print "pad is NULL\n"
    end
ok:
    print "ok\n"
    P1 = new .Integer
    P1 = 13013
    pad['$a'] = P1
    print P0
    print "\n"
    P1 = 42
    pad['$b'] = P1
    print P2
    print "\n"
    end
.end
CODE
ok
13013
42
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'synopsis example' );
.sub main
    .lex '$a', P0
    P1 = new .Integer
    P1 = 13013
    store_lex '$a', P1
    print P0
    print "\n"
    end
.end
CODE
13013
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - PASM' );
.pcc_sub main:
    print "ok\n"
    end
.pcc_sub :lex foo:
    returncc
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - PIR' );
.sub main
    print "ok\n"
.end
.sub foo :lex
.end
CODE
ok
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - PASM' );
.pcc_sub main:
    print "ok\n"
    end
.pcc_sub :outer('main') foo:
    returncc
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - PIR' );
.sub main
    print "ok\n"
.end
.sub foo :outer('main')
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', ':outer parsing - ident' );
.sub main
    .local pmc a
    .lex "$a", a
    print "ok\n"
    end
.end
.sub foo :outer(main)
.end
CODE
ok
OUTPUT

pir_output_like( <<'CODE', <<'OUTPUT', ':outer parsing - missing :outer' );
.sub main
    print "ok\n"
.end
.sub foo :outer(oops)
.end
CODE
/Undefined :outer sub 'oops'\./
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_lexinfo from pad' );
.sub main
    .lex '$a', P0
    .local pmc pad, interp, info
    interp = getinterp
    pad = interp["lexpad"]
    unless null pad goto ok
    print "pad is NULL\n"
    end
ok:
    print "ok\n"
    info = pad.'get_lexinfo'()
    typeof $S0, info
    print $S0
    print "\n"
    end
.end
CODE
ok
LexInfo
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', ':lex parsing - verify info and pad' );
.sub main
    foo()
    print "ok\n"
.end
.sub foo :lex
    .local pmc pad, interp, info
    interp = getinterp
    pad = interp["lexpad"]
    unless null pad goto ok
    print "pad is NULL\n"
    end
ok:
    print "ok\n"
    typeof $S0, pad
    print $S0
    print "\n"
    info = pad.'get_lexinfo'()
    typeof $S0, info
    print $S0
    print "\n"
.end
CODE
ok
LexPad
LexInfo
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer' );
.sub "main"
    foo()
.end
.sub foo :outer('main')
    .include "interpinfo.pasm"
    interpinfo $P1, .INTERPINFO_CURRENT_SUB
    $P2 = $P1."get_outer"()
    print $P2
    print "\n"
.end
CODE
main
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer 2' );
.sub "main"
    foo()
.end
.sub foo  :outer('main')
    bar()
.end
.sub bar   :outer('foo')
    .include "interpinfo.pasm"
    interpinfo $P1, .INTERPINFO_CURRENT_SUB
    $P2 = $P1."get_outer"()
    print $P2
    print "\n"
    $P3 = $P2."get_outer"()
    print $P3
    print "\n"
.end
CODE
foo
main
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'get_outer via interp' );
.sub "main"
    .const .Sub foo = "foo"
    .local pmc foo_cl
    .lex "a", $P0
    foo_cl = newclosure foo
    foo_cl()
    print $P0
.end
.sub foo  :outer('main')
    .const .Sub bar = "bar"
    .local pmc bar_cl
    bar_cl = newclosure bar
    bar_cl()
.end
.sub bar   :outer('foo')
    .local pmc sub, interp, pad
    interp = getinterp
    sub = interp["outer"]
    print sub
    print "\n"
    sub = interp["outer"; "sub"]
    print sub
    print "\n"
    sub = interp["outer"; 2]
    print sub
    print "\n"
    sub = interp["outer"; "sub"; 2]
    print sub
    print "\n"
    $P0 = new .String
    $P0 = "I messed with your var\n"
    pad = interp["outer"; "lexpad"; 2]
    pad['a'] = $P0
.end
CODE
foo
foo
main
main
I messed with your var
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'closure 3' );
# sub foo {
#     my ($n) = @_;
#     sub {$n += shift}
# }
# my $f = foo(5);
# print &$f(3), "\n";
# my $g = foo(20);
# print &$g(3), "\n";
# print &$f(3), "\n";
# print &$g(4), "\n";

.sub foo
    .param pmc arg
    .local pmc n
    .lex '$n', n
    n = arg
    .const .Sub anon = "anon"
    $P0 = newclosure anon
    .return ($P0)
.end

.sub anon :outer(foo)
    .param pmc arg
    $P0 = find_lex '$n'
    # in practice we need copying the arg but as it is passed
    # as native int, we already have a fresh pmc
    $P0 += arg
    .return ($P0)
.end

.sub main :main
    .local pmc f, g
    .lex '$f', f
    .lex '$g', g
    f = foo(5)
    $P0 = f(3)
    print $P0
    print "\n"
    g = foo(20)
    $P0 = g(3)
    print $P0
    print "\n"
    $P0 = f(3)
    print $P0
    print "\n"
    $P0 = g(4)
    print $P0
    print "\n"
.end
CODE
8
23
11
27
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'closure 4' );
# code by Piers Cawley
=pod

  ;;; Indicate that the computation has failed, and that the program
  ;;; should try another path.  We rebind this variable as needed.
  (define fail
    (lambda () (error "Program failed")))

  ;;; Choose an arbitrary value and return it, with backtracking.
  ;;; You are not expected to understand this.
  (define (choose . all-choices)
    (let ((old-fail fail))
      (call-with-current-continuation
       (lambda (continuation)
         (define (try choices)
           (if (null? choices)
               (begin
                 (set! fail old-fail)
                 (fail))
               (begin
                 (set! fail
                      (lambda () (continuation (try (cdr choices)))))
                 (car choices))))
         (try all-choices)))))

  ;;; Find two numbers with a product of 15.
  (let ((x (choose 1 3 5))
        (y (choose 1 5 9)))
    (for-each display `("Trying " ,x " and " ,y #\newline))
    (unless (= (* x y) 15)
      (fail))
    (for-each display `("Found " ,x " * " ,y " = 15" #\newline)))

=cut

.sub main :main
     .local pmc fail, arr1, arr2, x, y, choose
     .lex 'fail', fail
     .lex 'arr1', arr1
     .lex 'arr2', arr2
     .lex 'x', x
     .lex 'y', y
     .lex 'choose', choose
     .const .Sub choose_sub = "_choose"
     .const .Sub fail_sub = "_fail"
     fail = newclosure fail_sub
     arr1 = new ResizablePMCArray
     arr1[0] = 1
     arr1[1] = 3
     arr1[2] = 5
     arr2 = new ResizablePMCArray
     arr2[0] = 1
     arr2[1] = 5
     arr2[2] = 9

     choose = newclosure choose_sub
     x = choose(arr1)
     #print "Chosen "
     #print x
     #print " from arr1\n"

     # need to create a new closure: these closures have different state
     choose = newclosure choose_sub
     y = choose(arr2)
     #print "Chosen "
     #print y
     #print " from arr2\n"
     $I1 = x
     $I2 = y
     $I0 = $I1 * $I2
     if $I0 == 15 goto success
     fail()
     print "Shouldn't get here without a failure report\n"
     branch the_end
success:
     print x
     print " * "
     print y
     print " == 15!\n"
the_end:
     end
.end

.sub _choose :outer(main)
     .param ResizablePMCArray choices

     .local pmc our_try, old_fail, cc, try
     .lex 'old_fail', old_fail
     .lex 'cc', cc
     .lex 'try', try
     #print "In choose\n"
     old_fail = find_lex "fail"
     .include "interpinfo.pasm"
     $P1 = interpinfo .INTERPINFO_CURRENT_CONT
     store_lex  "cc", $P1
     .const .Sub tr_sub = "_try"
     newclosure our_try, tr_sub
     store_lex "try", our_try
     $P2 = our_try(choices)
     .return($P2)
.end

.sub _try :outer(_choose)
     .param ResizablePMCArray choices

     .lex 'choices', $P0
     #print "In try\n"
     clone $P0, choices
     if choices goto have_choices
     $P1 = find_lex "old_fail"
     store_lex "fail", $P1
     $P1()
have_choices:
     .const .Sub f = "new_fail"
     newclosure $P2, f
     store_lex "fail", $P2
     $P3 = find_lex "choices"
     shift $P4, $P3

     .return($P4)
.end

.sub new_fail :outer(_try)
     .local pmc our_try
     .local pmc our_cc
     #print "In new_fail\n"
     our_cc = find_lex "cc"
     our_try = find_lex "try"
     $P2 = find_lex "choices"
     $P3 = our_try($P2)
     our_cc($P3)
.end

.sub _fail :outer(main)
     print "Program failed\n"
.end
CODE
3 * 5 == 15!
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'closure 5' );
# FIXME - we need to detect the destruction of the P registers
# associated with the Contexts for the calls of xyzzy and plugh.
# Otherwise, this test is just a repeat of others

.sub main :main
    .local pmc f
    f = xyzzy()
    f()
    f()
    f()
.end

.sub xyzzy
    $P1 = plugh()
    .return ($P1)
.end

.sub plugh
    $P1 = foo()
    .return ($P1)
.end

.sub foo
    .lex 'a', $P0
    $P0 = new Integer
    $P0 = 0

    .const .Sub bar_sub = "bar"
    $P1 = newclosure bar_sub
    .return ($P1)
.end

.sub bar :anon :outer(foo)
    $P0 = find_lex 'a'
    inc $P0
    print "bar: "
    print $P0
    print "\n"
.end
CODE
bar: 1
bar: 2
bar: 3
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'closure 6' );
# Leo's version of xyzzy original by particle, p5 by chip     #'

.sub main :main
    .local pmc f,g
    f = xyzzy(42)
    $P0 = f()
    $P0 = f()
    $P0 = f()
    g = xyzzy(13013)
    $P0 = g()
    $P0 = f()
.end

.sub xyzzy
    .param int i
    .local pmc f
    f = plugh(i)
    .return (f)
.end

.sub plugh
    .param int i
    .local pmc f
    f = foo(i)
    .return (f)
.end

.sub foo
    .param int i
    .lex 'a', $P0
    $P1 = new Integer
    $P1 = i
    store_lex 'a', $P1
    print "foo: "
    print $P0
    print "\n"
    .const .Sub closure = 'bar'
    $P2 = newclosure closure
    .return($P2)
.end

.sub bar :anon :outer(foo)
    $P0 = find_lex 'a'
    inc $P0
    store_lex 'a', $P0
    print "bar: "
    print $P0
    print "\n"
.end
CODE
foo: 42
bar: 43
bar: 44
bar: 45
foo: 13013
bar: 13014
bar: 46
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'closure 7 - evaled' );
.sub main :main
    .local pmc f,g
    f = xyzzy(42)
    $P0 = f()
    $P0 = f()
    $P0 = f()
    g = xyzzy(13013)
    $P0 = g()
    $P0 = f()
.end

.sub xyzzy
    .param int i
    .local pmc f
    f = plugh(i)
    .return (f)
.end

.sub plugh
    .param int i
    .local pmc f
    f = foo(i)
    .return (f)
.end

.sub foo
    .param int i
    .lex 'a', $P0
    $P1 = new Integer
    $P1 = i
    store_lex 'a', $P1
    print "foo: "
    print $P0
    print "\n"
    .local string code
    code = <<'EOC'
        .sub bar :anon :outer(foo)
            $P0 = find_lex 'a'
            inc $P0
            store_lex 'a', $P0
            print "bar: "
            print $P0
            print "\n"
        .end
EOC
    .local pmc compiler
    compiler = compreg "PIR"
    $P1 = compiler(code)
    $P2 = $P1[0]   # first sub of eval
    $P3 = newclosure $P2
    .return($P3)
.end
CODE
foo: 42
bar: 43
bar: 44
bar: 45
foo: 13013
bar: 13014
bar: 46
OUTPUT

pir_output_like( <<'CODE', <<'OUT', 'closure 8' );

# p6 example from pmichaud
# { my $x = 5;  { print $x; my $x = 4; print $x; } }

## According to S04 this is an error

.sub main :main
    .lex '$x', $P0
    $P0 = new .Integer
    $P0 = 5
    anon_1()
.end

.sub anon_1 :anon :outer(main)
    # anon closure
    $P0 = find_lex '$x'
    print $P0
    .lex '$x', $P1
    $P1 = new .Integer
    $P1 = 4
    print $P1
.end
CODE
/Null PMC access/
OUT

pir_output_like( <<'CODE', <<'OUTPUT', 'get non existing' );
.sub "main" :main
    .lex 'a', $P0
    foo()
.end
.sub foo  :outer('main')
    .lex 'b', $P0
    bar()
.end
.sub bar   :outer('foo')
    .lex 'c', $P0
    $P2 = find_lex 'no_such'
.end
CODE
/Lexical 'no_such' not found/
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'find_name on lexicals' );
.sub main :main
    .lex 'a', $P0
    $P1 = new .String
    $P1 = "ok\n"
    store_lex 'a', $P1
    $P2 = find_name 'a'
    print $P0
    print $P1
    print $P2
.end
CODE
ok
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'multiple names' );
.sub main :main
    .lex 'a', $P0
    .lex 'b', $P0
    .lex 'c', $P0
    $P1 = new .String
    $P1 = "ok\n"
    store_lex 'a', $P1
    $P2 = find_name 'b'
    print $P0
    print $P1
    print $P2
    $P3 = find_lex 'c'
    print $P3
.end
CODE
ok
ok
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 1' );
# my $x;
# sub f{$x++}
# f()
# print "$x\n"
.sub '&main' :main :anon
    .local pmc sx
    .lex '$x', sx
    sx = new .Integer
    sx = 33
    '&f'()
    print sx    # no find_lex needed - 'sx' is defined here
    print "\n"

    '&f'()
    print sx 
    print "\n"

    '&f'()
    print sx 
    print "\n"
.end

.sub '&f' :outer('&main') 
    $P0 = find_lex '$x'           # find_lex needed
    inc $P0
.end
CODE
34
35
36
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 2' );
# my $x;
# sub f{$x++}
# sub g{f();f()}
# g()
# print "$x\n"
.sub '&main' :main :anon
    .local pmc sx
    .lex '$x', sx
    sx = new .Integer
    sx = -32
    '&g'()
    print sx
    print "\n"

    '&g'()
    print sx
    print "\n"

    '&g'()
    print sx
    print "\n"

.end

.sub '&f' :outer('&main') 
    $P0 = find_lex '$x'
    inc $P0
.end

.sub '&g' :outer('&main') # :outer not needed - no find_lex
    '&f'()
    '&f'()
.end
CODE
-30
-28
-26
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 3 - autoclose' );
#     sub f ($x) { 
#         sub g ($y) { $x + $y }; g($x); 
#     } 
#     f(10); # 20 
#     g(100); # 110
.sub '&f' 
    .param pmc x
    .lex '$x', x
    $P0 = '&g'(x)
    .return ($P0)
.end

.sub '&g' :outer('&f')
    .param pmc y
    .lex '$y', y
    .local pmc x
    x = find_lex '$x'
    $P0 = n_add x, y
    .return ($P0)
.end

.sub '&main' :main :anon
    $P0 = '&f'(10)
    print $P0
    print "\n"
    $P0 = '&g'(100)
    print $P0
    print "\n"
.end


CODE
20
110
OUTPUT

pir_output_like( <<'CODE', <<'OUTPUT', 'package-scoped closure 4 - autoclose' );
#     sub f ($x) { 
#         sub g () { print $x }; 
#     } 
#     g(); 
.sub '&f' 
    .param pmc x
    .lex '$x', x
.end

.sub '&g' :outer('&f')
    .local pmc x
    x = find_lex '$x'
    print x
.end

.sub '&main' :main :anon
    '&g'()
    print "never\n"
.end
CODE
/Null PMC access/
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 5 - autoclose' );
#     sub f ($x) { 
#         sub g () { print "$x\n" }; 
#     } 
#     f(10); 
#     g(); 
.sub '&f' 
    .param pmc x
    .lex '$x', x
.end

.sub '&g' :outer('&f')
    .local pmc x
    x = find_lex '$x'
    print x
    print "\n"
.end

.sub '&main' :main :anon
    '&f'(10)
    '&g'()
.end
CODE
10
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'package-scoped closure 6 - autoclose' );
#     sub f ($x) { 
#         sub g () { print "$x\n" }; 
#     } 
#     f(10); 
#     f(20); 
#     g(); 
.sub '&f' 
    .param pmc x
    .lex '$x', x
.end

.sub '&g' :outer('&f')
    .local pmc x
    x = find_lex '$x'
    print x
    print "\n"
.end

.sub '&main' :main :anon
    '&f'(10)
    '&f'(20)
    '&g'()
.end
CODE
20
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', 'find_lex: (Perl6 OUTER::)', todo => 'not yet implemented' );
.sub main :main
	.lex '$x', 42
	get_outer()
.end

.sub 'get_outer' :outer('main')
	.lex '$x', 13
	$P0 = find_lex '$x', 1
	say $P0
.end
CODE
42
OUTPUT

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: