languages/tcl/runtime/variables.pir

   1 .HLL '_Tcl', ''
   2 .namespace []
   3
   4 =head2 _Tcl::readVar
   5
   6 Read a variable from its name. It may be a scalar or an
   7 array.
   8
   9 Use the call level to determine if we are referring to a
  10 global variable or a lexical variable - will no doubt
  11 require further refinement later as we support namespaces
  12 other than the default, and multiple interpreters.
  13
  14 =cut
  15
  16 .sub readVar
  17   .param string name
  18
  19   .local pmc variable
  20
  21   # is this an array?
  22   # ends with )
  23   .local int char
  24   char = ord name, -1
  25   if char != 41 goto scalar
  26   # contains a (
  27   char = index name, '('
  28   if char == -1 goto scalar
  29
  30 array:
  31   .local string var
  32   var = substr name, 0, char
  33
  34   .local string key
  35   .local int len
  36   len = length name
  37   len -= char
  38   len -= 2
  39   inc char
  40   key = substr name, char, len
  41
  42   variable = findVar(var)
  43   if null variable goto no_such_variable
  44
  45   $I0 = does variable, 'associative_array'
  46   unless $I0 goto cant_read_not_array
  47
  48   variable = variable[key]
  49   if null variable goto bad_index
  50   $I0 = isa variable, 'Undef'
  51   if $I0 goto bad_index
  52   .return(variable)
  53
  54 bad_index:
  55   $S0 = "can't read \""
  56   $S0 .= name
  57   $S0 .= '": no such element in array'
  58   die $S0
  59
  60 cant_read_not_array:
  61   $S0 =  "can't read \""
  62   $S0 .= name
  63   $S0 .= "\": variable isn't array"
  64   die $S0
  65
  66 scalar:
  67   variable = findVar(name)
  68   if null variable goto no_such_variable
  69
  70   $I0 = does variable, 'associative_array'
  71   if $I0 goto cant_read_array
  72   .return(variable)
  73
  74 cant_read_array:
  75   $S0 = "can't read \""
  76   $S0 .= name
  77   $S0 .= '": variable is array'
  78   die $S0
  79
  80 no_such_variable:
  81   $S0 = "can't read \""
  82   $S0 .= name
  83   $S0 .= '": no such variable'
  84   die $S0
  85 .end
  86
  87 =head2 _Tcl::makeVar
  88
  89 Read a variable from its name. If it doesn't exist, create it. It may be a
  90 scalar or an array.
  91
  92 Use the call level to determine if we are referring to a
  93 global variable or a lexical variable - will no doubt
  94 require further refinement later as we support namespaces
  95 other than the default, and multiple interpreters.
  96
  97 =cut
  98
  99 .sub makeVar
 100   .param string name
 101   .param int    depth :named('depth') :optional
 102
 103   .local pmc variable
 104
 105   # is this an array?
 106   # ends with )
 107   .local int char
 108   char = ord name, -1
 109   if char != 41 goto scalar
 110   # contains a (
 111   char = index name, '('
 112   if char == -1 goto scalar
 113
 114 array:
 115   .local string var
 116   var = substr name, 0, char
 117
 118   .local string key
 119   .local int len
 120   len = length name
 121   len -= char
 122   len -= 2
 123   inc char
 124   key = substr name, char, len
 125
 126   variable = findVar(var, 'depth' => depth)
 127   unless null variable goto check_is_hash
 128
 129   variable = new 'TclArray'
 130   variable = storeVar(var, variable, 'depth' => depth)
 131
 132 check_is_hash:
 133   $I0 = does variable, 'associative_array'
 134   unless $I0 goto cant_read_not_array
 135
 136   $P0 = variable[key]
 137   if null $P0 goto create_elem
 138   .return($P0)
 139
 140 create_elem:
 141   $P0 = new 'Undef'
 142   variable[key] = $P0
 143   .return($P0)
 144
 145 cant_read_not_array:
 146   $S0 =  "can't read \""
 147   $S0 .= name
 148   $S0 .= "\": variable isn't array"
 149   die $S0
 150
 151 scalar:
 152   variable = findVar(name, 'depth' => depth)
 153   if null variable goto make_variable
 154   .return(variable)
 155
 156 make_variable:
 157     variable = new 'Undef'
 158     variable = storeVar(name, variable, 'depth' => depth)
 159     .return(variable)
 160 .end
 161
 162 =head2 _Tcl::setVar
 163
 164 Set a variable by its name. It may be a scalar or an array.
 165
 166 Use the call level to determine if we are referring to a
 167 global variable or a lexical variable - will no doubt
 168 require further refinement later as we support namespaces
 169 other than the default, and multiple interpreters.
 170
 171 =cut
 172
 173 .sub setVar
 174   .param string name
 175   .param pmc value
 176
 177   .local pmc variable
 178
 179   # Some cases in the code allow a NULL pmc to show up here.
 180   # This defensively converts them to an empty string.
 181   unless_null value, got_value
 182   value = new 'TclString'
 183   value = ''
 184
 185  got_value:
 186   # is this an array?
 187   # ends with )
 188   .local int char
 189   char = ord name, -1
 190   if char != 41 goto scalar
 191   # contains a (
 192   char = index name, '('
 193   if char == -1 goto scalar
 194
 195 find_array:
 196   .local string var
 197   var = substr name, 0, char
 198
 199   .local string key
 200   .local int len
 201   len = length name
 202   len -= char
 203   len -= 2
 204   inc char
 205   key = substr name, char, len
 206
 207   .local pmc array
 208   null array
 209   array = findVar(var)
 210   if null array goto create_array
 211
 212   $I0 = does array, 'associative_array'
 213   unless $I0 goto cant_set_not_array
 214   goto set_array
 215
 216 create_array:
 217   array = new 'TclArray'
 218   array = storeVar(var, array)
 219
 220 set_array:
 221   variable = array[key]
 222   if null variable goto set_new_elem
 223   assign variable, value
 224   $P0 = clone variable
 225   .return($P0)
 226
 227 set_new_elem:
 228   array[key] = value
 229   $P0 = clone value
 230   .return($P0)
 231
 232 cant_set_not_array:
 233   $S0 =  "can't set \""
 234   $S0 .= name
 235   $S0 .= "\": variable isn't array"
 236   die $S0
 237
 238 scalar:
 239   $P0 = findVar(name)
 240   if null $P0 goto create_scalar
 241   $I0 = does $P0, 'associative_array'
 242   if $I0 goto cant_set_array
 243
 244 create_scalar:
 245   storeVar(name, value)
 246   $P0 = clone value
 247   .return($P0)
 248
 249 cant_set_array:
 250   $S0 =  "can't set \""
 251   $S0 .= name
 252   $S0 .= "\": variable is array"
 253   die $S0
 254 .end
 255
 256 =head2 _Tcl::findVar
 257
 258 Utility function used by readVar and setVar.
 259
 260 Gets the actual variable from memory and returns it.
 261
 262 =cut
 263
 264 .sub findVar
 265   .param string name
 266   .param int    isglobal :named('global') :optional
 267   .param int    depth    :named('depth')  :optional
 268
 269   .local pmc value, ns
 270   ns = new 'ResizableStringArray'
 271
 272   .local int absolute
 273   absolute = 0
 274
 275   $I0 = index name, '::'
 276   if $I0 == 0  goto absolute_global
 277   if $I0 != -1 goto global_var
 278   if isglobal  goto global_var
 279
 280   .local pmc call_chain
 281   .local int call_level
 282   call_chain = get_root_global ['_tcl'], 'call_chain'
 283   call_level = elements call_chain
 284   if call_level == 0 goto global_var
 285
 286   name = '$' . name
 287
 288   .local pmc lexpad, variable
 289   push_eh lexical_notfound
 290     lexpad     = call_chain[-1]
 291     value      = lexpad[name]
 292   pop_eh
 293   if null value goto args_check
 294   $I0 = isa value, 'Undef'
 295   if $I0 goto args_check
 296   goto found
 297
 298 args_check:
 299   # args is special -- it doesn't show up in [info vars]
 300   # unless you explicitly set it in your proc. but if you
 301   # try to get it, it's always there.
 302   unless name == '$args' goto notfound
 303   value = lexpad['args']
 304   .return(value)
 305
 306 absolute_global:
 307   absolute = 1
 308 global_var:
 309   depth += 2
 310   ns = splitNamespace(name, depth)
 311   $S0 = pop ns
 312   $S0 = '$' . $S0
 313
 314   unshift ns, 'tcl'
 315   ns = get_root_namespace ns
 316   if null ns goto notfound
 317
 318   value = ns[$S0]
 319   if null value goto notfound
 320   $I0 = isa value, 'Undef'
 321   if $I0 goto notfound
 322   goto found
 323
 324 root_global_var:
 325   absolute = 1
 326   .local pmc colons, split
 327   colons = get_root_global ['_tcl'], 'colons'
 328   split  = get_root_global ['parrot'; 'PGE::Util'], 'split'
 329
 330   ns  = split(colons, name)
 331   $S0 = pop ns
 332   $S0 = '$' . $S0
 333
 334   unshift ns, 'tcl'
 335   ns = get_root_namespace ns
 336   if null ns goto notfound
 337
 338   value = ns[$S0]
 339   if null value goto found
 340   $I0 = isa value, 'Undef'
 341   if $I0 goto notfound
 342   goto found
 343
 344 notfound:
 345   unless absolute goto root_global_var
 346 lexical_notfound:
 347   null value
 348 found:
 349   .return(value)
 350 .end
 351
 352 =head2 _Tcl::storeVar
 353
 354 Utility function used by readVar and setVar.
 355
 356 Sets the actual variable from memory.
 357
 358 =cut
 359
 360 .sub storeVar
 361   .param string name
 362   .param pmc    value
 363   .param int    isglobal :named('global') :optional
 364   .param int    depth    :named('depth')  :optional
 365
 366   .local pmc value, ns
 367   ns = new 'ResizableStringArray'
 368
 369   $I0 = index name, '::'
 370   if $I0 != -1 goto global_var
 371   if isglobal goto global_var
 372
 373   .local pmc call_chain
 374   .local int call_level
 375   call_chain = get_root_global ['_tcl'], 'call_chain'
 376   call_level = elements call_chain
 377   if call_level == 0 goto global_var
 378
 379   name = '$' . name
 380 lexical_var:
 381   .local pmc lexpad
 382   lexpad       = call_chain[-1]
 383
 384   $P0 = lexpad[name]
 385   if null $P0 goto lexical_is_null
 386
 387   copy $P0, value
 388   .return($P0)
 389
 390 lexical_is_null:
 391   lexpad[name] = value
 392   .return(value)
 393
 394 global_var:
 395   depth += 2
 396   ns = splitNamespace(name, depth)
 397   name = pop ns
 398   name = '$' . name
 399
 400   unshift ns, 'tcl'
 401   ns = get_root_namespace ns
 402   if null ns goto global_not_undef
 403   $P0 = ns[name]
 404   if null $P0 goto global_not_undef
 405
 406   copy $P0, value
 407   .return($P0)
 408
 409 global_not_undef:
 410   ns[name] = value
 411   .return(value)
 412 .end
 413
 414 # Local Variables:
 415 #   mode: pir
 416 #   fill-column: 100
 417 # End:
 418 # vim: expandtab shiftwidth=4 ft=pir: