mim/development/mim/mimc/getord.mud

   1 <PACKAGE "GETORD">
   2
   3 <ENTRY GETORDER>
   4 "GETORDER FUNCTIONS"
   5
   6 <DEFINE CHECK (ATM)
   7         #DECL ((ATM) ATOM)
   8         <AND <GASSIGNED? .ATM>
   9              <OR <TYPE? ,.ATM FUNCTION>
  10                  <TYPE? ,.ATM MACRO>>>>
  11
  12 <DEFINE PREV (LS SUBLS)
  13         #DECL ((LS SUBLS) LIST (VALUE) LIST)
  14         <REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
  15
  16 <DEFINE SPLOUTEM (FL OU)
  17         #DECL ((FL) LIST (OU) ATOM)
  18         <REPEAT (TEM)
  19                 #DECL ((TEM) <OR FALSE LIST>)
  20                 <COND (<EMPTY? .FL> <RETURN T>)
  21                       (<SET TEM <MEMQ .OU <1 .FL>>>
  22                        <COND (<==? <1 .FL> .TEM> <PUT .FL 1 <REST .TEM>>)
  23                              (ELSE <PUTREST <PREV <1 .FL> .TEM> <REST .TEM>>)>)>
  24                 <SET FL <REST .FL 2>>>>
  25
  26 <DEFINE REVERSE (LS)
  27         #DECL ((LS) LIST)
  28         <REPEAT ((RES ()) (TEM ()))
  29                 #DECL ((RES TEM) LIST)
  30                 <COND (<EMPTY? .LS> <RETURN .RES>)>
  31                 <SET TEM <REST .LS>>
  32                 <SET RES <PUTREST .LS .RES>>
  33                 <SET LS .TEM>>>
  34
  35 <DEFINE ORDEREM (FLIST)
  36    #DECL ((FLIST) LIST)
  37    <REPEAT (TEM (RES ()))
  38      #DECL ((RES) <LIST [REST <OR ATOM LIST>]>
  39             (VALUE) <LIST [REST <OR ATOM LIST>]>
  40             (TEM) <PRIMTYPE LIST>)
  41      <COND
  42       (<EMPTY? .FLIST> <RETURN <REVERSE .RES>>)
  43       (<SET TEM <MEMQ () .FLIST>>
  44        <SET RES (<2 .TEM> !.RES)>
  45        <COND (<==? .TEM .FLIST> <SET FLIST <REST .FLIST 2>>)
  46              (ELSE <PUTREST <PREV .FLIST .TEM> <REST .TEM 2>>)>
  47        <SPLOUTEM .FLIST <1 .RES>>)
  48       (ELSE
  49        <PROG ((RES2 ()) GOTONE)
  50              #DECL ((RES2) LIST)
  51              <SET GOTONE <>>
  52              <REPEAT ((RES1 .FLIST))
  53                      #DECL ((RES1) LIST)
  54                      <COND (<NOT <CALLME <2 .RES1> .FLIST>>
  55                             <SET GOTONE T>
  56                             <SET RES2 (<2 .RES1> !.RES2)>
  57                             <COND (<==? .FLIST .RES1>
  58                                    <SET FLIST <REST .FLIST 2>>)
  59                                   (ELSE
  60                                    <PUTREST <PREV .FLIST .RES1>
  61                                             <REST .RES1 2>>)>)>
  62                      <AND <EMPTY? <SET RES1 <REST .RES1 2>>> <RETURN>>>
  63              <COND (.GOTONE <AGAIN>)
  64                    (<NOT <EMPTY? .FLIST>> <SET FLIST <CORDER .FLIST>>)>
  65              <SET TEM <REVERSE .RES>>
  66              <COND (<NOT <EMPTY? .FLIST>>
  67                     <COND (<EMPTY? .RES>
  68                            <SET TEM .FLIST>
  69                            <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
  70                           (ELSE
  71                            <SET RES
  72                                 <REST <PUTREST .RES .FLIST>
  73                                       <LENGTH .FLIST>>>)>)>
  74              <COND (<EMPTY? .RES> <SET RES .RES2>)
  75                    (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
  76        <RETURN .RES>)>>>
  77
  78 <DEFINE CALLME (ATM LST)
  79         #DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
  80         <REPEAT ()
  81                 <AND <EMPTY? .LST> <RETURN <>>>
  82                 <AND <MEMQ .ATM <1 .LST>> <RETURN>>
  83                 <SET LST <REST .LST 2>>>>
  84
  85 <DEFINE CORDER (LST "AUX" (RES ()))
  86         #DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
  87         <REPEAT ((LS .LST))
  88                 #DECL ((LS) <LIST [REST LIST ATOM]>)
  89                 <AND <EMPTY? .LS> <RETURN>>
  90                 <PUT .LS 1 <ALLREACH (<2 .LS>) <1 .LS> .LST>>
  91                 <SET LS <REST .LS 2>>>
  92         <REPEAT ((PNT ()))
  93                 #DECL ((PNT) <LIST [REST LIST ATOM]>)
  94                 <REPEAT ((SHORT <CHTYPE <MIN> FIX>) (TL 0) (LST .LST))
  95                         #DECL ((SHORT TL) FIX (LST) <LIST [REST LIST ATOM]>)
  96                         <AND <EMPTY? .LST> <RETURN>>
  97                         <COND (<L? <SET TL <LENGTH <1 .LST>>> .SHORT>
  98                                <SET SHORT .TL>
  99                                <SET PNT .LST>)>
 100                         <SET LST <REST .LST 2>>>
 101                 <SET RES
 102                      (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
 103                             (ELSE <1 .PNT>)>
 104                       !.RES)>
 105                 <MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
 106                 <REPEAT (TEM)
 107                         <COND (<SET TEM <MEMQ () .LST>>
 108                                <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
 109                                      (ELSE
 110                                       <PUTREST <PREV .LST .TEM>
 111                                                <REST .TEM 2>>)>)
 112                               (ELSE <RETURN>)>>
 113                 <AND <EMPTY? .LST> <RETURN>>>
 114         <REVERSE .RES>>
 115
 116 <DEFINE ALLREACH (LATM LST MLST)
 117    #DECL ((LATM LST) <LIST [REST ATOM]>
 118           (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
 119    <MAPF <>
 120     <FUNCTION (ATM)
 121             #DECL ((ATM) ATOM)
 122             <COND (<MEMQ .ATM .LATM>)
 123                   (ELSE
 124                    <SET LATM
 125                         <ALLREACH (.ATM !.LATM)
 126                                   <REPEAT ((L .MLST))
 127                                           #DECL ((L) <LIST [REST LIST ATOM]>)
 128                                           <AND <==? <2 .L> .ATM>
 129                                                <RETURN <1 .L>>>
 130                                           <SET L <REST .L 2>>>
 131                                   .MLST>>)>>
 132     .LST>
 133    .LATM>
 134
 135 <DEFINE REMEMIT (ATM)
 136         #DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
 137                (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
 138         <OR <==? .ATM .FUNC>
 139             <MEMQ .ATM .FUNCL>
 140             <SET FUNCL (.ATM !.FUNCL)>>>
 141
 142 <DEFINE FINDREC (OBJ "AUX" (FM '<>))
 143         #DECL ((FM) FORM)
 144         <COND (<MONAD? .OBJ>)
 145               (<AND <TYPE? .OBJ FORM SEGMENT>
 146                     <NOT <EMPTY? <SET FM <CHTYPE .OBJ FORM>>>>>
 147                <COND (<AND <TYPE? <1 .FM> ATOM> <GASSIGNED? <1 .FM>>>
 148                       <AND <TYPE? ,<1 .FM> FUNCTION> <REMEMIT <1 .FM>>>
 149                       <AND <TYPE? ,<1 .FM> MACRO>
 150                         <NOT <EMPTY? ,<1 .FM>>>
 151                                 <FINDREC <EMACRO .FM>>>
 152                                 ;"Analyze expansion of MACRO call"
 153                       <AND <OR <==? ,<1 .FM> ,MAPF> <==? ,<1 .FM> ,MAPR>>
 154                            <NOT <LENGTH? .FM 3>>
 155                            <PROG ()
 156                                  <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
 157                                  T>
 158                            <PROG ()
 159                                  <AND <TYPE? <3 .FM> FORM>
 160                                       <CHK-GVAL <3 .FM>>>>>)
 161                      (<STRUCTURED? <1 .OBJ>> <MAPF <> ,FINDREC <1 .OBJ>>)>
 162                <COND (<EMPTY? <REST .OBJ>>)
 163                      (ELSE <MAPF <> ,FINDREC <REST .OBJ>>)>)
 164               (ELSE <MAPF <> ,FINDREC .OBJ>)>>
 165
 166 <DEFINE EMACRO (OBJ "AUX" (ERR <CLASS "ERROR">) TEM)
 167         <COND (.ERR <OFF .ERR>)>
 168         <ON <HANDLER "ERROR"
 169                      <FUNCTION (FR "TUPLE" T)
 170                         <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
 171                                <DISMISS [!.T] ,MACACT>)
 172                               (ELSE <LISTEN .T>)>>
 173                      100>>
 174         <COND (<TYPE? <SET TEM
 175                            <PROG MACACT () #DECL ((MACACT) <SPECIAL ANY>)
 176                                  <SETG MACACT .MACACT>
 177                                  (<EXPAND .OBJ>)>>
 178                       VECTOR>
 179                <OFF "ERROR">
 180                <COND (.ERR <ON .ERR>)>
 181                <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
 182               (ELSE <OFF "ERROR"> <AND .ERR <ON .ERR>> <1 .TEM>)>>
 183
 184 <DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
 185         <AND    <==? <LENGTH .FM> 2>
 186                 <TYPE? <1 .FM> ATOM>
 187                 <==? ,<1 .FM> ,GVAL>
 188                 <TYPE? <2 .FM> ATOM>
 189                 <GASSIGNED? <2 .FM>>
 190                 <OR <TYPE? ,<2 .FM> FUNCTION>
 191                         <AND <TYPE? ,<2 .FM> MACRO>
 192                                 <NOT <EMPTY? ,<2 .FM>>>
 193                                 <TYPE? <1 ,<2 .FM>> FUNCTION>>>
 194                 <REMEMIT <2 .FM>>>>
 195
 196 <DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
 197         #DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
 198                (VALUE) <LIST [REST ATOM]>)
 199         <FINDREC ,.FUNC>
 200         .FUNCL>
 201
 202 <DEFINE FINDEMALL (ATM
 203                    "AUX" (TOPDO
 204                           <REPEAT ((TD ()))
 205                                   #DECL ((TD) LIST
 206                                          (VALUE)
 207                                          <LIST <LIST [REST ATOM]> ATOM>)
 208                                   <AND <EMPTY? .ATM> <RETURN .TD>>
 209                                   <SET TD (<FINDEM <1 .ATM>> <1 .ATM> !.TD)>
 210                                   <SET ATM <REST .ATM>>>))
 211         #DECL ((ATM) <<PRIMTYPE VECTOR> [REST ATOM]>
 212                (TOPDO) <LIST <LIST [REST ATOM]> ATOM>)
 213         <REPEAT ((TODO .TOPDO) (CURDO <1 .TOPDO>))
 214                 #DECL ((TODO) LIST
 215                        (CURDO) <LIST [REST ATOM]>)
 216                 <COND (<EMPTY? .CURDO>
 217                        <COND (<EMPTY? <SET TODO <REST .TODO 2>>>
 218                               <RETURN .TOPDO>)
 219                              (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
 220                       (<MEMQ <1 .CURDO> .TOPDO>)
 221                       (ELSE
 222                        <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
 223                                 (<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
 224                 <SET CURDO <REST .CURDO>>>>
 225
 226 <DEFINE GETORDER ("TUPLE" ATMS)
 227         #DECL ((ATMS) <TUPLE [REST ATOM]>)
 228         <COND (<NOT <MEMQ #FALSE () <MAPF ,LIST ,CHECK .ATMS>>>
 229                <ORDEREM <FINDEMALL .ATMS>>)
 230               (ELSE <ERROR BAD-ARG GETORDER>)>>
 231
 232
 233
 234 <SET LIST_OF_FUNCTIONS
 235      '(CHECK
 236        PREV
 237        SPLOUTEM
 238        REVERSE
 239        ORDEREM
 240        REMEMIT
 241        FINDREC
 242        FINDEM
 243        FINDEMALL
 244        GETORDER)>
 245 <ENDPACKAGE>