mim/development/mim/mimc/bitsgen.mud

   1
   2 <PACKAGE "BITSGEN">
   3
   4 <ENTRY BITLOG-GEN FGETBITS-GEN FPUTBITS-GEN>
   5
   6 <USE "COMPDEC" "CODGEN" "CHKDCL" "MIMGEN">
   7
   8 <DEFINE FGETBITS-GEN (N W "AUX" (K <KIDS .N>) REG S WI)
   9         #DECL ((N) NODE (K) <LIST [REST NODE]>)
  10         <SET REG <GEN <1 .K>>>
  11         <SET S <GEN <2 .K>>>
  12         <FREE-TEMP <SET WI <GEN <3 .K>>> <>>
  13         <FREE-TEMP .S <>>
  14         <IEMIT `GETBITS
  15                .REG
  16                .S
  17                .WI
  18                =
  19                <COND (<N==? .W DONT-CARE>
  20                       <FREE-TEMP .REG <>>
  21                       <COND (<TYPE? .W TEMP> <USE-TEMP .W FIX>)>
  22                       .W)
  23                      (<AND <TYPE? .REG TEMP> <L=? <TEMP-REFS .REG> 1>>
  24                       <SET W .REG>)
  25                      (ELSE <FREE-TEMP .REG <>> <SET W <GEN-TEMP>>)>>
  26         .W>
  27
  28 <DEFINE FPUTBITS-GEN (N W
  29                       "AUX" (K <KIDS .N>) REG S WI F
  30                             (TY <ISTYPE? <RESULT-TYPE .N>>))
  31         #DECL ((N) NODE (K) <LIST [REST NODE]>)
  32         <SET REG <GEN <1 .K>>>
  33         <SET S <GEN <2 .K>>>
  34         <SET WI <GEN <3 .K>>>
  35         <FREE-TEMP <SET F <GEN <4 .K>>> <>>
  36         <FREE-TEMP .S <>>
  37         <FREE-TEMP .WI <>>
  38         <IEMIT `PUTBITS
  39                .REG
  40                .S
  41                .WI
  42                .F
  43                =
  44                <COND (<N==? .W DONT-CARE>
  45                       <FREE-TEMP .REG <>>
  46                       <COND (<TYPE? .W TEMP> <USE-TEMP .W .TY>)>
  47                       .W)
  48                      (<AND <TYPE? .REG TEMP> <L=? <TEMP-REFS .REG> 1>>
  49                       <SET W .REG>)
  50                      (ELSE
  51                       <FREE-TEMP .REG <>>
  52                       <SET W <GEN-TEMP <COND (.TY) (T)>>>)>>
  53         .W>
  54
  55 <DEFINE BITLOG-GEN (N W
  56                     "AUX" (K <KIDS .N>) (FST <1 .K>)
  57                           (INS <LGINS <NODE-SUBR .N>>) REG)
  58         #DECL ((FST N) NODE (K) <LIST [REST NODE]>)
  59         <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
  60                <PUT .K 1 <2 .K>>
  61                <PUT .K 2 .FST>)>
  62         <SET REG <GEN <1 .K>>>
  63         <MAPR <>
  64               <FUNCTION (NP "AUX" (NN <1 .NP>) (NXT <GEN .NN DONT-CARE>) TT
  65                                   (LAST <EMPTY? <REST .NP>>))
  66                       #DECL ((NN) NODE (NP) <LIST NODE>)
  67                       <IEMIT .INS
  68                              .REG
  69                              .NXT
  70                              =
  71                              <COND (<AND .LAST <OR <TYPE? .W TEMP>
  72                                                    <==? .W ,POP-STACK>>>
  73                                     <COND (<N==? .W .REG>
  74                                            <FREE-TEMP .REG <>>
  75                                            <COND (<TYPE? .W TEMP>
  76                                                   <USE-TEMP .W FIX>)>)>
  77                                     <SET REG .W>)
  78                                    (<AND .LAST
  79                                          <==? .W DONT-CARE>
  80                                          <TYPE? .REG TEMP>
  81                                          <L=? <TEMP-REFS .REG> 1>> .REG)
  82                                    (<OR <NOT <TYPE? .REG TEMP>>
  83                                         <G? <TEMP-REFS .REG> 1>>
  84                                     <COND (<TYPE? .REG TEMP>
  85                                            <FREE-TEMP .REG <>>)>
  86                                     <SET REG <GEN-TEMP FIX>>)
  87                                    (ELSE .REG)>>
  88                       <FREE-TEMP .NXT>>
  89               <REST .K>>
  90         <MOVE-ARG .REG .W>>
  91
  92 <DEFINE LGINS (SUBR)
  93         <NTH '[`AND `OR `XOR `EQV]
  94              <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
  95
  96 <SETG LSUBRS [,EQVB ,XORB ,ORB ,ANDB]>
  97
  98 <GDECL (LSUBRS) VECTOR>
  99
 100 <ENDPACKAGE>