t/pmc/key.t

   1 #!./parrot
   2 # Copyright (C) 2001-2009, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/pmc/key.t - Keys
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/pmc/key.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests the C<Key> PMC.
  16
  17 =cut
  18
  19 .sub main :main
  20     .include 'test_more.pir'
  21
  22     plan(9)
  23
  24     traverse_key_chain()
  25     extract_int_from_string_keys()
  26     extract_string_from_int_keys()
  27     use_number_keys()
  28     do_not_collect_string_keys_early_rt_60128()
  29 .end
  30
  31 .sub traverse_key_chain
  32     .local string result
  33     result = ''
  34
  35     new $P0, ['Key']
  36     set $P0, "1"
  37     new $P1, ['Key']
  38     set $P1, "2"
  39     push $P0, $P1
  40     new $P2, ['Key']
  41     set $P2, "3"
  42     push $P1, $P2
  43
  44     set $P4, $P0
  45 l1:
  46     defined $I0, $P0
  47     unless $I0, e1
  48     $S0 = $P0
  49     result .= $S0
  50     shift $P0, $P0
  51     branch l1
  52 e1:
  53     is( result, '123', 'traverse key chain' )
  54
  55     result = ''
  56     set $P0, $P4
  57 l2:
  58     defined $I0, $P0
  59     unless $I0, e2
  60     $S0 = $P0
  61     result .= $S0
  62     shift $P0, $P0
  63     branch l2
  64 e2:
  65     is( result, '123', 'traverse second key chain' )
  66 .end
  67
  68 .sub extract_int_from_string_keys
  69     new $P0, ['ResizableStringArray']
  70     push $P0, 'ok1'
  71     push $P0, 'ok2'
  72     set $S0, 0
  73     set $P1, $P0[$S0]
  74     is( $P1, 'ok1', 'retrieve key is number as string' )
  75     set $P1, $P0["1"]
  76     is( $P1, 'ok2', 'retrieved key is number as str const' )
  77 .end
  78
  79 .sub extract_string_from_int_keys
  80     new $P0, ['Hash']
  81     set $P0['1'], 'ok1'
  82     set $P0['2'], 'ok2'
  83     set $I0, 1
  84     set $P1, $P0[$I0]
  85     is( $P1, 'ok1', 'retrieve key is int, set key was str const' )
  86     set $P1, $P0[2]
  87     is( $P1, 'ok2', 'retrieve key is const int, set key was str const' )
  88 .end
  89
  90 .sub use_number_keys
  91     .local pmc hash, key
  92     .local string foo
  93
  94     hash = new ['Hash']
  95     key  = new ['Key']
  96
  97     key = 1.234
  98     is(key, "1.234", "number-valued Key stringification works")
  99
 100     hash[key] = "FOO"
 101     foo = hash[key]
 102     is(foo, "FOO", "set/get via number-valued Key works")
 103 .end
 104
 105
 106 .sub do_not_collect_string_keys_early_rt_60128
 107     .local pmc proc, a
 108     proc = get_root_global [ 'tcl' ], '&proc'
 109     proc()
 110     a = get_root_global [ 'tcl' ], '&a'
 111     a()
 112     collect
 113     a()
 114     ok(1, 'register and non-register string keys should be COW' )
 115 .end
 116
 117 # support for do_not_collect_string_keys_early_rt_60128
 118 .HLL 'tcl'
 119 .namespace []
 120
 121 .sub '&info'
 122 iterate:
 123   .local pmc call_chain, lexpad
 124   call_chain = get_root_global ['_tcl'], 'call_chain'
 125   lexpad     = call_chain[-1]
 126   .local pmc    iterator
 127   .local string elem
 128   iterator = iter lexpad
 129 loop:
 130   unless iterator goto end
 131   elem = shift iterator
 132   $S0 = replace elem, 0, 1, ''
 133   goto loop
 134 end:
 135   .return('')
 136 .end
 137
 138 .sub '&proc'
 139
 140  $S0 = <<'code'
 141 .namespace []
 142 .sub 'xxx' :anon
 143   .local pmc call_chain, lexpad
 144   call_chain = get_root_global ['_tcl'], 'call_chain'
 145   lexpad = new ['Hash']
 146   push call_chain, lexpad
 147   .local pmc arg_list
 148   arg_list = new ['ResizablePMCArray']
 149   lexpad['args'] = arg_list
 150     $P14 = find_name "&info"
 151     $P14()
 152   $P0 = pop call_chain
 153   .return('')
 154 .end
 155 code
 156
 157   .local pmc pir_compiler
 158   pir_compiler = compreg 'PIR'
 159   $P0 = pir_compiler($S0)
 160   $P0 = $P0[0]
 161   $P1 = new ['TclProc']
 162   assign $P1, $P0
 163   .local pmc ns_target
 164   ns_target = get_hll_namespace
 165   ns_target['&a'] = $P1
 166 .end
 167
 168 .HLL '_Tcl'
 169 .namespace []
 170
 171 .sub prepare_lib :init
 172   $P0 = get_class 'Sub'
 173   $P1 = subclass $P0, 'TclProc'
 174   $P1 = new ['ResizablePMCArray']
 175   set_global 'call_chain', $P1
 176 .end
 177
 178 # Local Variables:
 179 #   mode: pir
 180 #   fill-column: 100
 181 # End:
 182 # vim: expandtab shiftwidth=4 ft=pir: