languages/tcl/runtime/builtin/uplevel.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&uplevel'
   5   .param pmc argv :slurpy
   6
   7   .local int argc
   8   argc = elements argv
   9   if argc == 0 goto bad_args
  10
  11   .local pmc compileTcl, getCallLevel
  12   compileTcl        = get_root_global ['_tcl'], 'compileTcl'
  13   getCallLevel    = get_root_global ['_tcl'], 'getCallLevel'
  14
  15   # save the old call level
  16   .local pmc call_chain
  17   .local int call_level
  18   call_chain = get_root_global ['_tcl'], 'call_chain'
  19   call_level = elements call_chain
  20
  21   .local pmc new_call_level
  22   new_call_level = argv[0]
  23
  24   .local int defaulted
  25   (new_call_level,defaulted) = getCallLevel(new_call_level)
  26   if defaulted == 1 goto skip
  27
  28   # if we only have a level, then we don't have a command to run!
  29   if argc == 1 goto bad_args
  30   # pop the call level argument
  31   $P1 = shift argv
  32
  33 skip:
  34   .local int difference
  35   $I0 = new_call_level
  36   difference = call_level - $I0
  37
  38   .local pmc saved_call_chain
  39   saved_call_chain = new 'TclList'
  40   $I0 = 0
  41 save_chain_loop:
  42   if $I0 == difference goto save_chain_end
  43   $P0 = pop call_chain
  44   push saved_call_chain, $P0
  45   inc $I0
  46   goto save_chain_loop
  47 save_chain_end:
  48
  49   $S0 = join ' ', argv
  50   # if we get an exception, we have to reset the environment
  51   .local pmc retval
  52   push_eh restore_and_rethrow
  53     $P0 = compileTcl($S0)
  54     retval = $P0()
  55   pop_eh
  56
  57   bsr restore
  58   .return(retval)
  59
  60 restore_and_rethrow:
  61   .catch()
  62   bsr restore
  63   .rethrow()
  64
  65 restore:
  66   # restore the old level
  67   $I0 = 0
  68 restore_chain_loop:
  69   if $I0 == difference goto restore_chain_end
  70   $P0 = pop saved_call_chain
  71   push call_chain, $P0
  72   inc $I0
  73   goto restore_chain_loop
  74 restore_chain_end:
  75   ret
  76
  77 bad_args:
  78   die 'wrong # args: should be "uplevel ?level? command ?arg ...?"'
  79 .end
  80
  81 # Local Variables:
  82 #   mode: pir
  83 #   fill-column: 100
  84 # End:
  85 # vim: expandtab shiftwidth=4 ft=pir: