languages/tcl/runtime/builtin/switch.pir

   1 .HLL 'Tcl', 'tcl_group'
   2 .namespace []
   3
   4 .sub '&switch'
   5   .param pmc argv :slurpy
   6   .local int argc
   7   argc = elements argv
   8
   9   .local pmc retval
  10   .local string mode
  11   .local int nocase
  12   nocase = 0
  13   mode = '-exact'
  14
  15   if argc < 2 goto bad_args
  16 flag_loop:
  17   unless argc goto bad_args
  18   $S0 = shift argv
  19   $S1 = substr $S0, 0, 1
  20   if $S0 == '--' goto get_subj
  21   if $S1 != '-' goto skip_subj
  22
  23   # ouch!
  24   if $S0 == '-exact' goto set_mode
  25   if $S0 == '-glob' goto set_mode
  26   if $S0 == '-regexp' goto set_mode
  27   if $S0 == '-nocase' goto set_case
  28   if $S0 == '-matchvar' goto set_fvar
  29   if $S0 == '-indexvar' goto set_fvar
  30   branch bad_flag
  31
  32 set_case:
  33   nocase = 1
  34   branch flag_loop
  35
  36 set_mode:
  37   mode = $S0
  38   branch flag_loop
  39
  40 set_fvar:
  41   $S0 = shift argv
  42   branch flag_loop
  43
  44 get_subj:
  45   unless argv goto bad_args
  46   $S0 = shift argv
  47 skip_subj:
  48   .local string subject
  49   subject = $S0
  50   unless nocase goto get_body
  51   subject = downcase subject
  52
  53 get_body:
  54   .local pmc body
  55   argc = elements argv
  56   if argc != 1 goto body_from_argv
  57
  58 body_from_list:
  59   .local pmc __list
  60   __list = get_root_global ['_tcl'], '__list'
  61
  62   $P0 = shift argv
  63   body = __list($P0)
  64   goto got_body
  65
  66 body_from_argv:
  67   body = argv
  68
  69 got_body:
  70   $I0 = elements body
  71   if $I0 == 0 goto bad_args_with_curlies
  72   $I0 = $I0 % 2
  73   if $I0 == 1 goto extra_pattern
  74
  75   # check to make sure the last option isn't a fall-through
  76   $S0 = body[-1]
  77   unless $S0 == '-' goto check_mode
  78   $S0 = body[-2]
  79   $S0 = 'no body specified for pattern "' . $S0
  80   $S0 = $S0 . '"'
  81   tcl_error $S0
  82
  83 check_mode:
  84   .local string pattern, code
  85   if mode == '-exact' goto exact_mode
  86   if mode == '-glob' goto glob_mode
  87   if mode == '-regexp' goto regex_mode
  88
  89 exact_mode:
  90 exact_loop:
  91   unless body goto body_end
  92   pattern = shift body
  93   code = shift body
  94   unless nocase goto exact_do
  95   pattern = downcase pattern
  96   code    = downcase code
  97
  98 exact_do:
  99   if subject == pattern goto body_match
 100   branch exact_loop
 101
 102 glob_mode:
 103   .local pmc globber, rule
 104   globber = compreg 'Tcl::Glob'
 105 glob_loop:
 106   unless body goto body_end
 107   pattern = shift body
 108   code = shift body
 109   unless nocase goto glob_do
 110   pattern = downcase pattern
 111   code    = downcase code
 112
 113  glob_do:
 114   (rule, $P1, $P2) = globber.'compile'(pattern)
 115   $P0 = rule(subject)
 116   if $P0 goto body_match
 117   branch glob_loop
 118
 119 regex_mode:
 120   .local pmc tclARE,rule,match
 121   tclARE = compreg 'PGE::P5Regex'
 122 regex_loop:
 123   unless body goto body_end
 124   pattern = shift body
 125   code = shift body
 126   unless nocase goto re_do
 127   pattern = downcase pattern
 128   code    = downcase code
 129  re_do:
 130   rule  = tclARE(pattern)
 131   match = rule(subject)
 132   if match goto body_match
 133   branch glob_loop
 134
 135 body_end:
 136   if pattern == 'default' goto body_match
 137
 138   .return ('')
 139
 140 fallthrough:
 141   $S0  = shift body
 142   code = shift body
 143 body_match:
 144   if code == '-' goto fallthrough
 145   .local pmc __script
 146   __script = get_root_global ['_tcl'], '__script'
 147   $P1 = __script(code)
 148   .return $P1()
 149
 150 extra_pattern:
 151   tcl_error 'extra switch pattern with no body'
 152
 153 bad_args:
 154   tcl_error 'wrong # args: should be "switch ?switches? string pattern body ... ?default body?"'
 155
 156 bad_args_with_curlies:
 157   tcl_error 'wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"'
 158
 159 bad_flag:
 160   $S1 = 'bad option "'
 161   $S1 .= $S0
 162   $S1 .= '": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --'
 163   tcl_error $S1
 164 .end
 165
 166 # Local Variables:
 167 #   mode: pir
 168 #   fill-column: 100
 169 # End:
 170 # vim: expandtab shiftwidth=4 ft=pir: