languages/tcl/runtime/builtin/lsort.pir

   1 #
   2 # [lsort]
   3 #
   4
   5 .HLL 'Tcl', 'tcl_group'
   6 .namespace []
   7
   8 .sub '&lsort'
   9   .param pmc argv :slurpy
  10
  11   .local int return_type, argc
  12   .local pmc retval
  13   .local pmc compare
  14   .local pmc sort
  15
  16   argc = argv
  17   if argc == 0 goto wrong_args
  18
  19   compare = get_root_global ['_tcl';'helpers';'lsort'], 'ascii'
  20   sort    = get_root_global ['_tcl';'helpers';'lsort'], 'sort'
  21
  22   # possible options
  23   .local int decr, unique
  24   decr = 0
  25   unique = 0
  26 chew_flag:
  27   $P0 = shift argv
  28   unless argv goto got_list
  29
  30   if $P0 == '-decreasing' goto c_decr
  31   if $P0 == '-increasing' goto c_incr
  32   if $P0 == '-unique' goto c_uniq
  33   if $P0 == '-integer' goto c_int
  34   if $P0 == '-real' goto c_real
  35   if $P0 == '-dictionary' goto c_dict
  36   # RT#40749: command etc necessary
  37   branch bad_opt
  38
  39 c_dict:
  40   compare = get_root_global ['_tcl';'helpers';'lsort'], 'dictionary'
  41   branch chew_flag
  42 c_real:
  43   compare = get_root_global ['_tcl';'helpers';'lsort'], 'real'
  44   branch chew_flag
  45 c_decr:
  46   decr = 1
  47   branch chew_flag
  48 c_incr:
  49   decr = 0
  50   branch chew_flag
  51 c_uniq:
  52   unique = 1
  53   branch chew_flag
  54 c_int:
  55   compare = get_root_global ['_tcl';'helpers';'lsort'], 'integer'
  56   branch chew_flag
  57
  58
  59 got_list:
  60
  61   .local pmc __list
  62   __list = get_root_global ['_tcl'], '__list'
  63   $P0 = __list($P0)
  64
  65   $P0.'sort'(compare)
  66
  67   unless unique goto skip_unique
  68   .local int c, size
  69   c=0
  70   size = $P0
  71
  72   if size == 0 goto strip_end
  73   $P1 = $P0[0]
  74 strip_loop:
  75   inc c
  76   if c == size goto strip_end
  77   $P2 = $P1
  78   $P1 = $P0[c]
  79
  80   if $P1 != $P2 goto strip_loop
  81   delete $P0[c]
  82   dec c
  83   dec size
  84   branch strip_loop
  85 strip_end:
  86
  87 skip_unique:
  88   unless decr goto ordered
  89
  90   .local pmc reverse
  91   reverse = get_root_global ['_tcl'], 'reverse'
  92   reverse($P0)
  93
  94 ordered:
  95   .return ($P0)
  96
  97 bad_opt:
  98   $S0 = 'bad option "'
  99   $S1 = $P0
 100   $S0 .= $S1
 101   $S0 .= '": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique'
 102   tcl_error $S0
 103 wrong_args:
 104   tcl_error 'wrong # args: should be "lsort ?options? list"'
 105 .end
 106
 107 .HLL '_Tcl', ''
 108 .namespace [ 'helpers'; 'lsort' ]
 109
 110 .sub 'ascii'
 111   .param string s1
 112   .param string s2
 113   $I0 = cmp_str s1, s2
 114   .return ($I0)
 115 .end
 116
 117 .sub 'integer'
 118   .param pmc s1
 119   .param pmc s2
 120
 121   # check that they're actually integers.
 122   # This points out that we should really be caching
 123   # the integer value rather than recalculating on each compare.
 124   .local pmc __integer
 125   __integer = get_root_global ['_tcl'], '__integer'
 126   .local pmc i1,i2
 127   i1 = __integer(s1)
 128   i2 = __integer(s2)
 129   $I0 = cmp_num i1, i2
 130   .return ($I0)
 131
 132 .end
 133
 134
 135 .sub 'dictionary'
 136     .param string s1
 137     .param string s2
 138
 139     .include 'cclass.pasm'
 140
 141     .local int len1, len2, pos1, pos2
 142     len1 = length s1
 143     len2 = length s2
 144     pos1 = 0
 145     pos2 = 0
 146 loop:
 147     if pos1 >= len1 goto end1
 148     if pos2 >= len2 goto greater
 149
 150     $I0 = is_cclass .CCLASS_NUMERIC, s1, pos1
 151     if $I0 goto numeric
 152     $I0 = is_cclass .CCLASS_NUMERIC, s2, pos2
 153     if $I0 goto numeric
 154
 155     .local string char1, char2, sortchar1, sortchar2
 156     char1 = substr s1, pos1, 1
 157     char2 = substr s2, pos2, 1
 158     sortchar1 = downcase char1
 159     sortchar2 = downcase char2
 160     if sortchar1 != sortchar2 goto got_chars
 161     sortchar1 = char1
 162     sortchar2 = char2
 163
 164 got_chars:
 165     $I1 = ord sortchar1
 166     $I2 = ord sortchar2
 167
 168     inc pos1
 169     inc pos2
 170     goto compare
 171
 172 numeric:
 173     $I3 = find_not_cclass .CCLASS_NUMERIC, s1, pos1, len1
 174     if $I3 == pos1 goto greater
 175
 176     $I4 = find_not_cclass .CCLASS_NUMERIC, s2, pos2, len2
 177     if $I4 == pos2 goto less
 178
 179     $I5 = $I3 - pos1
 180     $I6 = $I4 - pos2
 181     $S1 = substr s1, pos1, $I5
 182     $S2 = substr s2, pos2, $I6
 183     pos1 = $I3
 184     pos2 = $I4
 185     $I1 = $S1
 186     $I2 = $S2
 187
 188 compare:
 189     if $I1 < $I2 goto less
 190     if $I1 > $I2 goto greater
 191     goto loop
 192
 193 end1:
 194     if len1 == len2 goto equal
 195
 196 less:
 197     .return(-1)
 198
 199 equal:
 200     .return(0)
 201
 202 greater:
 203     .return(1)
 204 .end
 205
 206 .sub 'real'
 207   .param pmc s1
 208   .param pmc s2
 209
 210   # check that they're actually numbers
 211   .local pmc __number
 212   __number = get_root_global ['_tcl'], '__number'
 213   s1 = __number(s1)
 214   s2 = __number(s2)
 215
 216   $I0 = cmp_num s1, s2
 217   .return ($I0)
 218 .end
 219
 220 # Local Variables:
 221 #   mode: pir
 222 #   fill-column: 100
 223 # End:
 224 # vim: expandtab shiftwidth=4 ft=pir: