Files from TOPS-20 <mdl.comp>.

[pdp10-muddle.git] / <mdl.comp> / bitana.mud.5

diff --git a/<mdl.comp>/bitana.mud.5 b/<mdl.comp>/bitana.mud.5
new file mode 100644 (file)
index 0000000..e349c4e
--- /dev/null
+++ b/<mdl.comp>/bitana.mud.5
@@ -0,0 +1,84 @@
+
+<PACKAGE "BITANA">
+
+<ENTRY BIT-ANA GETBITS-ANA PUTBITS-ANA BITLOG>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC">
+
+"MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
+
+<DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH) 
+       #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
+       <COND (<SEGFLUSH .NOD .RTYP>)
+             (ELSE
+              <ARGCHK <LENGTH .K> '(1 2) BITS>
+              <EANA <SET WIDTH <1 .K>> FIX BITS>
+              <COND (<NOT <EMPTY? <REST .K>>>
+                     <EANA <SET POS <2 .K>> FIX BITS>
+                     <SET POSN <NODE-NAME .POS>>    ;"May be position field.")>
+              <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
+                          <OR <NOT <ASSIGNED? POS>>            ;"Only one arg."
+                              <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
+                     <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+                     <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
+                     <PUT .NOD ,KIDS ()>)
+                    (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
+       <TYPE-OK? BITS .RTYP>>
+
+<PUT ,BITS ANALYSIS ,BIT-ANA>
+
+<DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
+
+<PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
+
+<DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
+
+<PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
+
+<DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>)) 
+       #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
+       <COND (<SEGFLUSH .NOD .RTYP>)
+             (ELSE
+              <ARGCHK <LENGTH .K> .NARG .NAM>
+              <PUT .NOD ,NODE-TYPE .COD>
+              <EANA <1 .K>
+                    <COND (<==? .COD ,GETBITS-CODE>
+                           '<OR <PRIMTYPE WORD>
+                                <PRIMTYPE STORAGE>>)
+                          (ELSE '<PRIMTYPE WORD>)>
+                    .NAM>
+              <EANA <2 .K> BITS .NAM>
+              <AND <==? <LENGTH .K> 3>
+                  <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
+       <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
+                       (<ISTYPE? <RESULT-TYPE <1 .K>>>)
+                       (ELSE '<PRIMTYPE WORD>)>
+                 .RTYP>>
+
+<DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>)) 
+       #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
+       <COND (<SEGFLUSH .NOD .RTYP>)
+             (<0? .LN>
+              <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+              <PUT .NOD ,KIDS ()>
+              <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
+             (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
+             (ELSE
+              <PUT .NOD ,NODE-TYPE ,BITL-CODE>
+              <MAPF <>
+                    <FUNCTION (K1) 
+                            #DECL ((K1) NODE)
+                            <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
+                    .K>)>
+       <TYPE-OK? WORD .RTYP>>
+
+<PUT ,ANDB ANALYSIS ,BITLOG>
+
+<PUT ,ORB ANALYSIS ,BITLOG>
+
+<PUT ,XORB ANALYSIS ,BITLOG>
+
+<PUT ,EQVB ANALYSIS ,BITLOG>
+
+<ENDPACKAGE>
+