Skip to content
This repository
branch: nqp-p6
Fetching contributors…

Cannot retrieve contributors at this time

file 223 lines (185 sloc) 4.279 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
#!./parrot
# Copyright (C) 2001-2009, Parrot Foundation.

=head1 NAME

t/pmc/key.t - Keys

=head1 SYNOPSIS

% prove t/pmc/key.t

=head1 DESCRIPTION

Tests the C<Key> PMC.

=cut

.sub main :main
    .include 'test_more.pir'

    plan(13)

    test_push_bad_args()
    test_clone()
    traverse_key_chain()
    extract_int_from_string_keys()
    extract_string_from_int_keys()
    do_not_collect_string_keys_early_rt_60128()
    'get_repr'()

.end

.sub test_push_bad_args
    push_eh bad_push
    new $P1, ['FileHandle']
    new $P0, ['Key']
    push $P0, $P1
    pop_eh

    bad_push:
        ok( 1, 'Bad Arguments to push handled.')
.end

.sub traverse_key_chain
    .local string result
    result = ''

    new $P0, ['Key']
    set $P0, "1"
    new $P1, ['Key']
    set $P1, "2"
    push $P0, $P1
    new $P2, ['Key']
    set $P2, "3"
    push $P1, $P2

    set $P4, $P0
l1:
    defined $I0, $P0
    unless $I0, e1
    $S0 = $P0
    result .= $S0
    shift $P0, $P0
    branch l1
e1:
    is( result, '123', 'traverse key chain' )

    result = ''
    set $P0, $P4
l2:
    defined $I0, $P0
    unless $I0, e2
    $S0 = $P0
    result .= $S0
    shift $P0, $P0
    branch l2
e2:
    is( result, '123', 'traverse second key chain' )
.end

.sub extract_int_from_string_keys
    new $P0, ['ResizableStringArray']
    push $P0, 'ok1'
    push $P0, 'ok2'
    set $S0, 0
    set $P1, $P0[$S0]
    is( $P1, 'ok1', 'retrieve key is number as string' )
    set $P1, $P0["1"]
    is( $P1, 'ok2', 'retrieved key is number as str const' )
.end

.sub extract_string_from_int_keys
    new $P0, ['Hash']
    set $P0['1'], 'ok1'
    set $P0['2'], 'ok2'
    set $I0, 1
    set $P1, $P0[$I0]
    is( $P1, 'ok1', 'retrieve key is int, set key was str const' )
    set $P1, $P0[2]
    is( $P1, 'ok2', 'retrieve key is const int, set key was str const' )
.end

.sub test_clone
    .local pmc key
    key = new ['Key']
    key = 1

    # Test cloning integer keys.
    clone $P0, key

    # Test get integer
    $I0 = $P0

    is ($I0, "1", "cloning integer keys works")

    freeze $S0, $P0
    thaw $P2, $S0
    is ($P2, "1", "freeze/thaw integer keys works")
.end


.sub do_not_collect_string_keys_early_rt_60128
    .local pmc proc, a
    proc = get_root_global [ 'tcl' ], '&proc'
    proc()
    a = get_root_global [ 'tcl' ], '&a'
    a()
    collect
    a()
    ok(1, 'register and non-register string keys should be COW' )
.end

# support for do_not_collect_string_keys_early_rt_60128
.HLL 'tcl'
.namespace []

.sub '&info'
iterate:
  .local pmc call_chain, lexpad
  call_chain = get_root_global ['_tcl'], 'call_chain'
  lexpad = call_chain[-1]
  .local pmc iterator
  .local string elem
  iterator = iter lexpad
loop:
  unless iterator goto end
  elem = shift iterator
  $S0 = replace elem, 0, 1, ''
  goto loop
end:
  .return('')
.end

.sub '&proc'

 $S0 = <<'code'
.namespace []
.sub 'xxx' :anon
  .local pmc call_chain, lexpad
  call_chain = get_root_global ['_tcl'], 'call_chain'
  lexpad = new ['Hash']
  push call_chain, lexpad
  .local pmc arg_list
  arg_list = new ['ResizablePMCArray']
  lexpad['args'] = arg_list
    $P14 = find_name "&info"
    $P14()
  $P0 = pop call_chain
  .return('')
.end
code

  .local pmc pir_compiler
  pir_compiler = compreg 'PIR'
  $P0 = pir_compiler($S0)
  $P0 = $P0[0]
  $P1 = new ['TclProc']
  assign $P1, $P0
  .local pmc ns_target
  ns_target = get_hll_namespace
  ns_target['&a'] = $P1
.end

.HLL '_Tcl'
.namespace []

.sub prepare_lib :init
  $P0 = get_class 'Sub'
  $P1 = subclass $P0, 'TclProc'
  $P1 = new ['ResizablePMCArray']
  set_global 'call_chain', $P1
.end

.sub 'get_repr'
    $P0 = new ['Key']
    $P0 = 42
    repr_is($P0, '[ 42 ]')

    $P0 = new ['Key']
    $P0 = "xyzzy"
    repr_is($P0, "[ 'xyzzy' ]") # nothing happens (hopefully)

    $P0 = new ['Key']
    $P0.'set_register'(1, 4) # register 1 of set 4 (S1)
    # XXX PCC treats key arguments as special. Don't pass keys to subroutines.
    # repr_is($P0, '[ S1 ]')
    $S0 = get_repr $P0
    is($S0, '[ S1 ]', 'get_repr')
.end

.sub repr_is
    .param pmc x
    .param pmc repr
    .include 'test_more.pir'
    $S0 = get_repr x
    is($S0, repr, 'get_repr')
.end

# Local Variables:
# mode: pir
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir:
Something went wrong with that request. Please try again.