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

diff --git a/<mdl.comp>/cback.mud.18 b/<mdl.comp>/cback.mud.18
new file mode 100644
index 0000000..71439d2
--- /dev/null
+++ b/<mdl.comp>/cback.mud.18
@@ -0,0 +1,145 @@
+<PACKAGE "CBACK">
+
+<ENTRY BACK-GEN TOP-GEN>
+
+<USE "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD" "STRGEN">
+
+
+<DEFINE BACK-GEN (NOD WHERE
+		  "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
+			(TPS <STRUCTYP .TYP>)
+			(NUMKN <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>)
+			(NUM <COND (.NUMKN <NODE-NAME <2 .K>>) (ELSE 0)>))
+	#DECL ((NUMKN) <OR ATOM FALSE> (NUM) FIX (TPS) ATOM (NOD) NODE
+	       (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
+	<APPLY <NTH ,BACKERS <LENGTH <MEMQ .TPS ,STYPES>>>
+	       .NOD
+	       .WHERE
+	       .TYP
+	       .TPS
+	       .NUMKN
+	       .NUM
+	       <1 .K>
+	       <2 .K>>>
+
+<DEFINE NO-BACK-ERROR (NOD "TUPLE" ERR) 
+	<MESSAGE INCONSISTENCY "CANT OPEN-COMPILE BACK" .ERR .NOD>>
+
+<DEFINE VEC-BACK-GEN (NODE WHERE TYP TPS NUMKN NUM STRNOD NUMNOD
+		      "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
+			    (CAREFL <AND .CAREFUL <N==? .TPS TUPLE>>)
+			    (UV? <==? .TPS UVECTOR>) NAC SAC STR NUMN (RV <>)
+			    TAC TDAT (W <GOODACS .NODE .WHERE>))
+   #DECL ((NOD NUMNOD STRNOD) NODE (W TDAT STR NUMN) DATUM (TAC SAC NAC) AC (NUM) FIX
+	  (NO-KILL) <SPECIAL LIST> (RV CAREFL UV?) <OR ATOM FALSE>)
+   <COND
+    (.NUMKN
+     <COND (<L? .NUM 0> <MESSAGE INCONSISTENCY "ARG OUT OF RANGE BACK" .NODE>)
+	   (<0? .NUM> <SET STR <GEN .STRNOD .W>>)
+	   (ELSE
+	    <SET STR <GEN .STRNOD .W>>
+	    <COND (.CAREFL
+		   <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
+		   <MUNG-AC .TAC>
+		   <PUT .TDAT ,DATVAL .TAC>
+		   <SET TAC <DATVAL .TDAT>>
+		   <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .STR>>>
+		   <EMIT <INSTRUCTION `MOVE  <ACSYM .TAC> !<ADDR:VALUE .STR>>>
+		   <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> `O >>
+		   <EMIT <INSTRUCTION `HLRZ  <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
+		   <EMIT <INSTRUCTION `ADD  <ACSYM .TAC> `O >>
+		   <EMIT <INSTRUCTION `SUBI 
+				      <ACSYM .TAC>
+				      <+ <COND (.UV? .NUM) (ELSE <* .NUM 2>)>
+					 1>>>
+		   <EMIT <INSTRUCTION `JUMPLE  <ACSYM .TAC> |COMPER >>
+		   <RET-TMP-AC .TDAT>)>
+	    <TOACV .STR>
+	    <SET SAC <DATVAL .STR>>
+	    <MUNG-AC .SAC .STR>
+	    <EMIT <INSTRUCTION `SUB 
+			       <ACSYM .SAC>
+			       <COND (.UV? [<FORM (.NUM) .NUM>])
+				     (ELSE
+				      [<FORM (<* .NUM 2>) <* .NUM 2>>])>>>)>)
+    (ELSE
+     <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
+     <COND (.RV <SET NUMN <GEN .NUMNOD DONT-CARE>> <SET STR <GEN .STRNOD .W>>)
+	   (<SET STR <GEN .STRNOD .W>> <SET NUMN <GEN .NUMNOD DONT-CARE>>)>
+     <DELAY-KILL .NO-KILL .ONO>
+     <TOACV .NUMN>
+     <SET NAC <DATVAL .NUMN>>
+     <MUNG-AC .NAC .NUMN>
+     <COND (<NOT .UV?> <EMIT <INSTRUCTION `ASH  <ACSYM .NAC> 1>>)>
+     <COND (.CAREFUL
+	    <EMIT <INSTRUCTION `JUMPL  <ACSYM .NAC> |COMPER >>
+	    <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
+	    <PUT .TDAT ,DATVAL .TAC>
+	    <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .STR>>>
+	    <EMIT <INSTRUCTION `MOVE  <ACSYM .TAC> !<ADDR:VALUE .STR>>>
+	    <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> `O >>
+	    <EMIT <INSTRUCTION `HLRZ  <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
+	    <EMIT <INSTRUCTION `ADD  <ACSYM .TAC> `O >>
+	    <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> <ADDRSYM .NAC>>>
+	    <EMIT <INSTRUCTION `SOJLE  <ACSYM .TAC> |COMPER >>
+	    <RET-TMP-AC .TDAT>)>
+     <EMIT <INSTRUCTION `HRLI  <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+     <TOACV .STR>
+     <MUNG-AC <DATVAL .STR> .STR>
+     <EMIT <INSTRUCTION `SUB  <ACSYM <CHTYPE <DATVAL .STR> AC>> <ADDRSYM .NAC>>>
+     <PUT .NAC ,ACPROT <>>
+     <RET-TMP-AC .NUMN>
+     <COND (<N==? .TPS TUPLE>
+	    <RET-TMP-AC <DATTYP .STR> .STR>
+	    <PUT .STR ,DATTYP .TPS>)>)>
+   <MOVE:ARG .STR .WHERE>>
+
+<GDECL (BACKERS) VECTOR>
+
+<SETG BACKERS
+      [,NO-BACK-ERROR
+       ,NO-BACK-ERROR
+       ,NO-BACK-ERROR
+       ,VEC-BACK-GEN
+       ,VEC-BACK-GEN
+       ,VEC-BACK-GEN
+       ,VEC-BACK-GEN
+       ,NO-BACK-ERROR]>
+
+<DEFINE TOP-GEN (N RW
+		 "AUX" (NN <1 <KIDS .N>>) (TY <RESULT-TYPE .NN>)
+		       (TPS <STRUCTYP .TY>) OAC SAC (FLG <>) W DAC D)
+	#DECL ((N NN) NODE (W D) DATUM (TPS) ATOM (OAC SAC DAC) AC)
+	<SET W <GOODACS .N .RW>>
+	<SET D <GEN .NN <DATUM <COND (<ISTYPE? .TY>) (ELSE .TPS)> ANY-AC>>>
+	<PUT <SET SAC <DATVAL .D>> ,ACPROT T>
+	<COND (<==? <DATVAL .W> <DATVAL .D>> <SET OAC <GETREG <>>> <SET FLG T>)
+	      (<TYPE? <DATVAL .W> AC>
+	       <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT T>
+	       <SET OAC <GETREG <>>>
+	       <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT <>>)
+	      (ELSE <SET OAC <GETREG <>>>)>
+	<EMIT <INSTRUCTION `HLRE  <ACSYM .OAC> <ADDRSYM .SAC>>>
+	<EMIT <INSTRUCTION `SUBM  <ACSYM .SAC> <ADDRSYM .OAC>>>
+	<COND (<AND <NOT .FLG> <TYPE? <DATVAL .W> AC>>
+	       <SET DAC <SGETREG <DATVAL .W> <>>>
+	       <EMIT <INSTRUCTION `MOVEI  <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)
+	      (<OR .FLG <0? <CHTYPE <FREE-ACS T> FIX>>>
+	       <MUNG-AC <SET DAC .SAC> .D>
+	       <EMIT <INSTRUCTION `MOVEI  <ACSYM .SAC> 2 (<ADDRSYM .OAC>)>>)
+	      (ELSE
+	       <PUT .OAC ,ACPROT T>
+	       <SET DAC <GETREG <>>>
+	       <EMIT <INSTRUCTION `MOVEI  <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)>
+	<EMIT <INSTRUCTION `HLR  <ACSYM .OAC> 1 (<ADDRSYM .OAC>)>>
+	<EMIT <INSTRUCTION `HRLI  <ACSYM .OAC> -2 (<ADDRSYM .OAC>)>>
+	<EMIT <INSTRUCTION `SUB  <ACSYM .DAC> <ADDRSYM .OAC>>>
+	<PUT .SAC ,ACPROT <>>
+	<PUT .OAC ,ACPROT <>>
+	<RET-TMP-AC .D>
+	<SET D <DATUM .TPS .DAC>>
+	<PUT .DAC ,ACLINK (.D)>
+	<MOVE:ARG .D .RW>>
+
+<ENDPACKAGE>
+
\ No newline at end of file