--- /dev/null
+<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>
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff