mim/development/mim/mimc/mset.mud

   1
   2 <DEFINE MULTI-SET-GEN (N:NODE W
   3                        "AUX" (K:<LIST [REST NODE]> <KIDS .N>) (SEG? <>)
   4                              (SIDE-E <>) (MX:FIX 0) (MN:FIX 0)
   5                              (VARS:<LIST [REST LIST]> <NODE-NAME .N>) TL:LIST
   6                              (VLN:FIX <LENGTH .VARS>)
   7                              (LV:<OR ATOM SYMTAB> <1 <NTH .VARS .VLN>>) (I:FIX 0))
   8    <MAPF <>
   9     <FUNCTION (N:NODE "AUX" RT)
  10             <COND (<OR <==? <SET NT <NODE-TYPE .N>> ,SEG-CODE>
  11                        <==? .NT ,SEGMENT-CODE>>
  12                    <SET SEG? T>
  13                    <SET MX <MAX <+ <MAXL <SET RT <RESULT-TYPE <1 <KIDS .N>>>>> .MX>
  14                                 ,MAX-LENGTH>>
  15                    <SET MN <+ <MINL .RT> .MN>>)
  16                   (ELSE
  17                    <SET I <+ .I 1>>
  18                    <SET MN <+ .MN 1>>
  19                    <SET MX <MAX <+ .MX 1> ,MAX-LENGTH>>)>
  20             <COND (<AND <G=? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
  21                         <SIDE-EFFECTS .N>>
  22                    <SET SIDE-E T>)>>
  23     <SET K <REST .K>>>
  24    <COND
  25     (.SEG?
  26      <PROG ((SEGLABEL <MAKE-TAG>) COUNTMP (SEGCALLED <>) SEGTMP)
  27        #DECL ((SEGLABEL COUNTMP SEGCALLED) <SPECIAL ANY>)
  28        <MAPF <>
  29         <FUNCTION (NN:NODE "AUX" (NT <NODE-TYPE .NN>) RES)
  30            <COND
  31             (<OR <==? .NT ,SEG-CODE> <==? .NT ,SEGMENT-CODE>>
  32              <COND (<NOT <ASSIGNED? SEGTMP>>
  33                     <SET SEGTMP <GEN-TEMP <>>>
  34                     <SET COUNTMP <GEN-TEMP FIX>>
  35                     <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
  36              <SET RES <GEN <SET NN <1 <KIDS .NN>>> .SEGTMP>>
  37              <SET SEGTYP <STRUCTYP-SEG <RESULT-TYPE .NN>>>
  38              <COND (<AND <N==? .RES ,NO-DATUM> <N==? .SEGTYP MULTI>>
  39                     <SEGMENT-STACK .SEGTMP
  40                                    .COUNTMP
  41                                    .SEGTYP
  42                                    <ISTYPE? <RESULT-TYPE .NN>>
  43                                    .SEGLABEL>
  44                     <SET SEGLABEL <MAKE-TAG>>)
  45                    (.SEGCALLED
  46                     <LABEL-TAG .SEGLABEL>
  47                     <SET SEGLABEL <MAKE-TAG>>)>)
  48             (ELSE
  49              <COND (.CNT <IEMIT `ADD .CNT 1 = .CNT>)>
  50              <GEN .NN ,POP-STACK>)>>
  51         .K>
  52        <COND (<AND .CAREFUL <N==? .MX .MN>>
  53               <IEMIT `VEQUAL? .COUNTMP .VLN - `COMPERR>)>
  54        <REPEAT ()
  55                <IEMIT `POP = <TEMP-NAME-SYM <1 <NTH .VARS .VLN>>>>
  56                <COND (<==? <SET VLN <- .VLN 1>> 0> <RETURN>)>>>)
  57     (.SIDE-E
  58      <SET TL
  59           <MAPF ,LIST
  60                 <FUNCTION (NN:NODE SYP:<LIST <OR ATOM SYMTAB>>
  61                            "AUX" (TY <RESULT-TYPE .NN>) PT
  62                                  (SY:<OR ATOM SYMTAB> <1 .SYP>))
  63                         <COND (<TYPE? .SY SYMTAB>
  64                                <SET TY <TYPE-AND <2 .SYP> .TY>>)>
  65                         <COND (<AND <SET TY <ISTYPE? .TY>>
  66                                     <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
  67                                         <==? .PT LIST>>>)
  68                               (ELSE <SET TY ANY>)>
  69                         <GEN .NN <GEN-TEMP .TY>>>
  70                 .K
  71                 .VARS>>
  72      <MAPF <>
  73            <FUNCTION (SYP:<LIST <OR ATOM SYMTAB>> TMP:TEMP
  74                       "AUX" (SY:<OR ATOM SYMTAB> <1 .SYP>) (LCL <>))
  75                    <COND (<AND <TYPE? .SY SYMTAB>
  76                                <N==? <CODE-SYM .SY> -1>
  77                                <SET LCL T>
  78                                <NOT <SPEC-SYM .SY>>>
  79                           <IEMIT `SET <TEM-NAME-SYM .SY> .TMP>
  80                           <FREE-TEMP .TMP>)
  81                          (ELSE
  82                           <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
  83                           <SET-VALUE .SY .TMP <NOT .LCL>>
  84                           <FREE-TEMP .TMP>)>>
  85            .VARS
  86            .TL>)
  87     (ELSE
  88      <PROG (NL-LATER:LIST SL-LATER:LIST ANY-DONE (MUCH-LATER:LIST ())
  89             TTMP:TEMP)
  90        <SET NL-LATER <SET SL-LATER ()>>
  91        <SET ANY-DONE <>>
  92        <MAPR <>
  93         <FUNCTION (SL NL
  94                    "AUX" (SYP:<LIST <OR ATOM SYMTAB TEMP>> <1 .SL>) (LCL <>) TY
  95                          (N:NODE <1 .NL>) (SY:<OR ATOM SYMTAB TEMP> <1 .SYP>) TMP)
  96                 <COND (<OR <TYPE? .SY TEMP>
  97                            <AND <NOT <REF? .SY <REST .NL>>>
  98                                 <NOT <REF? .SY .NL-LATER>>>>
  99                        <SET ANY-DONE T>
 100                        <COND (<OR <AND <TYPE? .SY SYMTAB>
 101                                        <N==? <CODE-SYM .SY> -1>
 102                                        <SET LCL T>
 103                                        <NOT <SPEC-SYM .SY>>
 104                                        <SET TMP <TEMP-NAME-SYM .SY>>>
 105                                   <AND <TYPE? .SY TEMP> <SET TMP .SY>>>
 106                               <GEN .N .TMP>)
 107                              (ELSE
 108                               <COND (<TYPE? .SY SYMTAB>
 109                                      <SET SY <NAME-SYM .SY>>)>
 110                               <SET-VALUE .SY <GEN .N DONT-CARE> <NOT .LCL>>)>)
 111                       (ELSE
 112                        <SET SL-LATER (.SYP !.SL-LATER)>
 113                        <SET NL-LATER (.N !.NL-LATER)>)>>
 114         .VARS
 115         .K>
 116        <COND (<AND .ANY-DONE <NOT <EMPTY? .SL-LATER>>>
 117               <SET VARS .SL-LATER>
 118               <SET K .NL-LATER>
 119               <AGAIN>)
 120              (<NOT <EMPTY? .SL-LATER>>
 121               <SET MUCH-LATER
 122                    ((<1 .SL-LATER> <SET TTMP <GEN-TEMP <>>>) !.MUCH-LATER)>
 123               <SET VARS ((.TTMP) !<REST .SL-LATER>)>
 124               <SET K .NL-LATER>
 125               <AGAIN>)>
 126        <MAPF <>
 127              <FUNCTION (L
 128                         "AUX" (SY:<OR ATOM SYMTAB> <1 <1 .L>>) (LCL <>)
 129                               (TMP:TEMP <2 .L>))
 130                      <COND (<AND <TYPE? .SY SYMTAB>
 131                                  <N==? <CODE-SYM .SY> -1>
 132                                  <SET LCL T>
 133                                  <NOT <SPEC-SYM .SY>>>
 134                             <IEMIT `SET <TEMP-NAME-SYM .SY> .TMP>
 135                             <FREE-TEMP .TMP>)
 136                            (ELSE
 137                             <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
 138                             <SET-VALUE .SY .TMP <NOT .LCL>>
 139                             <FREE-TEMP .TMP>)>>
 140              .MUCH-LATER>>)>
 141    <COND (<N==? .W FLUSHED>
 142           <SET LCL <>>
 143           <COND (<AND <TYPE? .VL SYMTAB>
 144                       <N==? <CODE-SYM .VL> -1>
 145                       <SET LCL T>
 146                       <NOT <SPEC-SYM .VL>>>
 147                  <TEMP-REFS .VL <+ <TEMP-REFS .VL> 1>>
 148                  <MOVE-ARG .VL .W>)
 149                 (ELSE
 150                  <COND (<TYPE? .VL SYMTAB> <SET VL <NAME-SYM .VL>>)>
 151                  <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <>>>)>
 152                  <GET-VALUE-X .VL .W <NOT .LCL>>)>)
 153          (ELSE .W)>>
 154
 155 <DEFINE REF? (SY:<OR ATOM SYMTAB> L:<LIST [REST NODE]>)
 156         <MAPF <>
 157               <FUNCTION (N:NODE "AUX" (NT:FIX <NODE-TYPE .N>))
 158                     <PROG ()
 159                           <COND (<OR <==? .NT ,LVAL-CODE>
 160                                      <==? .NT ,ASSIGNED?-CODE>
 161                                      <==? .NT ,SET-CODE>>
 162                                  <COND (<==? <NODE-NAME .N> .SY> <MAPLEAVE>)>)
 163                                 (<OR <==? .NT ,FLVAL-CODE> <==? .NT ,FSET-CODE>>
 164                                  <COND (<OR <==? <NODE-NAME .N> .SY>
 165                                             <COND (<==? <NODE-TYPE
 166                                                          <SET NN <1 <KIDS .N>>>>
 167                                                         ,QUOTE-CODE>
 168                                                    <==? <NODE-NAME .NN> .SY>)
 169                                                   (ELSE
 170                                                    <OR <TYPE? .SY ATOM>
 171                                                        <==? <CODE-SYM .SY> -1>
 172                                                        <SPEC-SYM .SY>>)>>
 173                                         <MAPLEAVE T>)>)
 174                                 (<AND <G? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
 175                                       <MEMQ ALL <SIDE-EFFECTS .N>>
 176                                       <OR <TYPE? .SY ATOM>
 177                                           <SPEC-SYM .SY>
 178                                           <==? <CODE-SYM .SY> -1>>>
 179                                  <MAPLEAVE T>)
 180                                 (ELSE
 181                                  <COND (<REF? .SY <KIDS .N>> <MAPLEAVE T>)>
 182                                  <COND (<==? .NT ,BRANCH-CODE>
 183                                         <SET NT <NODE-TYPE <SET N <PREDIC .N>>>>
 184                                         <AGAIN>)>)>>>
 185               .L>>
 186
 187 <DEFINE GEN-DISPATCH (N W)
 188         <CASE ,==?
 189               <NODE-TYPE .N>
 190               (,FORM-CODE <FORM-GEN .N .W>)
 191               (,PROG-CODE <PROG-REP-GEN .N .W>)
 192               (,SUBR-CODE <SUBR-GEN .N .W>)
 193               (,COND-CODE <COND-GEN .N .W>)
 194               (,LVAL-CODE <LVAL-GEN .N .W>)
 195               (,SET-CODE <SET-GEN .N .W>)
 196               (,OR-CODE <OR-GEN .N .W>)
 197               (,AND-CODE <AND-GEN .N .W>)
 198               (,RETURN-CODE <RETURN-GEN .N .W>)
 199               (,COPY-CODE <COPY-GEN .N .W>)
 200               (,AGAIN-CODE <AGAIN-GEN .N .W>)
 201               (,ARITH-CODE <ARITH-GEN .N .W>)
 202               (,RSUBR-CODE <SUBR-GEN .N .W>)
 203               (,0-TST-CODE <0-TEST .N .W>)
 204               (,NOT-CODE <NOT-GEN .N .W>)
 205               (,1?-CODE <1?-GEN .N .W>)
 206               (,TEST-CODE <TEST-GEN .N .W>)
 207               (,EQ-CODE <==-GEN .N .W>)
 208               (,TY?-CODE <TYPE?-GEN .N .W>)
 209               (,LNTH-CODE <LNTH-GEN .N .W>)
 210               (,MT-CODE <MT-GEN .N .W>)
 211               (,REST-CODE <REST-GEN .N .W>)
 212               (,NTH-CODE <NTH-GEN .N .W>)
 213               (,PUT-CODE <PUT-GEN .N .W>)
 214               (,PUTR-CODE <PUTREST-GEN .N .W>)
 215               (,FLVAL-CODE <FLVAL-GEN .N .W>)
 216               (,FSET-CODE <FSET-GEN .N .W>)
 217               (,FGVAL-CODE <FGVAL-GEN .N .W>)
 218               (,FSETG-CODE <FSETG-GEN .N .W>)
 219               (,MIN-MAX-CODE <MIN-MAX .N .W>)
 220               (,CHTYPE-CODE <CHTYPE-GEN .N .W>)
 221               (,FIX-CODE <FIX-GEN .N .W>)
 222               (,FLOAT-CODE <FLOAT-GEN .N .W>)
 223               (,ABS-CODE <ABS-GEN .N .W>)
 224               (,MOD-CODE <MOD-GEN .N .W>)
 225               (,ID-CODE <ID-GEN .N .W>)
 226               (,ASSIGNED?-CODE <ASSIGNED?-GEN .N .W>)
 227               (,BITL-CODE <BITLOG-GEN .N .W>)
 228               (,ISUBR-CODE <SUBR-GEN .N .W>)
 229               (,EOF-CODE <ID-GEN .N .W>)
 230               (,READ-EOF2-CODE <READ2-GEN .N .W>)
 231               (,READ-EOF-CODE <SUBR-GEN .N .W>)
 232               (,GET2-CODE <GET2-GEN .N .W>)
 233               (,GET-CODE <GET-GEN .N .W>)
 234               (,IPUT-CODE <SUBR-GEN .N .W>)
 235               (,MAP-CODE <MAPFR-GEN .N .W>)
 236               (,MARGS-CODE <MPARGS-GEN .N .W>)
 237               (,MAPLEAVE-CODE <MAPLEAVE-GEN .N .W>)
 238               (,MAPRET-STOP-CODE <MAPRET-STOP-GEN .N .W>)
 239               (,UNWIND-CODE <UNWIND-GEN .N .W>)
 240               (,GVAL-CODE <GVAL-GEN .N .W>)
 241               (,SETG-CODE <SETG-GEN .N .W>)
 242               (,MEMQ-CODE <MEMQ-GEN .N .W>)
 243               (,LENGTH?-CODE <LENGTH?-GEN .N .W>)
 244               (,FORM-F-CODE <FORM-F-GEN .N .W>)
 245               (,ALL-REST-CODE <ALL-REST-GEN .N .W>)
 246               (,COPY-LIST-CODE <LIST-BUILD .N .W>)
 247               (,PUT-SAME-CODE <PUT-GEN .N .W>)
 248               (,BACK-CODE <BACK-GEN .N .W>)
 249               (,TOP-CODE <TOP-GEN .N .W>)
 250               (,ROT-CODE <ROT-GEN .N .W>)
 251               (,LSH-CODE <LSH-GEN .N .W>)
 252               (,BIT-TEST-CODE <BIT-TEST-GEN .N .W>)
 253               (,CALL-CODE <CALL-GEN .N .W>)
 254               (,MONAD-CODE <MONAD?-GEN .N .W>)
 255               (,GASSIGNED?-CODE <GASSIGNED?-GEN .N .W>)
 256               (,APPLY-CODE <APPLY-GEN .N .W>)
 257               (,ADECL-CODE <ADECL-GEN .N .W>)
 258               (,MULTI-RETURN-CODE <MULTI-RETURN-GEN .N .W>)
 259               (,VALID-CODE <VALID-TYPE?-GEN .N .W>)
 260               (,TYPE-C-CODE <TYPE-C-GEN .N .W>)
 261               (,=?-STRING-CODE <=?-STRING-GEN .N .W>)
 262               (,CASE-CODE <CASE-GEN .N .W>)
 263               (,FGETBITS-CODE <FGETBITS-GEN .N .W>)
 264               (,FPUTBITS-CODE <FPUTBITS-GEN .N .W>)
 265               (,ISTRUC-CODE <ISTRUC-GEN .N .W>)
 266               (,ISTRUC2-CODE <ISTRUC-GEN .N .W>)
 267               (,STACK-CODE <STACK-GEN .N .W>)
 268               (,CHANNEL-OP-CODE <CHANNEL-OP-GEN .N .W>)
 269               (,ATOM-PART-CODE <ATOM-PART-GEN .N .W>)
 270               (,OFFSET-PART-CODE <OFFSET-PART-GEN .N .W>)
 271               (,PUT-GET-DECL-CODE <PUT-GET-DECL-GEN .N .W>)
 272               (,SUBSTRUC-CODE <SUBSTRUC-GEN .N .W>)
 273               (,MULTI-SET-CODE <MULTI-SET-GEN .N .W>)
 274               DEFAULT
 275               (<DEFAULT-GEN .N .W>)>>