mim/development/mim/mimc/buildl.mud

   1
   2 <PACKAGE "BUILDL">
   3
   4 <ENTRY LIST-BUILD>
   5
   6 <USE "COMPDEC" "CODGEN" "CHKDCL" "ADVMESS" "MIMGEN" "STRGEN">
   7
   8 <DEFINE LIST-BUILD (NOD W
   9                     "AUX" (K <KIDS .NOD>) (KK ()) N TEM TT T1 D1 D2 D3
  10                           (OOPSF <>) TG1 TG2 (SUGGEST DONT-CARE))
  11    #DECL ((K KK) <LIST [REST NODE]> (N NOD) NODE)
  12    <COND (<AND <TYPE? .W TEMP> <==? <TEMP-REFS .W> 0>> <SET SUGGEST .W>)>
  13    <COND
  14     (<OR
  15       <AND <==? <LENGTH .K> 1> <SET KK .K>>
  16       <MAPF <>
  17             <FUNCTION (N)
  18                     #DECL ((N) NODE)
  19                     <COND (<AND <G=? <LENGTH .N>
  20                                      <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
  21                                 <SIDE-EFFECTS .N>>
  22                            <MAPLEAVE <>>)
  23                           (ELSE <SET KK (.N !.KK)> T)>>
  24             .K>>
  25      <COND
  26       (<AND <==? <NODE-TYPE <SET N <1 .KK>>> ,SEG-CODE>
  27             <==? <STRUCTYP <RESULT-TYPE <SET N <1 <KIDS .N>>>>>
  28                  LIST>>
  29        <SET TEM <GEN .N>>
  30        <SET KK <REST .KK>>)
  31       (ELSE <SET TEM <REFERENCE ()>>)>
  32      <MAPR <>
  33       <FUNCTION (NL "AUX" (N <1 .NL>))
  34               #DECL ((NL) <LIST NODE> (N) NODE)
  35               <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
  36                      <SET TEM <SEG-BUILD-LIST <1 <KIDS .N>> .TEM <> <> <>>>)
  37                     (ELSE
  38                      <FREE-TEMP <SET T1 <GEN .N>> <>>
  39                      <COND (<AND <N==? .TEM .W> <N==? .TEM .SUGGEST>>
  40                             <FREE-TEMP .TEM <>>)
  41                            (ELSE <DEALLOCATE-TEMP .TEM>)>
  42                      <IEMIT `CONS
  43                             <ATOMCHK .T1>
  44                             .TEM
  45                             =
  46                             <SET TEM
  47                                  <COND (<AND <EMPTY? <REST .NL>>
  48                                              <N==? .W DONT-CARE>>
  49                                         <COND (<TYPE? .W TEMP>
  50                                                <USE-TEMP .W LIST>)>
  51                                         .W)
  52                                        (<TYPE? .SUGGEST TEMP>
  53                                         <USE-TEMP .SUGGEST LIST>
  54                                         .SUGGEST)
  55                                        (ELSE <GEN-TEMP LIST>)>>>)>>
  56       .KK>
  57      <MOVE-ARG .TEM .W>)
  58     (ELSE
  59      <COND (<==? <NODE-TYPE <SET N <1 .K>>> ,SEG-CODE>
  60             <SET TEM <SEG-BUILD-LIST <1 <KIDS .N>> <REFERENCE ()> T T <>>>
  61             <SET D3 <2 .TEM>>
  62             <SET D2 <1 .TEM>>
  63             <SET OOPSF <3 .TEM>>)
  64            (ELSE
  65             <SET D1 <GEN .N DONT-CARE>>
  66             <FREE-TEMP .D1 <>>
  67             <IEMIT `CONS
  68                    <ATOMCHK .D1>
  69                    ()
  70                    =
  71                    <SET D2
  72                         <SET D3
  73                              <COND (<TYPE? .SUGGEST TEMP>
  74                                     <USE-TEMP .SUGGEST LIST>
  75                                     .SUGGEST)
  76                                    (ELSE <GEN-TEMP LIST>)>>>>)>
  77      <MAPR <>
  78       <FUNCTION (L "AUX" (N <1 .L>))
  79          #DECL ((N) NODE)
  80          <COND
  81           (<==? <NODE-TYPE .N> ,SEG-CODE>
  82            <COND
  83             (<AND
  84               <==? <STRUCTYP <RESULT-TYPE <SET N <1 <KIDS .N>>>>>
  85                    LIST>
  86               <EMPTY? <REST .L>>>
  87              <SET D1 <GEN .N DONT-CARE>>
  88              <COND (.OOPSF <EMPTY-LIST .D3 <SET TG1 <MAKE-TAG>> T>)>
  89              <IEMIT `PUTREST .D3 .D1>
  90              <COND (.OOPSF
  91                     <LABEL-TAG .TG1>
  92                     <EMPTY-LIST .D3 <SET TG1 <MAKE-TAG>> <>>
  93                     <SET-TEMP .D2 .D1>
  94                     <LABEL-TAG .TG1>)>
  95              <FREE-TEMP .D1>)
  96             (ELSE <SET D3 <SEG-BUILD-LIST .N .D3 T <> <COND (.OOPSF .D2)>>>)>)
  97           (ELSE
  98            <FREE-TEMP <SET D1 <GEN .N DONT-CARE>> <>>
  99            <IEMIT `CONS <ATOMCHK .D1> () = <SET D1 <GEN-TEMP LIST>>>
 100            <COND (.OOPSF <EMPTY-LIST .D3 <SET TG1 <MAKE-TAG>> T>)>
 101            <IEMIT `PUTREST .D3 .D1>
 102            <COND (.OOPSF
 103                   <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 104                   <LABEL-TAG .TG1>
 105                   <SET-TEMP .D2 .D1>
 106                   <LABEL-TAG .TG2>)
 107                  (ELSE
 108                   <COND (<N==? .D3 .D2> <FREE-TEMP .D3>)>
 109                   <SET D3 .D1>)>)>>
 110       <REST .K>>
 111      <COND (<N==? .D2 .D3> <FREE-TEMP .D3>)>
 112      <MOVE-ARG .D2 .W>)>>
 113
 114 <DEFINE SEG-BUILD-LIST (NOD DAT FLG FST SMQ
 115                         "AUX" (TYP <RESULT-TYPE .NOD>) (TG2 <MAKE-TAG>)
 116                               (ITYP <ISTYPE? .TYP>)
 117                               (TPS <STRUCTYP .TYP>)
 118                               (ET <GET-ELE-TYPE .TYP ALL>)
 119                               (ML <MINL .TYP>) TG3 TG4
 120                               (TG1 <MAKE-TAG>) TEM D1 (D3 .DAT) FDAT)
 121         #DECL ((NOD) NODE)
 122         <COND (<TYPE? .D3 TEMP> <USE-TEMP .D3 LIST>)>
 123         <SET ET <ISTYPE-GOOD? .ET>>
 124         <SET D1 <GEN .NOD <GEN-TEMP <>>>>
 125         <COND (<OR .FST <NOT .FLG>>
 126                <COND (<0? .ML>
 127                       <SET DAT <MOVE-ARG .DAT <GEN-TEMP <>>>>
 128                       <MT-TEST .D1 .TG1 .TPS .ITYP>)
 129                      (ELSE <SET DAT <GEN-TEMP>>)>
 130                <NTH-DO .TPS .D1 <SET TEM <GEN-TEMP>> 1>
 131                <FREE-TEMP .TEM <>>
 132                <IEMIT `CONS .TEM .D3 = <SET FDAT <GEN-TEMP LIST>>>
 133                <SET-TEMP .DAT .FDAT>
 134                <FREE-TEMP .DAT>)
 135               (ELSE <SET-TEMP <SET FDAT <GEN-TEMP <>>> .DAT>)>
 136         <COND (<OR .FST <NOT .FLG>> <SET D1 <1REST .D1 .TPS>>)>
 137         <COND (<L=? .ML 1> <MT-TEST .D1 .TG1 .TPS .ITYP>)>
 138         <IEMIT `LOOP
 139                <COND (<NOT .TPS> (<TEMP-NAME .D1> TYPE VALUE LENGTH))
 140                      (<==? .TPS LIST> (<TEMP-NAME .D1> VALUE))
 141                      (ELSE (<TEMP-NAME .D1> VALUE LENGTH))>
 142                (<TEMP-NAME .FDAT> VALUE)
 143                !<COND (<AND <NOT .FLG> <TYPE? .D3 TEMP>>
 144                        ((<TEMP-NAME .D3> VALUE)))
 145                       (ELSE ())>>
 146         <LABEL-TAG .TG2>
 147         <NTH-DO .TPS .D1 <SET TEM <GEN-TEMP>> 1>
 148         <IEMIT `CONS .TEM <COND (.FLG ()) (ELSE .D3)> = .TEM>
 149         <COND (.SMQ <EMPTY-LIST .FDAT <SET TG3 <MAKE-TAG>> T>)>
 150         <IEMIT `PUTREST .FDAT .TEM>
 151         <COND (.SMQ
 152                <BRANCH-TAG <SET TG4 <MAKE-TAG>>>
 153                <LABEL-TAG .TG3>
 154                <EMPTY-LIST .FDAT .TG4 <>>
 155                <SET-TEMP .SMQ .TEM>)>
 156         <SET-TEMP .FDAT .TEM>
 157         <FREE-TEMP .FDAT>
 158         <FREE-TEMP .TEM>
 159         <REST-N-JMP .D1 .TPS .TG2 .D1 .ITYP>
 160         <LABEL-TAG .TG1>
 161         <FREE-TEMP .D1>
 162         <COND (<AND .FLG .FST> (.DAT .FDAT <0? .ML>))
 163               (.FLG .FDAT)
 164               (ELSE <FREE-TEMP .FDAT> .DAT)>>
 165
 166 <DEFINE MT-TEST (D TG TP TYP)
 167         #DECL ((TP) ATOM)
 168         <EMPTY-CHECK .TP .D .TYP T .TG>>
 169
 170 <DEFINE 1REST (D TP) #DECL ((TP) ATOM) <REST-DO .TP .D .D 1> .D>
 171
 172 <DEFINE REST-N-JMP (D TP TG D1 TYP)
 173         <REST-DO .TP .D .D1 1>
 174         <EMPTY-CHECK .TP .D .TYP <> .TG>
 175         T>
 176
 177 <ENDPACKAGE>