languages/tcl/runtime/builtin/upvar.pir

   1 ###
   2 # [upvar]
   3
   4 .HLL 'Tcl', 'tcl_group'
   5 .namespace []
   6
   7 .sub '&upvar'
   8   .param pmc argv :slurpy
   9
  10   .local int argc
  11   argc = elements argv
  12   if argc < 2 goto bad_args
  13
  14   .local pmc __call_level, call_chain
  15   .local int call_level
  16   __call_level = get_root_global ['_tcl'], '__call_level'
  17   call_chain   = get_root_global ['_tcl'], 'call_chain'
  18   call_level   = elements call_chain
  19
  20   .local int new_call_level, defaulted
  21   $P0 = argv[0]
  22   (new_call_level,defaulted) = __call_level($P0)
  23   if defaulted == 1 goto skip
  24   $P1 = shift argv
  25   dec argc
  26
  27 skip:
  28   $I0 = argc % 2
  29   if $I0 == 1 goto bad_args
  30
  31   # for each othervar/myvar pair, created a mapping from
  32
  33   .local pmc __make, __set, __find_var
  34   __make     = get_root_global ['_tcl'], '__make'
  35   __set      = get_root_global ['_tcl'], '__set'
  36   __find_var = get_root_global ['_tcl'], '__find_var'
  37
  38   .local int counter, argc
  39   argc       = argv
  40   counter    = 0
  41   .local int difference
  42   difference = call_level - new_call_level
  43 loop:
  44   if counter >= argc goto done
  45
  46   .local string old_var, new_var
  47   old_var = argv[counter]
  48   inc counter
  49   new_var = argv[counter]
  50
  51   if new_call_level == 0 goto store_var
  52   $P0 = __find_var(new_var, 'depth'=>1)
  53   if null $P0 goto store_var
  54   $S0 = 'variable "'
  55   $S0 .= new_var
  56   $S0 .= '" already exists'
  57   tcl_error $S0
  58
  59 store_var:
  60   .local pmc saved_call_chain
  61   saved_call_chain = new 'ResizablePMCArray'
  62   $I0 = 0
  63 save_chain_loop:
  64   if $I0 == difference goto save_chain_end
  65   $P0 = pop call_chain
  66   push saved_call_chain, $P0
  67   inc $I0
  68   goto save_chain_loop
  69 save_chain_end:
  70
  71   $P1 = __make(old_var, 'depth'=>1)
  72
  73   # restore the old level
  74   $I0 = 0
  75 restore_chain_loop:
  76   if $I0 == difference goto restore_chain_end
  77   $P0 = pop saved_call_chain
  78   push call_chain, $P0
  79   inc $I0
  80   goto restore_chain_loop
  81 restore_chain_end:
  82
  83   # because we don't want to use assign here (we want to provide a new
  84   # alias, not use an existing one), do this work by hand
  85
  86   if call_level goto lexical
  87
  88   .local pmc ns
  89   .local string name
  90   ns   = __namespace(new_var, 1)
  91   name = pop ns
  92   name = '$' . name
  93
  94   unshift ns, 'tcl'
  95   ns = get_root_namespace ns
  96   ns[name] = $P1
  97   inc counter
  98   goto loop
  99
 100 lexical:
 101   $P0 = call_chain[-1]
 102   $S0 = '$' . new_var
 103   $P0[$S0] = $P1
 104   inc counter
 105   goto loop
 106
 107 done:
 108   .return('')
 109
 110 bad_args:
 111   tcl_error 'wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"'
 112 .end
 113
 114
 115 # Local Variables:
 116 #   mode: pir
 117 #   fill-column: 100
 118 # End:
 119 # vim: expandtab shiftwidth=4 ft=pir: