languages/tcl/runtime/builtin/regexp.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&regexp'
   5   .param pmc argv :slurpy
   6
   7   .local int argc
   8   argc = elements argv
   9   if argc < 2 goto badargs
  10
  11   .local pmc options
  12   options = get_root_global ['_tcl'; 'helpers'; 'regexp'], 'options'
  13
  14   .local pmc select_switches, switches
  15   select_switches  = get_root_global ['_tcl'], 'select_switches'
  16   switches = select_switches(options, argv, 1, 1)
  17
  18   .local string exp, a_string, original_string
  19    exp      = shift argv
  20    a_string = shift argv
  21    original_string = a_string
  22
  23    .local pmc tclARE, rule, match
  24
  25    # RT#40774: use tcl-regexps
  26    tclARE = compreg 'PGE::P5Regex'
  27    $I0 = exists switches['nocase']
  28    unless $I0 goto ready
  29    exp      = downcase exp
  30    a_string = downcase a_string
  31
  32 ready:
  33    rule = tclARE(exp)
  34    match = rule(a_string)
  35
  36    # matchVar
  37    argc = elements argv
  38    unless argc goto done
  39    .local string matchStr, matchVar
  40    .local pmc setVar
  41    setVar = get_root_global [ '_tcl' ], 'setVar'
  42
  43    matchVar = shift argv
  44
  45    .local pmc matches
  46
  47    $I0 = exists switches['indices']
  48    if $I0 goto matches_ind
  49
  50    # Do this in case there was a -nocase
  51    $I0 = match.'from'()
  52    $I1 = match.'to'()
  53    $I1 -= $I0
  54    matchStr = substr original_string, $I0, $I1
  55
  56    setVar(matchVar, matchStr)
  57
  58    matches = match.'get_array'()
  59    .local string subMatchStr, subMatchVar
  60
  61 subMatches:
  62    argc = elements argv
  63    unless argc goto done
  64
  65    subMatchVar = shift argv
  66    subMatchStr = ''
  67    if_null matches, set_it
  68    $I0 = elements matches
  69    unless $I0 goto set_it
  70    $P0 = shift matches
  71    if_null $P0, set_it
  72    $I0 = $P0.'from'()
  73    $I1 = $P0.'to'()
  74    $I1 -= $I0
  75    subMatchStr = substr original_string, $I0, $I1
  76
  77 set_it:
  78    setVar(subMatchVar,subMatchStr)
  79
  80 next_submatch:
  81   goto subMatches
  82
  83 matches_ind:
  84   .local pmc matchList
  85   matchList = new 'TclList'
  86   matchList[0] = -1
  87   matchList[1] = -1
  88   $I0 = match.'from'()
  89   $I1 = match.'to'()
  90   dec $I1
  91   matchList[0] = $I0
  92   matchList[1] = $I1
  93   setVar(matchVar, matchList)
  94
  95   matches = match.'get_array'()
  96
  97 subMatches_ind:
  98   .local pmc subMatchList
  99 subMatches_ind_loop:
 100    argc = elements argv
 101    unless argc goto done
 102
 103    subMatchVar = shift argv
 104    subMatchList = new 'TclList'
 105    subMatchList[0] = -1
 106    subMatchList[1] = -1
 107    if_null matches, set_it_ind
 108    $I0 = elements matches
 109    unless $I0 goto set_it_ind
 110    $P0 = shift matches
 111    if_null $P0, set_it_ind
 112    $I0 = $P0.'from'()
 113    $I1 = $P0.'to'()
 114    dec $I1
 115    subMatchList[0] = $I0
 116    subMatchList[1] = $I1
 117
 118 set_it_ind:
 119    setVar(subMatchVar,subMatchList)
 120
 121 next_submatch_ind:
 122   goto subMatches_ind_loop
 123
 124 done:
 125    $I0 = istrue match
 126    .return ($I0)
 127
 128 badargs:
 129   die 'wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"'
 130
 131 .end
 132
 133 .sub 'anon' :anon :load
 134   .local pmc options
 135   options = new 'TclList'
 136   push options, 'all'
 137   push options, 'about'
 138   push options, 'indices'
 139   push options, 'inline'
 140   push options, 'expanded' # RT#40774: use tcl-regexps
 141   push options, 'line'
 142   push options, 'linestop'
 143   push options, 'lineanchor'
 144   push options, 'nocase'
 145   push options, 'start'
 146
 147   set_root_global ['_tcl'; 'helpers'; 'regexp'], 'options', options
 148 .end
 149
 150 # Local Variables:
 151 #   mode: pir
 152 #   fill-column: 100
 153 # End:
 154 # vim: expandtab shiftwidth=4 ft=pir: