mim/development/mim/vax/mimlib/sortx.mud

   1 <PACKAGE "SORTX">
   2
   3 <RENTRY SORT>
   4
   5 <DEFINE SORT (PRED S1 "OPTIONAL" (L1 1) (OFFS 0) "TUPLE" T
   6               "AUX" L NN S SS E EE (STR? <>) SN)
   7         #DECL ((PRED) <OR FALSE APPLICABLE> (S1 S SS) ANY
   8                (E EE) ANY (STR?) <OR ATOM FALSE> (L1 L OFFS NN SN) FIX)
   9         <PROG ()
  10               <SET NN <+ .OFFS 1>>
  11               <COND (<TYPE? .S1 VECTOR>
  12                      <SET E <NTH .S1 .NN>>
  13                      <SET S <REST .S1 0>>
  14                      <SET SS <REST .S .L1>>)
  15                     (<TYPE? .S1 UVECTOR>
  16                      <SET E <NTH .S1 .NN>>
  17                      <SET S <REST .S1 0>>
  18                      <SET SS <REST .S .L1>>)
  19                     (<TYPE? .S1 LIST>
  20                      <SET E <NTH .S1 .NN>>
  21                      <SET S <REST .S1 0>>
  22                      <SET SS <REST .S .L1>>)
  23                     (<TYPE? .S1 TUPLE>
  24                      <SET E <NTH .S1 .NN>>
  25                      <SET S <REST .S1 0>>
  26                      <SET SS <REST .S .L1>>)
  27                     (ELSE
  28                      <RETURN <ERROR BAD-SORT-RECORD!-ERRORS>>)>
  29               <COND (<NOT <EMPTY? .T>>
  30                      <SET SN </ <LENGTH .S1> .L1>>
  31                      <REPEAT ((TT .T) X LX)
  32                              #DECL ((TT) TUPLE)
  33                              <COND (<EMPTY? .TT> <RETURN>)>
  34                              <SET X <1 .TT>>
  35                              <SET TT <REST .TT>>
  36                              <COND (<EMPTY? .TT> <SET L 1>)
  37                                    (ELSE
  38                                     <SET L <1 .TT>>
  39                                     <SET TT <REST .TT>>)>
  40                              <COND (<AND <==? .SN </ <SET LX <LENGTH .X>> .L>>
  41                                          <0? <MOD .LX .L>>>)
  42                                    (ELSE
  43                                     <ERROR INCONSISTENT-SORT-RECORD!-ERRORS
  44                                            .X>)>>)>
  45               <COND (<TYPE? .E STRING> <SET STR? T>)>
  46               <REPEAT ()
  47                       <COND (<COND (<TYPE? .SS VECTOR> <EMPTY? .SS>)
  48                                    (<TYPE? .SS UVECTOR> <EMPTY? .SS>)
  49                                    (<TYPE? .SS LIST> <EMPTY? .SS>)
  50                                    (<TYPE? .SS TUPLE> <EMPTY? .SS>)>
  51                              <COND (<TYPE? .S VECTOR> <SET S <REST .S .L1>>)
  52                                    (<TYPE? .S UVECTOR> <SET S <REST .S .L1>>)
  53                                    (<TYPE? .S LIST> <SET S <REST .S .L1>>)
  54                                    (<TYPE? .S TUPLE> <SET S <REST .S .L1>>)>
  55                              <COND (<LENGTH? .S .L1> <RETURN .S1>)
  56                                    (<TYPE? .S VECTOR>
  57                                     <SET E <NTH .S .NN>>
  58                                     <SET SS <REST .S .L1>>)
  59                                    (<TYPE? .S UVECTOR>
  60                                     <SET E <NTH .S .NN>>
  61                                     <SET SS <REST .S .L1>>)
  62                                    (<TYPE? .S LIST>
  63                                     <SET E <NTH .S .NN>>
  64                                     <SET SS <REST .S .L1>>)
  65                                    (<TYPE? .S TUPLE>
  66                                     <SET E <NTH .S .NN>>
  67                                     <SET SS <REST .S .L1>>)>)>
  68                       <COND (<TYPE? .S VECTOR>
  69                              <SET EE <NTH .SS .NN>>)
  70                             (<TYPE? .S UVECTOR>
  71                              <SET EE <NTH .SS .NN>>)
  72                             (<TYPE? .S LIST>
  73                              <SET EE <NTH .SS .NN>>)
  74                             (<TYPE? .S TUPLE>
  75                              <SET EE <NTH .SS .NN>>)>
  76                       <COND (<COND (.PRED <APPLY .PRED .E .EE>)
  77                                    (.STR? <G? <SET L <STRCOMP .E .EE>> 0>)
  78                                    (ELSE <G? .E .EE>)>
  79                              <SET E .EE>
  80                              <SWITCH .S .SS .L1>
  81                       <COND (<NOT <EMPTY? .T>>
  82                              <REPEAT ((TT .T) X)
  83                                      #DECL ((TT) TUPLE)
  84                                      <COND (<EMPTY? .TT> <RETURN>)>
  85                                      <SET X <1 .TT>>
  86                                      <SET TT <REST .TT>>
  87                                      <COND (<EMPTY? .TT> <SET L 1>)
  88                                            (ELSE
  89                                             <SET L <1 .TT>>
  90                                             <SET TT <REST .TT>>)>
  91                                      <SWITCH <REST .X
  92                                                    <* .L
  93                                                       <- .SN
  94                                                          </ <LENGTH .S> .L1>>>>
  95                                              <REST .X
  96                                                    <* .L
  97                                                       <- .SN
  98                                                          </ <LENGTH .SS> .L1>>>>
  99                                              .L>>)>)>
 100                       <COND (<TYPE? .SS VECTOR>
 101                              <SET SS <REST .SS .L1>>)
 102                             (<TYPE? .SS UVECTOR>
 103                              <SET SS <REST .SS .L1>>)
 104                             (<TYPE? .SS LIST>
 105                              <SET SS <REST .SS .L1>>)
 106                             (<TYPE? .SS TUPLE>
 107                              <SET SS <REST .SS .L1>>)>>>>
 108
 109 <DEFINE SWITCH (S SS L)
 110         #DECL ((L) FIX)
 111         <COND (<AND <TYPE? .S VECTOR> <TYPE? .SS VECTOR>>
 112                <MAPR <>
 113                      <FUNCTION (S SS "AUX" (TMP <1 .S>))
 114                           <PUT .S 1 <1 .SS>>
 115                           <PUT .SS 1 .TMP>
 116                           <COND (<0? <SET L <- .L 1>>>
 117                                  <MAPLEAVE>)>>
 118                      .S .SS>)
 119               (<AND <TYPE? .S UVECTOR> <TYPE? .SS UVECTOR>>
 120                <MAPR <>
 121                      <FUNCTION (S SS "AUX" (TMP <1 .S>))
 122                           <PUT .S 1 <1 .SS>>
 123                           <PUT .SS 1 .TMP>
 124                           <COND (<0? <SET L <- .L 1>>>
 125                                  <MAPLEAVE>)>>
 126                      .S .SS>)
 127               (<AND <TYPE? .S LIST> <TYPE? .SS LIST>>
 128                <MAPR <>
 129                      <FUNCTION (S SS "AUX" (TMP <1 .S>))
 130                           <PUT .S 1 <1 .SS>>
 131                           <PUT .SS 1 .TMP>
 132                           <COND (<0? <SET L <- .L 1>>>
 133                                  <MAPLEAVE>)>>
 134                      .S .SS>)
 135               (<AND <TYPE? .S TUPLE> <TYPE? .SS TUPLE>>
 136                <MAPR <>
 137                      <FUNCTION (S SS "AUX" (TMP <1 .S>))
 138                           <PUT .S 1 <1 .SS>>
 139                           <PUT .SS 1 .TMP>
 140                           <COND (<0? <SET L <- .L 1>>>
 141                                  <MAPLEAVE>)>>
 142                      .S .SS>)>>
 143
 144 <ENDPACKAGE>