languages/tcl/runtime/builtin/subst.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&subst'
   5     .param pmc argv :slurpy
   6
   7     .local pmc options
   8     options = get_root_global ['_tcl'; 'helpers'; 'subst'], 'options'
   9
  10     .local pmc select_switches, switches
  11     select_switches  = get_root_global ['_tcl'], 'select_switches'
  12
  13     switches = select_switches(options, argv)
  14
  15     .local int argc
  16     argc = elements argv
  17     if argc == 0 goto badargs
  18     if argc > 1  goto badswitch
  19
  20     .local string str, newstr
  21     str = argv[0]
  22
  23     .local int nobackslashes, nocommands, novariables
  24     nobackslashes = exists switches['nobackslashes']
  25     nocommands    = exists switches['nocommands']
  26     novariables   = exists switches['novariables']
  27
  28     .local int pos, len
  29     pos = 0
  30     len = length str
  31     .local pmc parse, match, astgrammar, pirgrammar
  32     astgrammar = new 'TclExpr::PAST::Grammar'
  33     pirgrammar = new 'TclExpr::PIR::Grammar'
  34
  35     .local pmc splitNamespace, ns
  36     .local string namespace
  37     splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
  38     ns          = splitNamespace('', 2)
  39     namespace   = ''
  40     $I0 = elements ns
  41     if $I0 == 0 goto loop
  42
  43     namespace = join "'; '", ns
  44     namespace = "['" . namespace
  45     namespace .= "']"
  46 loop:
  47     if pos >= len goto done
  48     $S0 = substr str, pos, 1
  49     if $S0 == '[' goto command
  50     if $S0 == '$' goto variable
  51     if $S0 == '\' goto backslash
  52 next:
  53     inc pos
  54     goto loop
  55
  56 command:
  57     if nocommands goto next
  58     parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'subst_command'
  59     goto subst
  60
  61 variable:
  62     if novariables goto next
  63     parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'subst_variable'
  64     goto subst
  65
  66 backslash:
  67     if nobackslashes goto next
  68     parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'subst_backslash'
  69     goto subst
  70
  71 subst:
  72     match = parse(str, 'pos'=>pos, 'grammar'=>'TclExpr::Grammar')
  73
  74     .local pmc astbuilder, ast
  75     astbuilder = astgrammar.'apply'(match)
  76     ast        = astbuilder.'get'('past')
  77
  78     .local pmc pirbuilder
  79     .local string code
  80     pirbuilder = pirgrammar.'apply'(ast)
  81     code       = pirbuilder.'get'('result')
  82
  83     .local string ret
  84     ret = ast['ret']
  85
  86     .local pmc pir
  87     pir = new 'CodeString'
  88
  89     pir.emit(".HLL 'Tcl', ''")
  90     pir.emit(".loadlib 'tcl_ops'")
  91     pir.emit('.namespace %0', namespace)
  92     pir.emit(".include 'languages/tcl/src/returncodes.pasm'")
  93     pir.emit(".sub '_anon' :anon")
  94     pir .= code
  95     pir.emit('  .return(%0)', ret)
  96     pir.emit('.end')
  97     $S0 = pir
  98
  99     $P1    = compreg 'PIR'
 100     $P1    = $P1(pir)
 101     newstr = $P1()
 102
 103     $I0 = match.'to'()
 104     $I1 = $I0 - pos
 105     substr str, pos, $I1, newstr
 106
 107     pos = $I0
 108     $I0 = length newstr
 109     $I0 -= $I1
 110     pos += $I0
 111     len += $I0
 112     goto loop
 113
 114 done:
 115   .return (str)
 116
 117 badargs:
 118     die 'wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"'
 119
 120 badswitch:
 121     $S0 = argv[0]
 122     $S0 = 'bad switch "' . $S0
 123     $S0 .= '": must be -nobackslashes, -nocommands, or -novariables'
 124     die $S0
 125 .end
 126
 127 .sub 'anon' :anon :load
 128     .local pmc options
 129     options = new 'TclList'
 130     options[0] = 'nobackslashes'
 131     options[1] = 'nocommands'
 132     options[2] = 'novariables'
 133
 134     set_root_global ['_tcl'; 'helpers'; 'subst'], 'options', options
 135 .end
 136
 137
 138 # Local Variables:
 139 #   mode: pir
 140 #   fill-column: 100
 141 # End:
 142 # vim: expandtab shiftwidth=4 ft=pir: