languages/tcl/src/class/tclconst.pir

   1 .HLL 'parrot', ''
   2 .namespace [ 'TclConst' ]
   3
   4 .cloneable()
   5
   6 =head1 TclConst
   7
   8 =head2 __class_init
   9
  10 Define the attributes required for the class.
  11
  12 =cut
  13
  14 .sub __class_init :anon :load
  15   $P0 = get_class 'String'
  16   $P1 = subclass $P0, 'TclConst'
  17
  18   $P0 = new 'Hash'
  19   $P0[ 97] = "\a"
  20   $P0[ 98] = "\x8" # \b
  21   $P0[102] = "\f"
  22   $P0[110] = "\n"
  23   $P0[114] = "\r"
  24   $P0[116] = "\t"
  25   $P0[118] = "\v"
  26
  27   # RT#40640: These should probably be moved into a class attribute.
  28   set_root_global ['_tcl'], 'backslashes', $P0
  29
  30   $P0 = new 'Hash'
  31   $P0[ 48] =  0 # '0'
  32   $P0[ 49] =  1
  33   $P0[ 50] =  2
  34   $P0[ 51] =  3
  35   $P0[ 52] =  4
  36   $P0[ 53] =  5
  37   $P0[ 54] =  6
  38   $P0[ 55] =  7
  39   $P0[ 56] =  8
  40   $P0[ 57] =  9
  41   $P0[ 65] = 10 # 'A'
  42   $P0[ 66] = 11
  43   $P0[ 67] = 12
  44   $P0[ 68] = 13
  45   $P0[ 69] = 14
  46   $P0[ 70] = 15
  47   $P0[ 97] = 10 # 'a'
  48   $P0[ 98] = 11
  49   $P0[ 99] = 12
  50   $P0[100] = 13
  51   $P0[101] = 14
  52   $P0[102] = 15
  53
  54   set_root_global ['_tcl'], 'hexadecimal', $P0
  55
  56 .end
  57
  58 .sub set_string_native :vtable :method
  59   .param string value
  60
  61   .local int value_length
  62
  63   .local pmc backslashes, hexadecimal
  64   backslashes = get_root_global ['_tcl'], 'backslashes'
  65   hexadecimal = get_root_global ['_tcl'], 'hexadecimal'
  66
  67   .local int pos
  68   pos = 0
  69 loop:
  70   value_length = length value
  71   pos = index value, '\', pos
  72   if pos == -1 goto done
  73
  74   $I0 = pos + 1
  75   $I0 = ord value, $I0
  76   if $I0 == 120 goto hex      # x
  77   if $I0 == 117 goto unicode  # u
  78   if $I0 <   48 goto simple   # < 0
  79   if $I0 <=  55 goto octal    # 0..7
  80                               # > 7
  81 simple:
  82   $I1 = exists backslashes[$I0]
  83   if $I1 goto special
  84
  85   substr value, pos, 1, ''
  86   inc pos
  87   goto loop
  88
  89 =for comment
  90
  91 Octal escapes consist of one, two, or three octal digits
  92
  93 =cut
  94
  95   .local int octal_value
  96   .local int digit
  97   .local int octal_pos
  98 octal:
  99   # at this point, $I0 contains the value of the first digit,
 100   # but pos is still at the backslash.
 101   octal_pos = pos + 1
 102   digit = $I0 - 48 # ascii value of 0.
 103   octal_value = digit
 104
 105   $I0 = octal_pos + 1
 106   if $I0 >= value_length goto octal_only1
 107
 108   $I0 = ord value, $I0
 109
 110   if $I0 <   48 goto octal_only1 # < 0
 111   if $I0 <=  55 goto octal2      # 0..7
 112                                  # > 7
 113 octal_only1:
 114   $S0 = chr octal_value
 115   substr value, pos, 2, $S0
 116
 117   inc pos
 118   goto loop
 119
 120 octal2:
 121   # at this point, $I0 contains the value of the second digit,
 122   # but octal_pos is still at the first digit.
 123   inc octal_pos # skip first digit
 124   digit = $I0 - 48 # ascii value of 0.
 125
 126   octal_value *= 8
 127   octal_value += digit
 128
 129   $I0 = octal_pos + 1
 130   if $I0 >= value_length goto octal_only2
 131   $I0 = ord value, $I0
 132
 133   if $I0 <   48 goto octal_only2 # < 0
 134   if $I0 <=  55 goto octal3      # 0..7
 135
 136 octal_only2:
 137   $S0 = chr octal_value
 138   substr value, pos, 3, $S0
 139
 140   inc pos
 141   goto loop
 142
 143 octal3:
 144   # at this point, $I0 contains the value of the third digit
 145   digit = $I0 - 48 # ascii value of 0.
 146
 147   octal_value *= 8
 148   octal_value += digit
 149
 150   $S0 = chr octal_value
 151   substr value, pos, 4, $S0
 152
 153   inc pos
 154   goto loop # can't have four digits, stop now.
 155
 156 =for comment
 157
 158 Hexadecimal escapes consist of an C<x>, followed by any number of hexadecimal
 159 digits. However, only the last two are used.
 160
 161 =cut
 162
 163  .local int hex_pos, hex_digit, hex_value
 164 hex:
 165   # at this point, pos is set to the backslash
 166   hex_value = 0
 167   hex_pos = pos + 2 # skip the backslash and the x
 168
 169 hex_loop:
 170   if hex_pos >= value_length goto hex_done
 171   $I0 = ord value, hex_pos
 172   $I1 = exists hexadecimal[$I0]
 173   unless $I1 goto hex_done
 174   hex_digit = hexadecimal[$I0]
 175   band hex_value, 15     # high byte discarded
 176   hex_value *= 16        # low byte promoted
 177   hex_value += hex_digit # new low byte added.
 178
 179   inc hex_pos
 180
 181   goto hex_loop
 182
 183 hex_done:
 184   $I0 = hex_pos - pos
 185   if $I0 == 2 goto hex_not_really
 186   $S0 = chr hex_value
 187   substr value, pos, $I0, $S0
 188
 189   inc pos
 190
 191   goto loop
 192
 193 hex_not_really:
 194   # This was a \x escape that had no hex value..
 195   substr value, pos, 2, 'x'
 196   inc pos
 197   goto loop
 198
 199 =for comment
 200
 201 Unicode escapes consist of an C<u>, followed by one to four hexadecimal digits.
 202
 203 =cut
 204
 205  .local int uni_pos, uni_digit, uni_value, uni_digit_count
 206 unicode:
 207   # at this point, pos is set to the backslash
 208   uni_value = 0
 209   uni_digit_count = 0
 210   uni_pos = pos + 2 # skip the backslash and the u
 211
 212 uni_loop:
 213   if uni_digit_count == 4 goto uni_done     #only four digits allowed
 214   if uni_pos >= value_length goto uni_done
 215   $I0 = ord value, uni_pos
 216   $I1 = exists hexadecimal[$I0]
 217   unless $I1 goto uni_done
 218   uni_digit = hexadecimal[$I0]
 219   uni_value *= 16        # low byte promoted
 220   uni_value += uni_digit # new low byte added.
 221
 222   inc uni_pos
 223   inc uni_digit_count
 224
 225   goto uni_loop
 226
 227 uni_done:
 228   $I0 = uni_pos - pos
 229   if $I0 == 2 goto uni_not_really
 230   $S0 = chr uni_value
 231   substr value, pos, $I0, $S0
 232
 233   inc pos
 234   goto loop
 235
 236 uni_not_really:
 237   # This was a \u escape that had no uni value..
 238   substr value, pos, 2, 'u'
 239   inc pos
 240   goto loop
 241
 242 special:
 243   $S0 = backslashes[$I0]
 244   substr value, pos, 2, $S0
 245   inc pos
 246   goto loop
 247
 248 done:
 249   # Finally, delegate to our parent's set_string
 250   $P0 = getattribute self, ['String'], 'proxy'
 251   $P0 = value
 252 .end
 253
 254 =head2 compile
 255
 256 Generate PIR code which can be used to generate our value
 257
 258 =cut
 259
 260 .sub compile :method
 261    .param int argnum
 262
 263    .local pmc compiler
 264   compiler = get_root_global ['_tcl'], 'compile_dispatch'
 265
 266    .return compiler(argnum, self)
 267 .end
 268
 269 =head2 _dump
 270
 271 This method enables Data::Dumper to work on us; shouldn't need it, because
 272 we're subclassing String...
 273
 274 =cut
 275
 276 .sub '__dump' :method
 277   .param pmc dumper
 278   .param string label
 279   print self
 280 .end
 281
 282
 283 # Local Variables:
 284 #   mode: pir
 285 #   fill-column: 100
 286 # End:
 287 # vim: expandtab shiftwidth=4 ft=pir: