<mdl.comp>/bitana.mud.5

   1
   2 <PACKAGE "BITANA">
   3
   4 <ENTRY BIT-ANA GETBITS-ANA PUTBITS-ANA BITLOG>
   5
   6 <USE "SYMANA" "CHKDCL" "COMPDEC">
   7
   8 "MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
   9
  10 <DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH)
  11         #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
  12         <COND (<SEGFLUSH .NOD .RTYP>)
  13               (ELSE
  14                <ARGCHK <LENGTH .K> '(1 2) BITS>
  15                <EANA <SET WIDTH <1 .K>> FIX BITS>
  16                <COND (<NOT <EMPTY? <REST .K>>>
  17                       <EANA <SET POS <2 .K>> FIX BITS>
  18                       <SET POSN <NODE-NAME .POS>>    ;"May be position field.")>
  19                <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
  20                            <OR <NOT <ASSIGNED? POS>>            ;"Only one arg."
  21                                <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
  22                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  23                       <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
  24                       <PUT .NOD ,KIDS ()>)
  25                      (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
  26         <TYPE-OK? BITS .RTYP>>
  27
  28 <PUT ,BITS ANALYSIS ,BIT-ANA>
  29
  30 <DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
  31
  32 <PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
  33
  34 <DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
  35
  36 <PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
  37
  38 <DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>))
  39         #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
  40         <COND (<SEGFLUSH .NOD .RTYP>)
  41               (ELSE
  42                <ARGCHK <LENGTH .K> .NARG .NAM>
  43                <PUT .NOD ,NODE-TYPE .COD>
  44                <EANA <1 .K>
  45                      <COND (<==? .COD ,GETBITS-CODE>
  46                             '<OR <PRIMTYPE WORD>
  47                                  <PRIMTYPE STORAGE>>)
  48                            (ELSE '<PRIMTYPE WORD>)>
  49                      .NAM>
  50                <EANA <2 .K> BITS .NAM>
  51                <AND <==? <LENGTH .K> 3>
  52                    <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
  53         <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
  54                         (<ISTYPE? <RESULT-TYPE <1 .K>>>)
  55                         (ELSE '<PRIMTYPE WORD>)>
  56                   .RTYP>>
  57
  58 <DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>))
  59         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
  60         <COND (<SEGFLUSH .NOD .RTYP>)
  61               (<0? .LN>
  62                <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  63                <PUT .NOD ,KIDS ()>
  64                <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
  65               (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
  66               (ELSE
  67                <PUT .NOD ,NODE-TYPE ,BITL-CODE>
  68                <MAPF <>
  69                      <FUNCTION (K1)
  70                              #DECL ((K1) NODE)
  71                              <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
  72                      .K>)>
  73         <TYPE-OK? WORD .RTYP>>
  74
  75 <PUT ,ANDB ANALYSIS ,BITLOG>
  76
  77 <PUT ,ORB ANALYSIS ,BITLOG>
  78
  79 <PUT ,XORB ANALYSIS ,BITLOG>
  80
  81 <PUT ,EQVB ANALYSIS ,BITLOG>
  82
  83 <ENDPACKAGE>
  84