mim/development/mim/mimc/newrep.mud

   1
   2 <PACKAGE "NEWREP">
   3
   4 <ENTRY PROG-REP-GEN RETURN-GEN AGAIN-GEN ACTIV? MULTI-RETURN-GEN>
   5
   6 <USE "COMPDEC" "CODGEN" "CHKDCL" "MIMGEN" "ADVMESS" "NOTGEN">
   7
   8 " Generate code for a poor innocent PROG or REPEAT."
   9
  10 "\f"
  11
  12 <DEFINE PROG-REP-GEN (PNOD PWHERE
  13                       "OPT" (NOTF <>) (BRANCH <>) (DIR <>)
  14                       "AUX" START-TAG (BASEF .BASEF) EXIT AGAIN (CD <>)
  15                             (DEST
  16                              <COND (<==? .PWHERE FLUSHED> FLUSHED)
  17                                    (<==? .PWHERE DONT-CARE> <GEN-TEMP <>>)
  18                                    (ELSE .PWHERE)>) (K <KIDS .PNOD>) TEM SPECD
  19                             (ORPNOD <AND <ASSIGNED? RPNOD> .RPNOD>) RPNOD
  20                             BNDTMP (OTMPS .TMPS) (OTMPS-NEXT .TMPS-NEXT)
  21                             (OFREE-TEMPS .FREE-TEMPS) RDEST
  22                             (RT <RESULT-TYPE <NTH .K <LENGTH .K>>>)
  23                             (FOK <TYPE-OK? .RT FALSE>)
  24                             (TRUE-OK <N==? <ISTYPE? .RT> FALSE>) (STK 0)
  25                             (STK-CHARS7 0) (STK-CHARS8 0) STKTMP)
  26    #DECL ((NTSLOTS STB) <SPECIAL LIST> (BASEF PNOD RPNOD) <SPECIAL NODE>
  27           (START-TAG) <SPECIAL ATOM> (K) <LIST [REST NODE]>
  28           (STK-CHARS7 STK-CHARS8 STK) <SPECIAL FIX> (STKTMP) <SPECIAL ANY>
  29           (SPECD) <SPECIAL ANY>)
  30    <COND (<AND <OR <ACTIVATED .PNOD> <ACTIV? <BINDING-STRUCTURE .PNOD>>>
  31                <TYPE? .DEST TEMP>>
  32           <USE-TEMP .DEST>)>
  33    <PROG ((TMPS .TMPS) (TMPS-NEXT .TMPS-NEXT) (FREE-TEMPS .FREE-TEMPS)
  34           (ALL-TEMPS-LIST .ALL-TEMPS-LIST) MYFRAME)
  35          #DECL ((TMPS-NEXT FREE-TEMPS ALL-TEMPS-LIST) <SPECIAL LIST>
  36                 (TMPS) <SPECIAL FORM>)
  37          <COND (<N==? <NODE-SUBR .PNOD> ,BIND> <SET RPNOD .PNOD>)
  38                (.ORPNOD <SET RPNOD .ORPNOD>)>
  39          <SET RDEST .DEST>
  40          <SET EXIT <MAKE-TAG "EXIT">>
  41          <COND (<OR <ACTIVATED .PNOD> <ACTIV? <BINDING-STRUCTURE .PNOD>>>
  42                 <PUT .PNOD ,ACTIVATED T>
  43                 <SET BASEF .PNOD>
  44                 <SET ALL-TEMPS-LIST
  45                      ((.TMPS .TMPS-NEXT .FREE-TEMPS <>) !.ALL-TEMPS-LIST)>
  46                 <COND (<==? .DEST FLUSHED> <IEMIT `ICALL .EXIT>)
  47                       (ELSE <IEMIT `ICALL .EXIT = .DEST>)>
  48                 <MIM-TEMPS-HOLD>
  49                 <MIM-TEMPS-EMIT>
  50                 <SET FREE-TEMPS ()>
  51                 <SET MYFRAME <GEN-TEMP>>
  52                 <PREV-FRAME .MYFRAME>
  53                 <PUT <1 .ALL-TEMPS-LIST> 4 .MYFRAME>
  54                 <COND (<NOT <==? .PWHERE FLUSHED>> <SET DEST <GEN-TEMP <>>>)>)>
  55          <SET SPECD
  56               <COND (<ACTIVATED .PNOD> <BIND-CODE .PNOD>)
  57                     (ELSE <BIND-CODE .PNOD T <SET BNDTMP <GEN-TEMP <>>>>)>>
  58          <SET BASEF .PNOD>
  59          <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
  60                 <IEMIT `LOOP>)>
  61          <LABEL-TAG <SET AGAIN <MAKE-TAG "AGAIN">>>
  62          <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
  63                 <IEMIT `INTGO>)>
  64          <COND (.NOTF <SET DIR <NOT .DIR>>)>
  65          <PUT .PNOD ,CDST <COND (.BRANCH (.BRANCH .DIR)) (ELSE ,NO-DATUM)>>
  66          <PUT .PNOD ,DST .DEST>
  67          <PUT .PNOD ,SPCS-X .SPECD>
  68          <PUT .PNOD ,ATAG .AGAIN>
  69          <PUT .PNOD ,RTAG .EXIT>
  70          <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
  71                 <COND (<==? <NODE-SUBR .PNOD> ,REPEAT>
  72                        <SET TEM <SEQ-GEN .K FLUSHED>>)
  73                       (<==? .DEST FLUSHED>
  74                        <COND (<AND .BRANCH .FOK .TRUE-OK>
  75                               <SET TEM <PSEQ-GEN .K FLUSHED .BRANCH .DIR <>>>)
  76                              (<AND .BRANCH <COND (.DIR .TRUE-OK) (ELSE .FOK)>>
  77                               <SET TEM <SEQ-GEN .K FLUSHED>>
  78                               <BRANCH-TAG .BRANCH>)
  79                              (ELSE <SET TEM <SEQ-GEN .K FLUSHED>>)>)
  80                       (ELSE
  81                        <SET TEM <SET CD <SEQ-GEN .K .DEST>>>
  82                        <COND (<==? .TEM ,NO-DATUM>
  83                               <COND (<EMPTY? <CDST .PNOD>> <SET CD ,NO-DATUM>)
  84                                     (ELSE <SET CD <CDST .PNOD>>)>)
  85                              (<==? <CDST .PNOD> ,NO-DATUM>
  86                               <PUT .PNOD ,CDST .CD>)>)>)
  87                (ELSE
  88                 <COND (<==? .DEST FLUSHED>
  89                        <COND (<AND .BRANCH .FOK .TRUE-OK>
  90                               <SET TEM <PSEQ-GEN .K FLUSHED .BRANCH .DIR <>>>)
  91                              (<AND .BRANCH <COND (.DIR .TRUE-OK) (ELSE .FOK)>>
  92                               <SET TEM <SEQ-GEN .K FLUSHED>>
  93                               <BRANCH-TAG .BRANCH>)
  94                              (ELSE <SET TEM <SEQ-GEN .K FLUSHED>>)>)
  95                       (ELSE
  96                        <SET TEM <SET CD <SEQ-GEN .K .DEST T>>>
  97                        <COND (<==? .TEM ,NO-DATUM>
  98                               <COND (<OR <EMPTY? <CDST .PNOD>>
  99                                          <==? <CDST .PNOD> ,NO-DATUM>>
 100                                      <SET CD ,NO-DATUM>)
 101                                     (ELSE <SET CD <CDST .PNOD>>)>)
 102                              (<==? <CDST .PNOD> ,NO-DATUM>
 103                               <PUT .PNOD ,CDST .CD>)>)>)>
 104          <COND (<NOT <ASSIGNED? NPRUNE>> <PUT .PNOD ,KIDS ()>)>
 105          <COND (<N==? <NODE-SUBR .PNOD> ,REPEAT>
 106                 <COND (<ACTIVATED .PNOD> <PROG-END .DEST> <FREE-TEMP .MYFRAME>)
 107                       (.SPECD <IEMIT `UNBIND .BNDTMP> <FREE-TEMP .BNDTMP>)>)
 108                (ELSE <BRANCH-TAG .AGAIN>)>
 109          <LABEL-TAG .EXIT>
 110          <COND (<N==? .STK-CHARS8 0>
 111                 <SET STK-CHARS8 <+ .STK-CHARS8 .STK>>
 112                 <SET STK-CHARS7 <+ .STK-CHARS7 .STK>>
 113                 <SET STK 0>)>
 114          <COND (<ACTIVATED .PNOD>)
 115                (ELSE
 116                 <COND (<ASSIGNED? STKTMP>
 117                        <COND (<N==? .STK 0>
 118                               <IEMIT `SUB .STKTMP .STK = .STKTMP (`TYPE FIX)>)
 119                              (<N==? .STK-CHARS7 0>
 120                               <IEMIT `IFSYS "TOPS20">
 121                               <IEMIT `SUB .STKTMP .STK-CHARS7 = .STKTMP>
 122                               <IEMIT `ENDIF "TOPS20">
 123                               <IEMIT `IFSYS "UNIX">
 124                               <IEMIT `SUB .STKTMP .STK-CHARS8 = .STKTMP>
 125                               <IEMIT `ENDIF "UNIX">)>
 126                        <IEMIT `ADJ .STKTMP>
 127                        <FREE-TEMP .STKTMP>)
 128                       (<N==? .STK 0> <IEMIT `ADJ <- .STK>>)
 129                       (<N==? .STK-CHARS8 0>
 130                        <IEMIT `IFSYS "TOPS20">
 131                        <IEMIT `ADJ <- .STK-CHARS7>>
 132                        <IEMIT `ENDIF "TOPS20">
 133                        <IEMIT `IFSYS "UNIX">
 134                        <IEMIT `ADJ <- .STK-CHARS8>>
 135                        <IEMIT `ENDIF "UNIX">)>
 136                 <SET OFREE-TEMPS .FREE-TEMPS>)>>
 137    <SET FREE-TEMPS .OFREE-TEMPS>
 138    <SET TMPS-NEXT <REST .TMPS <- <LENGTH .TMPS> 1>>>
 139    <COND (<OR <==? <CDST .PNOD> ,NO-DATUM> .BRANCH>
 140           <COND (<AND <ACTIVATED .PNOD> <N==? .PWHERE FLUSHED>>
 141                  <MOVE-ARG .RDEST .PWHERE>)
 142                 (ELSE ,NO-DATUM)>)
 143          (ELSE <MOVE-ARG .RDEST .PWHERE>)>>
 144
 145 <DEFINE PROG-END (RESULT)
 146         <COND (<==? .RESULT FLUSHED> <MIM-RETURN T>)
 147               (ELSE <MIM-RETURN .RESULT>)>>
 148
 149 <DEFINE ACTIV? (BST)
 150         #DECL ((BST) <LIST [REST SYMTAB]>)
 151         <REPEAT ()
 152                 <COND (<EMPTY? .BST> <RETURN <>>)>
 153                 <COND (<AND <==? <CODE-SYM <1 .BST>> ,ARGL-ACT>
 154                             <OR <NOT <RET-AGAIN-ONLY <1 .BST>>>
 155                                 <SPEC-SYM <1 .BST>>>>
 156                        <RETURN T>)>
 157                 <SET BST <REST .BST>>>>
 158
 159 "\f"
 160
 161 " Generate code for a RETURN."
 162
 163 <DEFINE RETURN-GEN (NOD WHERE
 164                     "AUX" N NN (CD1 <>) DEST (NF 0) LL RT (FOK <>) RTA)
 165    #DECL ((NOD N RPNOD) NODE (NF) FIX)
 166    <PROG ()
 167      <COND (<1? <LENGTH <KIDS .NOD>>> <SET N .RPNOD>)
 168            (<SET NN <RET-AGAIN-ONLY <NODE-NAME <2 <KIDS .NOD>>>>> <SET N .NN>)
 169            (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
 170      <SET RTA <RTAG .N>>
 171      <COND
 172       (<==? <SET DEST <DST .N>> FLUSHED>
 173        <COND
 174         (<AND <TYPE? <SET LL <CDST .N>> LIST> <N==? .LL ,NO-DATUM>>
 175          <COND
 176           (<AND <TYPE-OK? <SET RT <RESULT-TYPE <SET NN <1 <KIDS .NOD>>>>>
 177                           FALSE>
 178                 <SET FOK T>
 179                 <N==? <ISTYPE? .RT> FALSE>>
 180            <PRED-BRANCH-GEN <1 .LL> .NN <2 .LL> FLUSHED <>>)
 181           (<COND (<2 .LL> <NOT .FOK>) (ELSE .FOK)>
 182            <COND (<N==? <NODE-TYPE .NN> ,QUOTE-CODE> <GEN .NN FLUSHED>)>
 183            <SET RTA <1 .LL>>)
 184           (<N==? <NODE-TYPE .NN> ,QUOTE-CODE> <GEN .NN FLUSHED>)>)
 185         (ELSE <GEN <1 <KIDS .NOD>> FLUSHED>)>)
 186       (ELSE
 187        <COND (<==? .DEST DONT-CARE> <SET DEST <GEN-TEMP <>>>)>
 188        <SET CD1 <GEN <1 <KIDS .NOD>> .DEST>>
 189        <COND (<==? <DST .N> DONT-CARE> <PUT .N ,DST .CD1>)>
 190        <COND (<N==? <CDST .N> ,NO-DATUM> <DEALLOCATE-TEMP .CD1>)>
 191        <PUT .N ,CDST .CD1>)>
 192      <COND (<ACTIVATED .N> <PROG-END .DEST>)
 193            (ELSE
 194             <COND (<SPCS-X .N> <IEMIT `UNBIND <SPCS-X .N>>)>
 195             <BRANCH-TAG .RTA>)>
 196      ,NO-DATUM>>
 197
 198 <DEFINE MULTI-RETURN-GEN (NOD WHERE
 199                           "AUX" (K <KIDS .NOD>) NN (CD1 <>) DEST FTMP
 200                                 (N <1 .K>) (LOCAL <>) FR SEGTMP (I 0))
 201    #DECL ((NOD N RPNOD) NODE)
 202    <PROG ()
 203      <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 204             <SET LOCAL T>
 205             <SET N .RPNOD>
 206             <COND (<ASSIGNED? SEGLABEL> <SET FTMP .COUNTMP>)>)
 207            (<AND <==? <NODE-TYPE .N> ,LVAL-CODE>
 208                  <SET NN <RET-AGAIN-ONLY <NODE-NAME .N>>>>
 209             <SET N .NN>
 210             <SET FR 0>)
 211            (ELSE <SET FR <GEN .N DONT-CARE>>)>
 212      <MAPF <>
 213            <FUNCTION (N)
 214                    #DECL ((N) NODE)
 215                    <COND (<N==? <NODE-TYPE .N> ,SEGMENT-CODE>
 216                           <SET I <+ .I 1>>)>>
 217            <REST .K>>
 218      <MAPF <>
 219       <FUNCTION (NOD "AUX" TG STYP N TT)
 220               #DECL ((NOD) NODE)
 221               <COND (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
 222                      <COND (<NOT <ASSIGNED? SEGTMP>>
 223                             <COND (<ASSIGNED? FTMP>
 224                                    <COND (<N==? .I 0>
 225                                           <IEMIT `ADD .FTMP .I = .FTMP>)>)
 226                                   (ELSE
 227                                    <SET FTMP <GEN-TEMP>>
 228                                    <IEMIT `SET .FTMP .I>)>
 229                             <SET SEGTMP <GEN-TEMP <>>>)>
 230                      <SET STYP <STRUCTYP-SEG
 231                                 <RESULT-TYPE <SET N <1 <KIDS .NOD>>>>>>
 232                      <COND (.LOCAL
 233                             <GEN .N .SEGTMP>
 234                             <SEGMENT-STACK
 235                              .SEGTMP
 236                              .FTMP
 237                              .STYP
 238                              <ISTYPE? <RESULT-TYPE .N>>>)
 239                            (ELSE
 240                             <PROG ((SEGLABEL <MAKE-TAG>) (COUNTMP .FTMP)
 241                                    (SEGCALLED <>) RES)
 242                                   #DECL ((SEGLABEL COUNTMP SEGCALLED)
 243                                          <SPECIAL ANY>)
 244                                   <SET RES <GEN .N .SEGTMP>>
 245                                   <COND (<OR <N==? .RES ,NO-DATUM>
 246                                              <N==? .STYP MULTI>>
 247                                          <SEGMENT-STACK .SEGTMP
 248                                                         .COUNTMP
 249                                                         .STYP
 250                                                         <ISTYPE? <RESULT-TYPE .N>>
 251                                                         .SEGLABEL>)
 252                                         (.SEGCALLED
 253                                          <LABEL-TAG .SEGLABEL>)>>)>)
 254                     (ELSE <GEN .NOD ,POP-STACK>)>>
 255       <REST .K>>
 256      <COND (<AND .LOCAL
 257                  <OR <==? <SET DEST <DST .N>> FLUSHED>
 258                      <NOT <ASSIGNED? SEGLABEL>>>>
 259             <COMPILE-ERROR "MULTI-RETURN to nothing" .NOD>)
 260            (<AND .LOCAL <ASSIGNED? SEGLABEL>>
 261             <COND (<NOT <ASSIGNED? SEGTMP>> <IEMIT `SET .FTMP .I>)>
 262             <COND (<SPCS-X .N> <IEMIT `UNBIND <SPCS-X .N>>)>
 263             <BRANCH-TAG .SEGLABEL>)
 264            (ELSE
 265             <IEMIT `MRETURN <COND (<ASSIGNED? FTMP> .FTMP) (ELSE .I)> .FR>)>
 266      ,NO-DATUM>>
 267
 268 "\f"
 269
 270 " Generate code for an AGAIN."
 271
 272 <DEFINE AGAIN-GEN (NOD WHERE "AUX" N NN)
 273         #DECL ((NOD N RPNOD) NODE)
 274         <PROG ()
 275               <COND (<EMPTY? <KIDS .NOD>> <SET N .RPNOD>)
 276                     (<SET NN <RET-AGAIN-ONLY <NODE-NAME <1 <KIDS .NOD>>>>>
 277                      <SET N .NN>)
 278                     (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
 279               <BRANCH-TAG <ATAG .N>>
 280               ,NO-DATUM>>
 281
 282 <DEFINE UNBIND-LOCS () T>
 283
 284 <ENDPACKAGE>