<mdl.comp>/getord.mud.1

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