t/op/lexicals-2.t

   1 #!perl
   2 # Copyright (C) 2001-2008, The Perl Foundation.
   3 # $Id: lexicals-2.t 28939 2008-07-02 08:33:21Z chromatic $
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8
   9 use Test::More;
  10 use Parrot::Test tests => 3;
  11
  12 =head1 NAME
  13
  14 t/op/lexicals-2.t - Lexical Ops
  15
  16 =head1 SYNOPSIS
  17
  18     % prove t/op/lexicals-2.t
  19
  20 =head1 DESCRIPTION
  21
  22 More elaborate tests of closure and lexical variable operations.
  23 See PDD20.
  24
  25 =cut
  26
  27 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398:  Patrick's request" );
  28 .sub 'main' :main
  29         foo('try 1')
  30         foo('try 2')
  31         foo('try 3')
  32 .end
  33
  34 .sub 'foo' :lexid('foo')
  35         .param pmc x
  36         .lex '$x', x
  37         print "outer foo "
  38         say x
  39         'inner'()
  40 .end
  41
  42 .sub 'inner' :outer('foo')
  43         .local pmc x
  44         x = find_lex '$x'
  45         print "inner foo "
  46         say x
  47         $P0 = new 'String'
  48         $P0 = 'BOGUS!'
  49         store_lex '$x', $P0
  50 .end
  51 CODE
  52 outer foo try 1
  53 inner foo try 1
  54 outer foo try 2
  55 inner foo try 2
  56 outer foo try 3
  57 inner foo try 3
  58 OUTPUT
  59
  60 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398: Bob's recursion bug", todo => 'not working after r28763.');
  61 .sub main :main
  62         rpwi(0)
  63 .end
  64
  65 .sub rpwi
  66         .param int recursive_p
  67         unless recursive_p goto do_lex
  68         print "rpwi:  recursive case\n"
  69         .return ()
  70 do_lex:
  71         .lex "(SAVED *SHARP-EQUAL-ALIST*)", $P40
  72         $P40 = new 'Integer'
  73         $P40 = 99
  74         .const .Sub $P80 = "(:INTERNAL rpwi 0)"
  75         newclosure $P81, $P80
  76         ## $P81 = clone $P80
  77         ## pushaction $P81
  78         print "rpwi:  lex case\n"
  79         rpwi(1)
  80         $P81()
  81 .end
  82
  83 .sub "(:INTERNAL rpwi 0)" :anon :outer('rpwi')
  84         print "[restoring *SHARP-EQUAL-ALIST*]\n"
  85         find_lex $P40, "(SAVED *SHARP-EQUAL-ALIST*)"
  86         print "[got "
  87         print $P40
  88         print "]\n"
  89 .end
  90 CODE
  91 rpwi:  lex case
  92 rpwi:  recursive case
  93 [restoring *SHARP-EQUAL-ALIST*]
  94 [got 99]
  95 OUTPUT
  96
  97 pir_output_is( <<'CODE', <<'OUTPUT', "RT#56398: Jonathan's recursive case" );
  98 .sub 'main' :main
  99     $P0 = new 'ResizablePMCArray'
 100     push $P0, 'a'
 101     $P1 = new 'ResizablePMCArray'
 102     $P2 = new 'ResizablePMCArray'
 103     push $P2, 'simple'
 104     push $P1, $P2
 105     push $P1, 'test'
 106     $P3 = new 'ResizablePMCArray'
 107     push $P3, 'for'
 108     push $P3, 'a'
 109     push $P3, 'simple'
 110     push $P1, $P3
 111     push $P0, $P1
 112     push $P0, 'script'
 113     'dump_thing'($P0, '# ')
 114 .end
 115
 116 .sub 'dump_thing'
 117     .param pmc thing
 118     .param pmc prefix
 119     .lex '$thing', thing
 120     .lex '$prefix', prefix
 121
 122     $P0 = find_global 'anon_1'
 123     $P1 = newclosure $P0
 124     .lex '$recur', $P1
 125
 126     $P2 = find_lex '$thing'
 127     $I0 = isa $P2, 'ResizablePMCArray'
 128     unless $I0 goto not_ResizablePMCArray
 129
 130     $P3 = find_lex '$prefix'
 131     print $P3
 132     print "[\n"
 133     $P4 = find_global 'anon_2'
 134     $P5 = newclosure $P4
 135     $P6 = find_lex '$thing'
 136     'map'($P5, $P6)
 137     $P7 = find_lex '$prefix'
 138     print $P7
 139     print "]\n"
 140     goto end_if
 141
 142   not_ResizablePMCArray:
 143     $P8 = find_lex '$prefix'
 144     print $P8
 145     $P9 = find_lex '$thing'
 146     print $P9
 147     print "\n"
 148   end_if:
 149 .end
 150
 151 .sub 'anon_1' :outer('dump_thing')
 152     .param pmc subthing
 153     .lex '$subthing', subthing
 154     $P0 = find_lex '$subthing'
 155     $P1 = find_lex '$prefix'
 156     $P2 = new 'String'
 157     $P2 = concat $P1, '    '
 158    'dump_thing'($P0, $P2)
 159 .end
 160
 161 .sub 'anon_2' :outer('dump_thing')
 162     .param pmc topic
 163     .lex "$_", topic
 164     $P0 = find_lex '$recur'
 165     $P1 = find_lex '$_'
 166     $P0($P1)
 167 .end
 168
 169 .sub 'map'
 170     .param pmc block
 171     .param pmc array
 172     .local pmc result, it
 173     result = new 'ResizablePMCArray'
 174     it = iter array
 175     loop:
 176     unless it goto loop_end
 177     $P0 = shift it
 178     $P0 = block($P0)
 179     push result, $P0
 180     goto loop
 181     loop_end:
 182     .return (result)
 183 .end
 184 CODE
 185 # [
 186 #     a
 187 #     [
 188 #         [
 189 #             simple
 190 #         ]
 191 #         test
 192 #         [
 193 #             for
 194 #             a
 195 #             simple
 196 #         ]
 197 #     ]
 198 #     script
 199 # ]
 200 OUTPUT