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

diff --git a/<mdl.comp>/carana.mud.337 b/<mdl.comp>/carana.mud.337
new file mode 100644
index 0000000..096e350
--- /dev/null
+++ b/<mdl.comp>/carana.mud.337
@@ -0,0 +1,393 @@
+<PACKAGE "CARANA">
+
+<ENTRY ARITH-ANA MOD-ANA ABS-ANA ROT-ANA LSH-ANA FIX-ANA FLOAT-ANA ARITHP-ANA
+	HACK-BOUNDS BIT-TEST-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+"	This file contains analyzers and code generators for arithmetic
+ SUBRs and predicates.  For convenience many of the SUBRs that are
+similar are combined into one analyzer/generator.  For more info
+on analyzers see SYMANA and on generators see CODGEN.
+"
+
+<SETG ASTATE ![![2 3 5!] ![2 4 5!] ![4 3 5!] ![4 4 5!] ![5 5 5!]!]>
+
+"	Analyze +,-,* and /.  Take care of no arg and one arg problems."
+
+<DEFINE ARITH-ANA (NOD RTYP
+		   "AUX" (NN <NODE-NAME .NOD>) (DEFLT <GET-DF .NN>) (STATE 1)
+			 (K <KIDS .NOD>) (FIXDIV <>) RT)
+   #DECL ((NOD) <SPECIAL NODE> (K) <LIST [REST NODE]> (STYP) FIX
+	  (STATE) <SPECIAL FIX> (DEFLT) <OR FIX FLOAT>)
+   <SET RT <COND (<NOT <TYPE-OK? .RTYP FLOAT>> FIX) (ELSE '<OR FIX FLOAT>)>>
+   <COND
+    (<EMPTY? .K>
+     <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+     <PUT .NOD ,RESULT-TYPE <TYPE .DEFLT>>
+     <PUT .NOD ,NODE-NAME .DEFLT>
+     <PUT .NOD ,KIDS ()>
+     <TYPE-OK? <TYPE .DEFLT> .RTYP>)
+    (<AND <EMPTY? <REST .K>>
+	  <N==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>
+	  <N==? <NODE-TYPE <1 .K>> ,SEG-CODE>
+	  <COND (<==? <NODE-SUBR .NOD> ,/>
+		 <SET FIXDIV T>
+		 <PUT .NOD
+		      ,KIDS
+		      <SET K
+			   (<NODE1 ,QUOTE-CODE .NOD <TYPE .DEFLT> .DEFLT ()>
+			    !.K)>>
+		 <>)
+		(ELSE T)>>
+     <COND (<==? <NODE-SUBR .NOD> ,-> <PUT .NOD ,NODE-TYPE ,ABS-CODE>
+					  ;"Treat like a call
+							 to ABS.")
+	   (ELSE <PUT .NOD ,NODE-TYPE ,ID-CODE>)>
+     <EANA <1 .K> .RT <NODE-NAME .NOD>>)
+    (ELSE
+     <MAPF <> <FUNCTION (N) <ARITH-ELE .N .RT>> .K>
+     <COND (<L? .STATE 5>
+	    <COND (<AND .FIXDIV <N==? .STATE 2>>
+		   <PUT <PUT <1 .K> ,NODE-NAME 1.0> ,RESULT-TYPE FLOAT>)>
+	    <PUT .NOD
+		 ,NODE-TYPE
+		 <COND (<OR <==? .NN MAX> <==? .NN MIN>> ,MIN-MAX-CODE)
+		       (ELSE ,ARITH-CODE)>>
+	    <MAPF <>
+		  <FUNCTION (NN) 
+			  #DECL ((NN) NODE)
+			  <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
+				 <PUT .NN ,NODE-TYPE ,SEG-CODE>)>>
+		  .K>)
+	   (ELSE
+	    <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
+	    <PUT .NOD
+		 ,STACKS
+		 <* <MAPF ,+
+			  <FUNCTION (N "AUX" (CD <NODE-TYPE .N>)) 
+				  #DECL ((N) NODE (CD) FIX)
+				  <COND (<OR <==? .CD ,SEGMENT-CODE>
+					     <==? .CD ,SEG-CODE>>
+					 <PUT .NOD ,SEGS T>
+					 <PUT .N ,NODE-TYPE ,SEGMENT-CODE>
+					 <MAPRET>)
+					(ELSE 1)>>
+			  .K>
+		    2>>)>
+     <TYPE-OK? <NTH '[FIX FLOAT FLOAT <OR FIX FLOAT>] <- .STATE 1>> .RTYP>)>>
+
+<DEFINE GET-DF (S) 
+	#DECL ((S) ATOM)
+	<NTH '[0 0 1 1 1.7014117E+38 -1.7014117E+38]
+	     <LENGTH <MEMQ .S '![MAX MIN * / - +!]>>>> 
+ 
+<DEFINE ARITH-ELE (N RT "AUX" TT TEM (FL <>)) 
+	#DECL ((N NOD) NODE (STATE TT) FIX)
+	<COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+		   <==? <NODE-TYPE .N> ,SEG-CODE>>
+	       <SET FL T>
+	       <SET TEM
+		    <EANA <1 <KIDS .N>>
+			  <FORM STRUCTURED [REST .RT]>
+			  <NODE-NAME .NOD>>>
+	       <PUT .N ,RESULT-TYPE <RESULT-TYPE <1 <KIDS .N>>>>
+	       <SET TEM <OR <AND <ISTYPE? .TEM> <GET-ELE-TYPE .TEM ALL>> ANY>>)
+	      (ELSE
+	       <SET TEM <EANA .N .RT <NODE-NAME .NOD>>>
+	       <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
+		    <OR <==? .STATE 4> <==? .STATE 3>>
+		    <PUT .N ,NODE-NAME <FLOAT <NODE-NAME .N>>>
+		    <PUT .N ,RESULT-TYPE FLOAT>>)>
+	<SET TT
+	     <COND (<==? <ISTYPE? .TEM> FIX> 1)
+		   (<==? .TEM FLOAT> 2)
+		   (<NOT <TYPE-OK? .TEM FLOAT>>
+		    <PUT .N
+			 ,RESULT-TYPE
+			 <COND (.FL
+				<TYPE-MERGE '<STRUCTURED [REST FIX]>
+					    <RESULT-TYPE .N>>)
+			       (ELSE FIX)>>
+		    1)
+		   (<NOT <TYPE-OK? .TEM FIX>>
+		    <PUT .N
+			 ,RESULT-TYPE
+			 <COND (.FL
+				<TYPE-MERGE '<STRUCTURED [REST FLOAT]>
+					    <RESULT-TYPE .N>>)
+			       (ELSE FLOAT)>>
+		    2)
+		   (ELSE 3)>>
+	<COND (<AND .VERBOSE <==? .TT 3>>
+	       <ADDVMESS <PARENT .N>
+			 ("Arithmetic can't open compile because:  " .N
+			  " is of type:  " .TEM)>)>
+	<SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
+
+<DEFINE ABS-ANA (N RT "AUX" (K <KIDS .N>) TEM) 
+	#DECL ((N) NODE (K) <LIST [REST NODE]>)
+	<COND (<SEGFLUSH .N .RT>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> 1 ABS>
+	       <PUT .N ,NODE-TYPE ,ABS-CODE>
+	       <SET TEM <EANA <1 .K> '<OR FIX FLOAT> ABS>>
+	       <TYPE-OK? <TYPE-OK? '<OR FLOAT <FIX (0 34359738367)>> .RT>
+			 .TEM>)>>
+
+<PUT ,ABS ANALYSIS ,ABS-ANA>
+
+<DEFINE MOD-ANA (N R "AUX" (K <KIDS .N>)) 
+	#DECL ((N) NODE (K) <LIST [REST NODE]>)
+	<COND (<SEGFLUSH .N .R>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> 2 MOD>
+	       <EANA <1 .K> FIX MOD>
+	       <EANA <2 .K> FIX MOD>
+	       <PUT .N ,NODE-TYPE ,MOD-CODE>)>
+	<TYPE-OK? <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+			 <FORM FIX (0 <- <NODE-NAME <2 .K>> 1>)>)
+			(ELSE FIX)> .R>>
+
+<PUT ,MOD ANALYSIS ,MOD-ANA>
+
+<DEFINE ROT-LSH-ANA (N R COD "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>)) 
+	<COND (<SEGFLUSH .N .R>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> 2 .NAM>
+	       <EANA <1 .K> '<PRIMTYPE WORD> .NAM>
+	       <EANA <2 .K> FIX .NAM>
+	       <PUT .N ,NODE-TYPE .COD>)>
+	<TYPE-OK? WORD .R>>
+
+<DEFINE ROT-ANA (N R) <ROT-LSH-ANA .N .R ,ROT-CODE>>
+
+<DEFINE LSH-ANA (N R) <ROT-LSH-ANA .N .R ,LSH-CODE>>
+
+<PUT ,ROT ANALYSIS ,ROT-ANA>
+
+<PUT ,LSH ANALYSIS ,LSH-ANA>
+
+<DEFINE FLOAT-ANA (N R) 
+	#DECL ((N) NODE)
+	<FL-FI-ANA .N .R FLOAT FIX ,FLOAT-CODE>>    
+ 
+<PUT ,FLOAT ANALYSIS ,FLOAT-ANA>
+
+<DEFINE FIX-ANA (N R) #DECL ((N) NODE) <FL-FI-ANA .N .R FIX FLOAT ,FIX-CODE>>   
+ 
+<PUT ,FIX ANALYSIS ,FIX-ANA>
+
+<DEFINE FL-FI-ANA (N RT OT IT COD "AUX" (K <KIDS .N>) TY NUM) 
+	#DECL ((N NUM) NODE (OT IT) ATOM (K) <LIST [REST NODE]> (COD) FIX)
+	<COND (<SEGFLUSH .N .RT>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> 1 .OT>
+	       <SET TY <EANA <SET NUM <1 .K>> '<OR FIX FLOAT> .OT>>
+	       <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
+		      <PUT .N ,NODE-TYPE ,QUOTE-CODE>
+		      <PUT .N ,NODE-NAME <APPLY ,.OT <NODE-NAME .NUM>>>)
+		     (ELSE
+		      <PUT .N ,NODE-TYPE .COD>)>)>
+	<TYPE-OK? .OT .RT>>    
+
+<DEFINE ARITHP-ANA (NOD RTYP
+		    "AUX" (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
+			  (GLN .NOD) (GLE ()) (NN <NODE-NAME .NOD>)
+			  (N
+			   <COND (<OR <==? .NN 0?>
+				      <==? .NN 1?>
+				      <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
+				  1)
+				 (ELSE 2)>) (K <KIDS .NOD>) TEM (STATE 1))
+	#DECL ((WHO) <SPECIAL LIST> (WHON GLN) <SPECIAL ANY>
+	       (NOD NOD2) <SPECIAL NODE> (TEM) NODE (K) <LIST [REST NODE]>
+	       (STATE) <SPECIAL FIX> (COD N) FIX (GLE) <SPECIAL LIST>)
+	<COND (<SEGFLUSH .NOD .RTYP>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> .N <NODE-NAME .NOD>>
+	       <MAPF <> <FUNCTION (N) <ARITH-ELE .N '<OR FIX FLOAT>>> .K>
+	       <COND (<AND <==? .N 2>
+			   <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+				    <0? <NODE-NAME <1 .K>>>
+				    <SET TEM <2 .K>>
+				    <PUT .NOD
+					 ,NODE-NAME
+					 <FLOPP <NODE-NAME .NOD>>>>
+			       <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+				    <0? <NODE-NAME <2 .K>>>
+				    <SET TEM <1 .K>>>>>
+		      <PUT .NOD ,NODE-TYPE ,0-TST-CODE>
+		      <PUT .NOD ,KIDS (.TEM)>)
+		     (<==? <NODE-TYPE .NOD> ,0-TST-CODE>)
+		     (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-NAME .NOD> N0?>>
+		      <PUT .NOD ,NODE-TYPE ,0-TST-CODE>)
+		     (<L? .STATE 5>
+		      <PUT .NOD
+			   ,NODE-TYPE
+			   <COND (<==? .N 2> ,TEST-CODE)
+				 (<==? <NODE-NAME .NOD> 0?> ,0-TST-CODE)
+				 (ELSE ,1?-CODE)>>)
+		     (<==? <NODE-SUBR .NOD> ,1?> <PUT .NOD ,NODE-TYPE ,1?-CODE>)
+		     (<OR <==? <NODE-SUBR .NOD> ,==?>
+			  <==? <NODE-SUBR .NOD> ,N==?>>
+		      <PUT .NOD ,NODE-TYPE ,EQ-CODE>)
+		     (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+	       <COND (<==? .STATE 2> <HACK-BOUNDS .WHO .GLE .NOD .K>)>
+	       <CHECK-FOR-BIT-HACK .NOD>)>
+	<TYPE-OK? '<OR FALSE ATOM> .RTYP>>
+
+<DEFINE CHECK-FOR-BIT-HACK (N "AUX" (NN <1 <KIDS .N>>) DATA CONST K) 
+	#DECL ((NN DATA N) NODE (CONST) <PRIMTYPE WORD>)
+	<COND (<AND <==? <NODE-TYPE .N> ,0-TST-CODE>
+		    <==? <NODE-TYPE .NN> ,CHTYPE-CODE>
+		    <SET NN <1 <KIDS .NN>>>
+		    <OR <AND <==? <NODE-TYPE .NN> ,GETBITS-CODE>
+			     <SET K <KIDS .NN>>
+			     <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+			     <SET DATA <1 .K>>
+			     <SET CONST <PUTBITS 0 <NODE-NAME <2 .K>> -1>>>
+			<AND <==? <NODE-TYPE .NN> ,BITL-CODE>
+			     <==? <NODE-SUBR .NN> ,ANDB>
+			     <==? <LENGTH <SET K <KIDS .NN>>> 2>
+			     <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+				      <SET CONST <NODE-NAME <1 .K>>>
+				      <SET DATA <2 .K>>>
+				 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+				      <SET CONST <NODE-NAME <2 .K>>>
+				      <SET DATA <1 .K>>>
+				 <SET CONST 0>>>>>
+	       <PUT .N ,NODE-TYPE ,BIT-TEST-CODE>
+	       <PUT .N ,NODE-SUBR .CONST>
+	       <PUT .N ,KIDS <COND (<ASSIGNED? DATA> (.DATA)) (ELSE .K)>>
+	       <COND (<ASSIGNED? DATA> <PUT .DATA ,PARENT .N>)
+		     (ELSE
+		      <PUT <1 .K> ,PARENT .N>
+		      <PUT <2 .K> ,PARENT .N>)>)>>
+
+<DEFINE BIT-TEST-ANA (N R "AUX" (K <KIDS .N>))
+	#DECL ((N) NODE (K) <LIST [REST NODE]>)
+	<EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>
+	<COND (<NOT <EMPTY? <SET K <REST .K>>>>
+	       <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>)>
+	<TYPE-OK? <RESULT-TYPE .N> .R>>
+
+<DEFINE HACK-BOUNDS (WHO GLE NOD K "AUX" NUM YES NO NOD2 (HACKT <>)) 
+   #DECL ((WHO GLE) LIST (NOD NOD2) NODE (K) <LIST [REST NODE]>)
+   <SET NUM
+	<COND (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
+	       <SET NOD2 <1 .K>>
+	       0)
+	      (<==? <NODE-NAME .NOD> 1?> <SET NOD2 <1 .K>> 1)
+	      (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+	       <SET NOD2 <2 .K>>
+	       <NODE-NAME <1 .K>>)
+	      (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+	       <SET NOD2 <1 .K>>
+	       <PUT .NOD ,NODE-NAME <FLOPP <NODE-NAME .NOD>>>
+	       <PUT .NOD ,KIDS (<2 .K> <1 .K>)>
+	       <NODE-NAME <2 .K>>)>>
+   <COND (.NUM
+	  <SET YES <FORM FIX <GTV .NOD .NUM>>>
+	  <SET NO <FORM FIX <NGTV .NOD .NUM>>>
+	  <MAPF <>
+		<FUNCTION (L "AUX" (SYM <2 .L>)) 
+			#DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+			<SET TRUTH
+			     <ADD-TYPE-LIST .SYM .YES .TRUTH <> <REST .L 2>>>
+			<SET UNTRUTH
+			     <ADD-TYPE-LIST .SYM .NO .UNTRUTH <> <REST .L 2>>>>
+		.WHO>)>
+   <COND (<AND .NUM <G=? .NUM 0>>
+	  <COND (<OR <AND <NOT <0? .NUM>>
+			  <OR <==? <NODE-NAME .NOD> G=?>
+			      <==? <NODE-NAME .NOD> L?>>>
+		     <AND <0? .NUM>
+			  <OR <AND <==? <NODE-NAME .NOD> G?> <SET HACKT T>>
+			      <==? <NODE-NAME .NOD> L=?>>>>
+		 <SET NUM <+ .NUM 1>>)>
+	  <OR .HACKT <SET HACKT <MEMQ <NODE-NAME .NOD> '![1? L? L=? ==?!]>>>
+	  <COND (<==? <NODE-NAME .NOD> 0?> <SET NUM 1>)>
+	  <COND (<L=? .NUM 0> STRUCTURED)
+		(ELSE <SET NUM <CHTYPE (STRUCTURED !<ANY-PAT .NUM>) FORM>>)>
+	  <MAPF <>
+		<FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>)) 
+			#DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+			<COND (.HACKT
+			       <SET TRUTH
+				    <ADD-TYPE-LIST .SYM
+						   .NUM
+						   .TRUTH
+						   <>
+						   <REST .L 2>>>)
+			      (ELSE
+			       <SET UNTRUTH
+				    <ADD-TYPE-LIST .SYM
+						   .NUM
+						   .UNTRUTH
+						   <>
+						   <REST .L 2>>>)>
+			T>
+		.GLE>)>>
+
+<SETG APSUBTAB [1? 0? L? L=? G? G=? ==? N==?]>
+
+<SETG DCLTAB
+      [(1 1)
+       (0 0)
+       ('<+ .VAL 1> ,PLUSINF)
+       ('.VAL ,PLUSINF)
+       (,MINUSINF '<- .VAL 1>)
+       (,MINUSINF '.VAL)
+       ('.VAL '.VAL)
+       (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)]>
+
+<SETG NDCLTAB
+      [(,MINUSINF 0 2 ,PLUSINF)
+       (,MINUSINF -1 1 ,PLUSINF)
+       (,MINUSINF '.VAL)
+       (,MINUSINF '<- .VAL 1>)
+       ('.VAL ,PLUSINF)
+       ('<+ .VAL 1> ,PLUSINF)
+       (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)
+       ('.VAL '.VAL)]>
+
+<DEFINE NGTV (NOD VAL) 
+	#DECL ((VAL) <SPECIAL ANY> (NOD) NODE)
+	<EVAL <NTH ,NDCLTAB
+		   <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
+
+<DEFINE GTV (NOD VAL) 
+	#DECL ((NOD) NODE (VAL) <SPECIAL ANY>)
+	<EVAL <NTH ,DCLTAB
+		   <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
+
+<DEFINE FLOPP (SUBR) 
+	#DECL ((SUBR VALUE) ATOM)
+	<1 <REST <MEMQ .SUBR '![G? L? G? G=? L=? G=? ==? ==? N==? N==?!]>>>>    
+
+<PUT ,+ ANALYSIS ,ARITH-ANA>
+
+<PUT ,- ANALYSIS ,ARITH-ANA>
+
+<PUT ,* ANALYSIS ,ARITH-ANA>
+
+<PUT ,/ ANALYSIS ,ARITH-ANA>
+
+<PUT ,MAX ANALYSIS ,ARITH-ANA>
+
+<PUT ,MIN ANALYSIS ,ARITH-ANA>
+
+<PUT ,0? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,1? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,L? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,G? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,G=? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,L=? ANALYSIS ,ARITHP-ANA>
+
+<ENDPACKAGE>
\ No newline at end of file