languages/tcl/runtime/builtin/lsort.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&lsort'
   5   .param pmc argv :slurpy
   6
   7   .local int return_type, argc
   8   .local pmc retval
   9   .local pmc compare
  10   .local pmc sort
  11
  12   argc = elements argv
  13   if argc == 0 goto wrong_args
  14
  15   compare = get_root_global ['_tcl';'helpers';'lsort'], 'ascii'
  16   sort    = get_root_global ['_tcl';'helpers';'lsort'], 'sort'
  17
  18   # possible options
  19   .local int decr, unique
  20   decr = 0
  21   unique = 0
  22 chew_flag:
  23   $P0 = shift argv
  24   unless argv goto got_list
  25
  26   if $P0 == '-decreasing' goto c_decr
  27   if $P0 == '-increasing' goto c_incr
  28   if $P0 == '-unique' goto c_uniq
  29   if $P0 == '-integer' goto c_int
  30   if $P0 == '-real' goto c_real
  31   if $P0 == '-dictionary' goto c_dict
  32   if $P0 == '-command' goto c_command
  33   branch bad_opt
  34
  35 c_dict:
  36   compare = get_root_global ['_tcl';'helpers';'lsort'], 'dictionary'
  37   branch chew_flag
  38 c_real:
  39   compare = get_root_global ['_tcl';'helpers';'lsort'], 'real'
  40   branch chew_flag
  41 c_decr:
  42   decr = 1
  43   branch chew_flag
  44 c_incr:
  45   decr = 0
  46   branch chew_flag
  47 c_uniq:
  48   unique = 1
  49   branch chew_flag
  50 c_int:
  51   compare = get_root_global ['_tcl';'helpers';'lsort'], 'integer'
  52   branch chew_flag
  53 c_command:
  54   .local string compareName
  55   compareName = shift argv
  56   $S0 = '&' . compareName
  57   compare = find_global $S0
  58   branch chew_flag
  59
  60 got_list:
  61
  62   .local pmc toList
  63   toList = get_root_global ['_tcl'], 'toList'
  64   $P0 = toList($P0)
  65
  66   $P0.'sort'(compare)
  67
  68   unless unique goto skip_unique
  69   .local int c, size
  70   c=0
  71   size = $P0
  72
  73   if size == 0 goto strip_end
  74   $P1 = $P0[0]
  75 strip_loop:
  76   inc c
  77   if c == size goto strip_end
  78   $P2 = $P1
  79   $P1 = $P0[c]
  80
  81   if $P1 != $P2 goto strip_loop
  82   delete $P0[c]
  83   dec c
  84   dec size
  85   branch strip_loop
  86 strip_end:
  87
  88 skip_unique:
  89   unless decr goto ordered
  90
  91   $P0 = clone $P0
  92   $P0.'reverse'()
  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   die $S0
 103 wrong_args:
 104   die '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   # We recalculate this every time, but without smarter PMCs, we can't
 123   # afford to change the string value of the given PMC.
 124   .local pmc toInteger
 125   toInteger = get_root_global ['_tcl'], 'toInteger'
 126   .local pmc i1,i2
 127   s1 = clone s1
 128   s2 = clone s2
 129   i1 = toInteger(s1)
 130   i2 = toInteger(s2)
 131   $I0 = cmp_num i1, i2
 132   .return ($I0)
 133
 134 .end
 135
 136
 137 .sub 'dictionary'
 138     .param string s1
 139     .param string s2
 140
 141     .include 'cclass.pasm'
 142
 143     .local int len1, len2, pos1, pos2
 144     len1 = length s1
 145     len2 = length s2
 146     pos1 = 0
 147     pos2 = 0
 148 loop:
 149     if pos1 >= len1 goto end1
 150     if pos2 >= len2 goto greater
 151
 152     $I0 = is_cclass .CCLASS_NUMERIC, s1, pos1
 153     if $I0 goto numeric
 154     $I0 = is_cclass .CCLASS_NUMERIC, s2, pos2
 155     if $I0 goto numeric
 156
 157     .local string char1, char2, sortchar1, sortchar2
 158     char1 = substr s1, pos1, 1
 159     char2 = substr s2, pos2, 1
 160     sortchar1 = downcase char1
 161     sortchar2 = downcase char2
 162     if sortchar1 != sortchar2 goto got_chars
 163     sortchar1 = char1
 164     sortchar2 = char2
 165
 166 got_chars:
 167     $I1 = ord sortchar1
 168     $I2 = ord sortchar2
 169
 170     inc pos1
 171     inc pos2
 172     goto compare
 173
 174 numeric:
 175     $I3 = find_not_cclass .CCLASS_NUMERIC, s1, pos1, len1
 176     if $I3 == pos1 goto greater
 177
 178     $I4 = find_not_cclass .CCLASS_NUMERIC, s2, pos2, len2
 179     if $I4 == pos2 goto less
 180
 181     $I5 = $I3 - pos1
 182     $I6 = $I4 - pos2
 183     $S1 = substr s1, pos1, $I5
 184     $S2 = substr s2, pos2, $I6
 185     pos1 = $I3
 186     pos2 = $I4
 187     $I1 = $S1
 188     $I2 = $S2
 189
 190 compare:
 191     if $I1 < $I2 goto less
 192     if $I1 > $I2 goto greater
 193     goto loop
 194
 195 end1:
 196     if len1 == len2 goto equal
 197
 198 less:
 199     .return(-1)
 200
 201 equal:
 202     .return(0)
 203
 204 greater:
 205     .return(1)
 206 .end
 207
 208 .sub 'real'
 209   .param pmc s1
 210   .param pmc s2
 211
 212   # check that they're actually numbers
 213   .local pmc toNumber
 214   toNumber = get_root_global ['_tcl'], 'toNumber'
 215   s1 = clone s1
 216   s2 = clone s2
 217   s1 = toNumber(s1)
 218   s2 = toNumber(s2)
 219
 220   $I0 = cmp_num s1, s2
 221   .return ($I0)
 222 .end
 223
 224 # Local Variables:
 225 #   mode: pir
 226 #   fill-column: 100
 227 # End:
 228 # vim: expandtab shiftwidth=4 ft=pir: