mim/development/mim/mimc/casecomp.mud

   1
   2 <PACKAGE "CASECOMP">
   3
   4 <ENTRY CASE-GEN>
   5
   6 <USE "CODGEN" "MIMGEN" "CHKDCL" "COMPDEC" "SORTX">
   7
   8 <SETG MAX-DENSE 2>
   9
  10 <DEFINE CASE-GEN (N W
  11                   "AUX" (K <KIDS .N>) (P <NODE-NAME <1 <KIDS <1 .K>>>>)
  12                         (N1 <2 .K>) (SKIP-CH <>) (RW .W) (LNT 0) (DF <>) DN
  13                         (DFT <MAKE-TAG "CASEDF">) MI MX RNGS (TAGS (X)) LLABS
  14                         LABS (ET <MAKE-TAG "CASEND">) NOW (WSET <>) LOCN DAC TG
  15                         TT W2 (FIRST T) S1 (S2 ()) TNUM LRT)
  16    #DECL ((N DN N1) NODE (P) ATOM (RNGS) UVECTOR)
  17    <SET TT <ISTYPE? <RESULT-TYPE .N1>>>
  18    <COND (<OR <==? .W ,POP-STACK>
  19               <AND <TYPE? .W TEMP>
  20                    <TEMP-NO-RECYCLE .W>
  21                    <N==? <TEMP-NO-RECYCLE .W> ANY>>>
  22           <SET W DONT-CARE>)>
  23    <SET K
  24         <MAPR ,LIST
  25               <FUNCTION (NP "AUX" (N <1 .NP>))
  26                       #DECL ((N) NODE)
  27                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
  28                              <SET DF T>
  29                              <MAPRET>)>
  30                       <COND (.DF <SET DN .N> <SET DF <>> <MAPRET>)>
  31                       <COND (<==? <RESULT-TYPE .N> FALSE>
  32                              <COMPILE-NOTE "Case phrase always false " .N>
  33                              <MAPRET>)>
  34                       <COND (<AND <==? <RESULT-TYPE .N> ATOM>
  35                                   <NOT <EMPTY? <REST .NP>>>>
  36                              <COMPILE-NOTE "Non reachable CASE clauses "
  37                                            <2 .NP>>
  38                              (.N () FOO))>
  39                       (.N () FOO)>
  40               <REST .K 2>>>
  41    <SET LNT
  42     <LENGTH
  43      <SET RNGS
  44       <MAPF ,UVECTOR
  45        <FUNCTION (L "AUX" (N <1 .L>) (NN <NODE-NAME <PREDIC .N>>))
  46           #DECL ((N) NODE)
  47           <PUT .L 3 <MAKE-TAG "CASE">>
  48           <COND
  49            (<==? .P ==?>
  50             <COND (<TYPE? .NN LIST>
  51                    <MAPR <> <FUNCTION (L) <PUT .L 1 <FIX <1 .L>>>> .NN>)
  52                   (ELSE <SET NN <CHTYPE .NN FIX>>)>)
  53            (<==? .P TYPE?>
  54             <COND (<TYPE? .NN LIST>
  55                    <MAPR <>
  56                          <FUNCTION (L "AUX" TT)
  57                                  <COND (<G? <SET TT <CHTYPE <1 .L> FIX>> ,PMAX>
  58                                         <SET SKIP-CH T>)>
  59                                  <PUT .L 1 .TT>>
  60                          .NN>)
  61                   (ELSE
  62                    <COND (<G? <SET NN <CHTYPE <TYPE-C .NN> FIX>> ,PMAX>
  63                           <SET SKIP-CH T>)>
  64                    .NN)>)
  65            (<TYPE? .NN LIST>
  66             <MAPR <>
  67                   <FUNCTION (L) <PUT .L 1 <CHTYPE <PTYPE-C <1 .L>> FIX>>>
  68                   .NN>)
  69            (ELSE <SET NN <CHTYPE <PTYPE-C .NN> FIX>>)>
  70           <COND (<TYPE? .NN LIST> <PUT .L 2 .NN> <MAPRET !.NN>)
  71                 (ELSE <PUT .L 2 (.NN)> .NN)>>
  72        .K>>>>
  73    <SORT <> .RNGS>
  74    <SET TNUM <1 .RNGS>>
  75    <COND (<L=? .LNT 3> <SET SKIP-CH T>)
  76          (<G? <- <SET MX <NTH .RNGS .LNT>> <SET MI .TNUM>>
  77               <* .LNT ,MAX-DENSE>>
  78           <SET SKIP-CH T>)>
  79    <MAPF <>
  80          <FUNCTION (NUM)
  81                  <COND (<==? .NUM .TNUM>
  82                         <COMPILE-ERROR "Duplicate case entry " .N>)>
  83                  <SET TNUM .NUM>>
  84          <REST .RNGS>>
  85    <SET W2 <GEN .N1 DONT-CARE>>
  86    <COND
  87     (<==? .P ==?>
  88      <COND
  89       (<NOT <ISTYPE? <RESULT-TYPE .N1>>>
  90        <GEN-TYPE?
  91         .W2
  92         <TYPE <COND (<TYPE? <SET TT <NODE-NAME <PREDIC <1 <1 .K>>>>> LIST>
  93                      <1 .TT>)
  94                     (ELSE .TT)>>
  95         .DFT
  96         <>>)>)
  97     (<==? .P TYPE?>)
  98     (ELSE)>
  99    <COND
 100     (<NOT .SKIP-CH>
 101      <SET NOW <+ .MI 1>>
 102      <SET LLABS <SET LABS (.MI)>>
 103      <REPEAT ()
 104              <COND (<EMPTY? .RNGS> <RETURN>)>
 105              <COND (<N==? .NOW <+ <1 .RNGS> 1>>
 106                     <SET NOW <+ .NOW 1>>
 107                     <PUTREST .LLABS <SET LLABS (.DFT)>>)
 108                    (ELSE
 109                     <PUTREST .LLABS <SET LLABS (<DOTAGS <1 .RNGS> .K>)>>
 110                     <SET NOW <+ .NOW 1>>
 111                     <SET RNGS <REST .RNGS>>)>>
 112      <IEMIT `DISPATCH .W2 !.LABS>
 113      <LABEL-TAG .DFT>
 114      <COND (<ASSIGNED? DN>
 115             <SET LOCN <SEQ-GEN <KIDS .DN> .W>>
 116             <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
 117                    <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 118                    <SET WSET T>)>
 119             <COND (<OR <N==? <RESULT-TYPE .DN> NO-RETURN>
 120                        <N==? .LOCN ,NO-DATUM>>
 121                    <BRANCH-TAG .ET>)>)
 122            (ELSE
 123             <COND (<N==? .W FLUSHED>
 124                    <SET LOCN <MOVE-ARG <REFERENCE <>> .W>>
 125                    <COND (<AND <NOT .WSET>
 126                                <N==? .LOCN ,NO-DATUM>
 127                                <N==? .W FLUSHED>>
 128                           <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 129                           <SET WSET T>)>)>
 130             <BRANCH-TAG .ET>)>
 131      <MAPF <>
 132       <FUNCTION (L "AUX" (N <1 .L>) (TG <3 .L>))
 133          <COND (<AND <NOT .FIRST> <N==? .LRT NO-RETURN>> <BRANCH-TAG .ET>)
 134                (ELSE <SET FIRST <>>)>
 135          <SET LRT <RESULT-TYPE .N>>
 136          <LABEL-TAG .TG>
 137          <COND
 138           (<NOT <EMPTY? <KIDS .N>>>
 139            <SET LOCN <SEQ-GEN <KIDS .N> .W>>
 140            <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
 141                   <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 142                   <SET WSET T>)>)
 143           (<N==? .W FLUSHED>
 144            <SET LOCN
 145                 <MOVE-ARG
 146                  <REFERENCE <COND (<==? .P ==?> T)
 147                                   (ELSE <NODE-NAME <PREDIC .N>>)>>
 148                  .W>>
 149            <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
 150                   <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 151                   <SET WSET T>)>)>>
 152       .K>)
 153     (ELSE
 154      <REPEAT (L KK) #DECL ((KK L) LIST)
 155              <COND (<EMPTY? .K> <RETURN>)>
 156              <DISTAG <2 <SET L <1 .K>>> .W2 <SET TG <3 .L>>>
 157              <COND (<NOT <EMPTY? <SET KK <KIDS <1 .L>>>>>
 158                     <SET LOCN <SEQ-GEN .KK .W>>)
 159                    (<N==? .W FLUSHED> <SET LOCN <MOVE-ARG <REFERENCE T> .W>>)>
 160              <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
 161                     <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 162                     <SET WSET T>)>
 163              <COND (<AND <NOT <EMPTY? .KK>>
 164                          <N==? <RESULT-TYPE <NTH .KK <LENGTH .KK>>> NO-RETURN>>
 165                     <BRANCH-TAG .ET>)>
 166              <LABEL-TAG .TG>
 167              <SET K <REST .K>>>
 168      <COND (<ASSIGNED? DN> <SET LOCN <SEQ-GEN <KIDS .DN> .W>>)
 169            (ELSE <SET LOCN <MOVE-ARG <REFERENCE <>> .W>>)>
 170      <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
 171             <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 172             <SET WSET T>)>)>
 173    <LABEL-TAG .ET>
 174    <MOVE-ARG .W .RW>>
 175
 176 <DEFINE DOTAGS (N L)
 177         #DECL ((N) FIX (L) <LIST [REST <LIST NODE <LIST [REST FIX]> ATOM>]>)
 178         <MAPF <>
 179               <FUNCTION (LL) <COND (<MEMQ .N <2 .LL>> <MAPLEAVE <3 .LL>>)>>
 180               .L>>
 181
 182 <DEFINE DISTAG (L DAC ATM "AUX" TG)
 183         #DECL ((L) <LIST [REST FIX]> (ATM) ATOM)
 184         <COND (<G=? <LENGTH .L> 2> <SET TG <MAKE-TAG>>)>
 185         <REPEAT ()
 186                 <COND (<EMPTY? .L>
 187                        <BRANCH-TAG .ATM>
 188                        <AND <ASSIGNED? TG> <LABEL-TAG .TG>>
 189                        <RETURN>)
 190                       (<EMPTY? <REST .L>>
 191                        <IEMIT `VEQUAL? .DAC <1 .L> - .ATM>
 192                        <AND <ASSIGNED? TG> <LABEL-TAG .TG>>
 193                        <RETURN>)
 194                       (ELSE <IEMIT `VEQUAL? .DAC <1 .L> + .TG>)>
 195                 <SET L <REST .L 1>>>>
 196
 197 <DEFINE PTYPE-C (ATM) <PRIM-CODE <TYPE-C .ATM>>>
 198
 199 <DEFINE FIXUP-TEMP (W LOCN)
 200         <COND (<AND <TYPE? .LOCN TEMP> <L=? <TEMP-REFS .LOCN> 1>> .LOCN)
 201               (<==? .LOCN .W> .LOCN)
 202               (ELSE <MOVE-ARG .LOCN <GEN-TEMP <>>>)>>
 203
 204 <ENDPACKAGE>