X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.comp%3E%2Fbits.mud.1;fp=%3Cmdl.comp%3E%2Fbits.mud.1;h=26c2b9e6ca6c9af31c2a5f923ee325d86dce9a5b;hp=0000000000000000000000000000000000000000;hb=3395a5e4ef72d59cdb6832af7808dc9c2cf2a413;hpb=363cc6ead5cf4df20759797fe46b5dc29b3886e9

diff --git a/<mdl.comp>/bits.mud.1 b/<mdl.comp>/bits.mud.1
new file mode 100644
index 0000000..26c2b9e
--- /dev/null
+++ b/<mdl.comp>/bits.mud.1
@@ -0,0 +1,383 @@
+
+"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>
+	       <IF <==? <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>
+
+<DEFINE BITLOG-GEN (N W
+		    "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
+			  (INS <LGINS <NODE-SUBR .N>>))
+	#DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
+	<COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
+	       <PUT .K 1 <2 .K>>
+	       <PUT .K 2 .FST>)>
+	<SET REG <GEN <1 .K> .REG>>
+	<RET-TMP-AC <DATTYP .REG> .REG>
+	<PUT .REG
+	     ,DATTYP
+	     <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
+	<MAPF <>
+	      <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT) 
+		      #DECL ((NN) NODE (NXT) DATUM)
+		      <COND (<TYPE? <DATVAL .REG> AC>)
+			    (<TYPE? <SET TT <DATVAL .NXT>> AC>
+			     <PUT .NXT ,DATVAL <DATVAL .REG>>
+			     <PUT .REG ,DATVAL .TT>
+			     <FIX-ACLINK .TT .REG .NXT>)
+			    (ELSE <TOACV .REG>)>
+		      <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
+		      <MUNG-AC .TT .REG>
+		      <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
+		      <PUT .TT ,ACPROT <>>
+		      <RET-TMP-AC .NXT>>
+	      <REST .K>>
+	<MOVE:ARG .REG .W>>
+
+<DEFINE LGINS (SUBR) 
+	<NTH '![(`AND  `ANDI `ANDCMI )
+		(`IOR  `IORI `ORCMI )
+		(`XOR  `XORI )
+		(`EQV  `EQVI )!]
+	     <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
+
+<SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
+
+<DEFINE GETBITS-GEN (N W
+		     "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
+			   BAC AC BPW WRD BPD TEM)
+   #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
+	  (BPW) <PRIMTYPE WORD>)
+   <COND
+    (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+     <SET WRD <GEN .WRDN DONT-CARE>>
+     <SET BPW <NODE-NAME .BP>>
+     <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
+     <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+     <COND
+      (<AND <==? <+ .POS .WDTH> 36>
+	    <N==? .WDTH 18>
+	    <TYPE? <DATVAL .WRD> AC>
+	    <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
+	    <OR <==? .W DONT-CARE>
+		<AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
+       <MUNG-AC .AC <SET REG .WRD>>
+       <EMIT <INSTRUCTION `LSH  <ACSYM .AC> <- .POS>>>)
+      (ELSE
+       <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+	    ,ACPROT
+	    T>
+       <COND (<AND <==? .WDTH 18>		     ;"Could be half word hack."
+		   <COND (<0? .POS>
+			  <EMIT <INSTRUCTION `HRRZ 
+					     <ACSYM .AC>
+					     !<ADDR:VALUE .WRD>>>
+			  T)
+			 (<==? .POS 18>
+			  <EMIT <INSTRUCTION `HLRZ 
+					     <ACSYM .AC>
+					     !<ADDR:VALUE .WRD>>>
+			  T)>>)
+	     (ELSE
+	      <EMIT <INSTRUCTION `LDB 
+				 <ACSYM .AC>
+				 [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+					!<ADDR:VALUE .WRD>>]>>)>
+       <PUT .AC ,ACPROT <>>
+       <RET-TMP-AC .WRD>)>)
+    (<==? <NODE-TYPE .BP> ,BITS-CODE>
+     <SET WRD
+	  <GEN .WRDN
+	       <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+		     (ELSE DONT-CARE)>>>
+     <SET BPD
+	  <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
+     <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+	  ,ACPROT
+	  T>
+     <TOACV .BPD>
+     <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+     <SET TEM <2 .TEM>>
+     <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
+     <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
+     <EMIT <INSTRUCTION `LDB  <ACSYM .AC> <ADDRSYM .BAC>>>
+     <PUT .BAC ,ACPROT <>>
+     <PUT .AC ,ACPROT <>>
+     <RET-TMP-AC .WRD>
+     <RET-TMP-AC .BPD>)
+    (ELSE					   ;"Non constant byte pointer."
+     <SET WRD
+	  <GEN .WRDN
+	       <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+		     (ELSE DONT-CARE)>>>
+     <SET BPD <GEN .BP DONT-CARE>>
+     <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+	  ,ACPROT
+	  T>
+     <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
+     <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+     <MUNG-AC .BAC .BPD>
+     <EMIT <INSTRUCTION `HRRI  <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
+     <EMIT <INSTRUCTION `LDB  <ACSYM .AC> <ADDRSYM .BAC>>>
+     <PUT .BAC ,ACPROT <>>
+     <PUT .AC ,ACPROT <>>
+     <RET-TMP-AC .WRD>
+     <RET-TMP-AC .BPD>)>
+   <MOVE:ARG .REG .W>>
+
+<DEFINE PUTBITS-GEN (N W
+		     "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
+			   FLD BPW BPD SWRDD (FLG T) TEM NUM)
+   #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
+	  (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
+   <COND
+    (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+     <SET POS
+	  <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
+     <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+     <COND
+      (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
+	    <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
+       <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
+       <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+       <COND (<L? <+ .POS .WDTH> 36>
+	      <IMCHK '(`AND  `ANDI )
+		     <ACSYM <DATVAL .SWRDD>>
+		     <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
+       <EMIT <INSTRUCTION `LSH  <ACSYM <DATVAL .SWRDD>> .POS>>)
+      (ELSE
+       <SET SWRDD
+	    <GEN .SWRD
+		 <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
+       <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+       <COND
+	(<AND
+	  <==? .WDTH 18>
+	  <COND
+	   (<0? .POS>
+	    <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+		   <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
+				      <ADDRSYM <DATVAL .SWRDD>>>>)
+		  (ELSE <PCLOB .SWRDD '(`HRR  `HRRI ) <3 .K>>)>)
+	   (<==? .POS 18>
+	    <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+		   <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
+				      <ADDRSYM <DATVAL .SWRDD>>>>)
+		  (ELSE <PCLOB .SWRDD '(`HRL  `HRLI ) <3 .K>>)>
+	    T)>>)
+	(<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
+	      <SET NUM <ZERQ .K>>
+	      <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
+	 <EMIT <INSTRUCTION <COND (<0? .NUM>
+				   <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
+				  (ELSE
+				   <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
+			    <ACSYM <DATVAL .SWRDD>>
+			    <LSH <LSH -1 <- .WDTH 36>>
+				 <COND (<L? .POS 18> .POS)
+				       (ELSE <- .POS 18>)>>>>)
+	(ELSE
+	 <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
+	 <PUT <DATVAL .FLD> ,ACPROT T>
+	 <TOACV .SWRDD>
+	 <PUT <DATVAL .SWRDD> ,ACPROT T>
+	 <EMIT <INSTRUCTION `DPB 
+			    <ACSYM <DATVAL .FLD>>
+			    [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+				   <ADDRSYM <DATVAL .SWRDD>>>]>>
+	 <PUT <DATVAL .FLD> ,ACPROT <>>
+	 <PUT <DATVAL .SWRDD> ,ACPROT <>>
+	 <RET-TMP-AC .FLD>)>)>)
+    (ELSE
+     <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
+	    <SET SWRDD
+		 <GEN .SWRD
+		      <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+			    .W>>>)>
+     <PREFER-DATUM .W>
+     <SET BPD
+	  <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
+		 <SET FLG <>>
+		 <1 <SET TEM
+			 <RBITS-GEN .BP
+				    <DATUM BITS ANY-AC>
+				    <COND (<ASSIGNED? SWRDD> .SWRDD)
+					  (ELSE ,NO-DATUM)>>>>)
+		(ELSE <GEN .BP DONT-CARE>)>>
+     <PREFER-DATUM .W>
+     <COND (<SET NUM <ZERQ .K>>
+	    <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
+	   (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
+     <DATTYP-FLUSH .FLD>
+     <PUT .FLD ,DATTYP WORD>
+     <COND (<NOT <ASSIGNED? SWRDD>>
+	    <SET SWRDD
+		 <GEN .SWRD
+		      <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+			    .W>>>)>
+     <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
+	    <SET SWRDD
+		 <MOVE:ARG
+		  .SWRDD
+		  <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+			.W>>>)>
+     <PUT <DATVAL .SWRDD> ,ACPROT T>
+     <TOACV .FLD>
+     <PUT <DATVAL .FLD> ,ACPROT T>
+     <TOACV .BPD>
+     <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+     <COND (<NOT .FLG>
+	    <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
+	    <PUTREST <2 .TEM> ()>)>
+     <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+     <COND (.FLG
+	    <MUNG-AC .BAC .BPD>
+	    <EMIT <INSTRUCTION `HRRI  <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
+     <EMIT <INSTRUCTION `DPB  <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
+     <PUT .BAC ,ACPROT <>>
+     <PUT <DATVAL .SWRDD> ,ACPROT <>>
+     <PUT <DATVAL .FLD> ,ACPROT <>>
+     <RET-TMP-AC .BPD>
+     <RET-TMP-AC .FLD>)>
+   <MOVE:ARG .SWRDD .W>>
+
+<DEFINE ZERQ (L "AUX" NUM) 
+	#DECL ((L) <LIST [REST NODE]>)
+	<COND (<==? <LENGTH .L> 2> 0)
+	      (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
+		    <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
+		    <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
+			<AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
+
+<DEFINE PCLOB (DEST INS SRC "AUX" SRCD) 
+	#DECL ((DEST SRCD) DATUM (SRC) NODE)
+	<SET SRCD <GEN .SRC DONT-CARE>>
+	<TOACV .DEST>
+	<PUT <DATVAL .DEST> ,ACPROT T>
+	<IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
+	<PUT <DATVAL .DEST> ,ACPROT <>>
+	<RET-TMP-AC .SRCD>>
+
+<DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
+
+<DEFINE RBITS-GEN (N W ADDR
+		   "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
+			 (REG <REG? WORD .W>) POSD (FLG T))
+	#DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
+	<COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
+	<COND
+	 (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
+	  <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
+	 (<OR <NOT <ASSIGNED? POS>>
+	      <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
+	  <SET TEM
+	       <MAKE-PTR .ADDR
+			 <>
+			 <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
+	  <SET POS .WDTHN>
+	  <SET FLG <>>)
+	 (ELSE
+	  <SET WDTH <GEN .WDTHN .REG>>
+	  <MUNG-AC <DATVAL .REG> .REG>
+	  <EMIT <INSTRUCTION `LSH  <ACSYM <DATVAL .REG>> 24>>
+	  <COND (<TYPE? .ADDR DATUM>
+		 <EMIT <SET TEM <INSTRUCTION `HRRI  <ACSYM <DATVAL .REG>> 0>>>
+		 <SET TEM <REST .TEM 2>>)
+		(ELSE <SET TEM '(0)>)>)>
+	<SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
+	<PUT <DATVAL .POSD> ,ACPROT T>
+	<COND (<NOT <ASSIGNED? WDTH>>
+	       <SET WDTH <DATUM WORD ANY-AC>>
+	       <PUT .WDTH ,DATVAL <GETREG .WDTH>>
+	       <EMIT <INSTRUCTION `MOVE  <ACSYM <DATVAL .WDTH>> .TEM>>
+	       <SET TEM <REST <1 .TEM>>>)
+	      (ELSE <TOACV .WDTH>)>
+	<PUT <DATVAL .WDTH> ,ACPROT T>
+	<EMIT <INSTRUCTION `DPB 
+			   <ACSYM <DATVAL .POSD>>
+			   [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
+				  <ADDRSYM <DATVAL .WDTH>>>]>>
+	<PUT <DATVAL .WDTH> ,ACPROT <>>
+	<PUT <DATVAL .POSD> ,ACPROT <>>
+	<RET-TMP-AC .POSD>
+	<COND (<TYPE? <DATTYP .WDTH> AC>
+	       <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
+	<PUT .WDTH ,DATTYP BITS>
+	[<MOVE:ARG .WDTH .W> .TEM]>
+
+<DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>)) 
+	#DECL ((CNST) FIX)
+	<COND (<TYPE? .AD DATUM>
+	       [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
+	      (ELSE
+	       [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>
+
\ No newline at end of file