t/dynpmc/dynlexpad.t

   1 #! perl
   2 # Copyright (C) 2005-2007, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test tests => 7;
  10 use Parrot::Config;
  11
  12 =head1 NAME
  13
  14 t/dynpmc/dynlexpad.t - test the DynLexPad PMC
  15
  16 =head1 SYNOPSIS
  17
  18         % prove t/dynpmc/dynlexpad.t
  19
  20 =head1 DESCRIPTION
  21
  22 Tests the C<DynLexPad> PMC.
  23
  24 =cut
  25
  26 pir_output_is( << 'CODE', << 'OUTPUT', "loadlib" );
  27 .sub main :main
  28     .local pmc lib
  29     lib = loadlib "dynlexpad"
  30     unless lib goto not_loaded
  31     print "ok\n"
  32     end
  33 not_loaded:
  34     print "not loaded\n"
  35 .end
  36 CODE
  37 ok
  38 OUTPUT
  39
  40 my $loadlib = <<'EOC';
  41 .loadlib "dynlexpad"
  42
  43 .HLL "Some"
  44 .sub load :anon :init
  45   .local pmc interp, lexpad, dynlexpad
  46   interp = getinterp
  47   lexpad = get_class 'LexPad'
  48   dynlexpad = get_class 'DynLexPad'
  49   interp.'hll_map'(lexpad, dynlexpad)
  50 .end
  51
  52 EOC
  53
  54 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "store_lex" );
  55 # see loadlib
  56 .sub 'test' :main
  57     foo()
  58 .end
  59 .sub foo :lex
  60     $P1 = new 'Integer'
  61     $P1 = 13013
  62     store_lex 'a', $P1
  63     print "ok 1\n"
  64     $P2 = find_lex 'a'
  65     print "ok 2\n"
  66     print $P2
  67     print "\n"
  68     end
  69 .end
  70 CODE
  71 ok 1
  72 ok 2
  73 13013
  74 OUTPUT
  75
  76 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "check :outer" );
  77 .sub 'test' :main
  78     foo()
  79 .end
  80 .sub foo :lex
  81     $P1 = new 'Integer'
  82     $P1 = 13013
  83     store_lex 'a', $P1
  84     $P2 = find_lex 'a'
  85     print $P2
  86     print "\n"
  87     .const 'Sub' bar_sub = "bar"
  88     $P0 = newclosure bar_sub
  89     $P0()
  90 .end
  91 .sub bar :outer(foo)
  92     .const 'Sub' baz_sub = "baz"
  93     $P0 = newclosure baz_sub
  94     $P0()
  95 .end
  96 .sub baz :lex :outer(bar)
  97     $P1 = find_lex 'a'
  98     print $P1
  99     print "\n"
 100 .end
 101 CODE
 102 13013
 103 13013
 104 OUTPUT
 105
 106 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "tcl-ish upvar" );
 107 .sub 'test' :main
 108     foo()
 109 .end
 110 .sub foo :lex
 111     $P1 = new 'Integer'
 112     $P1 = 13013
 113     store_lex 'a', $P1
 114     $P2 = find_lex 'a'
 115     print $P2
 116     print "\n"
 117     .const 'Sub' bar_sub = "bar"
 118     $P0 = newclosure bar_sub
 119     $P0()
 120     # check the upvar
 121     $P2 = find_lex 'b'
 122     print $P2
 123     print "\n"
 124 .end
 125 .sub bar :outer(foo)
 126     .const 'Sub' baz_sub = "baz"
 127     $P0 = newclosure baz_sub
 128     $P0()
 129 .end
 130 .sub baz :lex :outer(bar)
 131     $P1 = find_lex 'a'
 132     print $P1
 133     print "\n"
 134     # upvar 2 'b', 55
 135     .local pmc pad, interp
 136     interp = getinterp
 137     pad = interp["lexpad"; 2]
 138     $P2 = new 'Integer'
 139     $P2 = 55
 140     pad['b'] = $P2
 141     .return()
 142 err:
 143     print "outer not found\n"
 144 .end
 145 CODE
 146 13013
 147 13013
 148 55
 149 OUTPUT
 150
 151 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "check that dynlexpad honors hll" );
 152 .sub 'test' :main
 153     foo()
 154     bar()
 155 .end
 156 .sub foo :lex
 157     .local pmc pad, interp
 158     interp = getinterp
 159     pad = interp["lexpad"]
 160     $S0 = typeof pad
 161     print $S0
 162     print "\n"
 163 .end
 164 .HLL "parrot"
 165 .sub bar :lex
 166     .local pmc pad, interp
 167     interp = getinterp
 168     pad = interp["lexpad"]
 169     $S0 = typeof pad
 170     print $S0
 171     print "\n"
 172 .end
 173 CODE
 174 DynLexPad
 175 LexPad
 176 OUTPUT
 177
 178 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "dynlexpad - lexpad interop" );
 179 .sub 'test' :main
 180     foo()
 181 .end
 182
 183 .sub foo
 184     .lex 'a', $P0               # static lexical
 185     $P0 = new 'String'
 186     $P0 = "ok 1"
 187     $P1 = find_lex 'a'
 188     say $P1
 189
 190     $P2 = new 'String'
 191     $P2 = "ok 2"
 192     store_lex 'a', $P2
 193     say $P0                   # sic!
 194
 195     $P3 = new 'String'
 196     $P3 = "ok 3"
 197     store_lex 'b', $P3          # and a dynamic one
 198     $P4 = find_lex 'b'
 199     say $P4
 200 .end
 201 CODE
 202 ok 1
 203 ok 2
 204 ok 3
 205 OUTPUT
 206
 207 TODO: {
 208     local $TODO = "iterator not implemented for DynLexPads; TT #1028";
 209
 210 pir_output_is( $loadlib . << 'CODE', << 'OUTPUT', "dynlexpad - iterator" );
 211
 212 .loadlib 'dynlexpad'
 213 .sub 'onload' :immediate
 214     .local pmc interp
 215     interp = getinterp
 216
 217     .local pmc core
 218     core = get_class 'LexPad'
 219     .local pmc hll
 220     hll = get_class 'DynLexPad'
 221     interp.'hll_map'(core,hll)
 222 .end
 223
 224 .sub 'test' :main
 225
 226     .local pmc str1,str2,str3
 227     .lex 'a', str1
 228     .lex 'b', str2
 229     .lex 'c', str3
 230
 231     str1 = box 'pants'
 232     str2 = box 'pants'
 233     str3 = box 'pants'
 234
 235     .local pmc interp
 236     interp = getinterp
 237
 238     .local pmc dlp
 239     dlp    = interp['lexpad']
 240
 241     .local pmc iterator
 242     iterator = iter dlp
 243 iter_loop:
 244     unless iterator goto iter_done
 245     .local pmc key
 246     key = shift iterator
 247     .local string value
 248     value = dlp[key]
 249     say value
 250     goto iter_loop
 251 iter_done:
 252 .end
 253 CODE
 254 pants
 255 pants
 256 pants
 257 OUTPUT
 258 }
 259
 260 # Local Variables:
 261 #   mode: cperl
 262 #   cperl-indent-level: 4
 263 #   fill-column: 100
 264 # End:
 265 # vim: expandtab shiftwidth=4: