mim/development/mim/mimc/bitsana.mud

   1
   2 <PACKAGE "BITSANA">
   3
   4 <ENTRY FGETBITS-ANA FPUTBITS-ANA BITLOG>
   5
   6 <USE "SYMANA" "CHKDCL" "COMPDEC">
   7
   8 "MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
   9
  10 <DEFINE FGETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 3 ,FGETBITS-CODE>>
  11
  12 <COND (<AND <GASSIGNED? FGETBITS>
  13             <GASSIGNED? FGETBITS-ANA>>
  14        <PUTPROP ,FGETBITS ANALYSIS ,FGETBITS-ANA>)>
  15
  16 <DEFINE FPUTBITS-ANA (N R) <PGBITS .N .R 4 ,FPUTBITS-CODE>>
  17
  18 <COND (<AND <GASSIGNED? FPUTBITS>
  19             <GASSIGNED? FPUTBITS-ANA>>
  20        <PUTPROP ,FPUTBITS ANALYSIS ,FPUTBITS-ANA>)>
  21
  22 <DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>)
  23                                         (NAM <NODE-NAME .NOD>))
  24         #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
  25         <COND (<SEGFLUSH .NOD .RTYP>)
  26               (ELSE
  27                <ARGCHK <LENGTH .K> .NARG .NAM .NOD>
  28                <PUT .NOD ,NODE-TYPE .COD>
  29                <EANA <1 .K> '<PRIMTYPE FIX> .NAM>
  30                <EANA <2 .K> FIX .NAM>
  31                <EANA <3 .K> FIX .NAM>
  32                <COND (<==? <LENGTH .K> 4>
  33                       <EANA <4 .K> '<PRIMTYPE FIX> .NAM>)>)>
  34         <TYPE-OK? FIX .RTYP>>
  35
  36 <DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (NL (0))
  37                                (IC <CHTYPE <APPLY <NODE-SUBR .NOD>> FIX>)
  38                                (NP .NL) CN)
  39         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX
  40                (CN) <SPECIAL NODE>)
  41         <COND (<SEGFLUSH .NOD .RTYP>)
  42               (<0? .LN>
  43                <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  44                <PUT .NOD ,KIDS ()>
  45                <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
  46               (ELSE
  47                <PUT .NOD ,NODE-TYPE ,BITL-CODE>
  48                <MAPF <>
  49                      <FUNCTION (K1)
  50                              #DECL ((K1) NODE)
  51                              <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>
  52                              <COND (<==? <NODE-TYPE .K1> ,QUOTE-CODE>
  53                                     <SET CN .K1>
  54                                     <SET IC <CHTYPE <APPLY <NODE-SUBR .NOD>
  55                                                            .IC
  56                                                            <NODE-NAME .K1>>
  57                                                     FIX>>)
  58                                    (<AND <==? <NODE-TYPE .K1> ,BITL-CODE>
  59                                          <==? <NODE-SUBR .K1>
  60                                               <NODE-SUBR .NOD>>>
  61                                     <SET IC
  62                                          <COMBINE-LOGICAL-OPS
  63                                           .NOD .K1 .NP .IC>>
  64                                     <SET NP <REST .NP <- <LENGTH .NP> 1>>>)
  65                                    (ELSE
  66                                     <PUTREST .NP <SET NP (.K1)>>)>>
  67                      .K>
  68                <COND (<EMPTY? <SET NL <REST .NL>>>
  69                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  70                       <PUT .NOD ,NODE-NAME .IC>
  71                       <PUT .NOD ,KIDS ()>)
  72                      (ELSE
  73                       <COND (<ASSIGNED? CN>
  74                              <PUT .CN ,NODE-NAME <CHTYPE .IC WORD>>
  75                              <PUTREST .NP (.CN)>)>
  76                       <PUT .NOD ,KIDS .NL>)>)>
  77         <TYPE-OK? FIX .RTYP>>
  78
  79 <DEFINE COMBINE-LOGICAL-OPS (P:NODE N:NODE NP:LIST IC)
  80         <MAPF <>
  81               <FUNCTION (NN:NODE)
  82                    <COND (<==? <NODE-TYPE .NN> ,QUOTE-CODE>
  83                           <SET IC <CHTYPE <APPLY <NODE-SUBR .P>
  84                                                  .IC
  85                                                  <NODE-NAME .NN>>
  86                                           FIX>>
  87                           <SET CN .NN>)
  88                          (<AND <==? <NODE-TYPE .NN> ,BITL-CODE>
  89                                <==? <NODE-SUBR .NN> <NODE-SUBR .P>>>
  90                           <SET IC <COMBINE-LOGICAL-OPS .P .NN .NP .IC>>
  91                           <SET NP <REST .NP <- <LENGTH .NP> 1>>>)
  92                          (ELSE
  93                           <PUT .NN ,PARENT .P>
  94                           <PUTREST .NP <SET NP (.NN)>>)>>
  95               <KIDS .N>>
  96         .IC>
  97
  98 <COND (<GASSIGNED? BITLOG>
  99        <PUTPROP ,ANDB ANALYSIS ,BITLOG>
 100        <PUTPROP ,ORB ANALYSIS ,BITLOG>
 101        <PUTPROP ,XORB ANALYSIS ,BITLOG>
 102        <PUTPROP ,EQVB ANALYSIS ,BITLOG>)>
 103
 104 <ENDPACKAGE>