3 <ENTRY BACK-GEN TOP-GEN>
5 <USE "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD" "STRGEN">
8 <DEFINE BACK-GEN (NOD WHERE
9 "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
11 (NUMKN <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>)
12 (NUM <COND (.NUMKN <NODE-NAME <2 .K>>) (ELSE 0)>))
13 #DECL ((NUMKN) <OR ATOM FALSE> (NUM) FIX (TPS) ATOM (NOD) NODE
14 (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
15 <APPLY <NTH ,BACKERS <LENGTH <MEMQ .TPS ,STYPES>>>
25 <DEFINE NO-BACK-ERROR (NOD "TUPLE" ERR)
26 <MESSAGE INCONSISTENCY "CANT OPEN-COMPILE BACK" .ERR .NOD>>
28 <DEFINE VEC-BACK-GEN (NODE WHERE TYP TPS NUMKN NUM STRNOD NUMNOD
29 "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
30 (CAREFL <AND .CAREFUL <N==? .TPS TUPLE>>)
31 (UV? <==? .TPS UVECTOR>) NAC SAC STR NUMN (RV <>)
32 TAC TDAT (W <GOODACS .NODE .WHERE>))
33 #DECL ((NOD NUMNOD STRNOD) NODE (W TDAT STR NUMN) DATUM (TAC SAC NAC) AC (NUM) FIX
34 (NO-KILL) <SPECIAL LIST> (RV CAREFL UV?) <OR ATOM FALSE>)
37 <COND (<L? .NUM 0> <MESSAGE INCONSISTENCY "ARG OUT OF RANGE BACK" .NODE>)
38 (<0? .NUM> <SET STR <GEN .STRNOD .W>>)
40 <SET STR <GEN .STRNOD .W>>
42 <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
44 <PUT .TDAT ,DATVAL .TAC>
45 <SET TAC <DATVAL .TDAT>>
46 <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .STR>>>
47 <EMIT <INSTRUCTION `MOVE <ACSYM .TAC> !<ADDR:VALUE .STR>>>
48 <EMIT <INSTRUCTION `SUB <ACSYM .TAC> `O >>
49 <EMIT <INSTRUCTION `HLRZ <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
50 <EMIT <INSTRUCTION `ADD <ACSYM .TAC> `O >>
51 <EMIT <INSTRUCTION `SUBI
53 <+ <COND (.UV? .NUM) (ELSE <* .NUM 2>)>
55 <EMIT <INSTRUCTION `JUMPLE <ACSYM .TAC> |COMPER >>
58 <SET SAC <DATVAL .STR>>
60 <EMIT <INSTRUCTION `SUB
62 <COND (.UV? [<FORM (.NUM) .NUM>])
64 [<FORM (<* .NUM 2>) <* .NUM 2>>])>>>)>)
66 <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
67 <COND (.RV <SET NUMN <GEN .NUMNOD DONT-CARE>> <SET STR <GEN .STRNOD .W>>)
68 (<SET STR <GEN .STRNOD .W>> <SET NUMN <GEN .NUMNOD DONT-CARE>>)>
69 <DELAY-KILL .NO-KILL .ONO>
71 <SET NAC <DATVAL .NUMN>>
73 <COND (<NOT .UV?> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
75 <EMIT <INSTRUCTION `JUMPL <ACSYM .NAC> |COMPER >>
76 <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
77 <PUT .TDAT ,DATVAL .TAC>
78 <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .STR>>>
79 <EMIT <INSTRUCTION `MOVE <ACSYM .TAC> !<ADDR:VALUE .STR>>>
80 <EMIT <INSTRUCTION `SUB <ACSYM .TAC> `O >>
81 <EMIT <INSTRUCTION `HLRZ <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
82 <EMIT <INSTRUCTION `ADD <ACSYM .TAC> `O >>
83 <EMIT <INSTRUCTION `SUB <ACSYM .TAC> <ADDRSYM .NAC>>>
84 <EMIT <INSTRUCTION `SOJLE <ACSYM .TAC> |COMPER >>
86 <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
88 <MUNG-AC <DATVAL .STR> .STR>
89 <EMIT <INSTRUCTION `SUB <ACSYM <CHTYPE <DATVAL .STR> AC>> <ADDRSYM .NAC>>>
92 <COND (<N==? .TPS TUPLE>
93 <RET-TMP-AC <DATTYP .STR> .STR>
94 <PUT .STR ,DATTYP .TPS>)>)>
95 <MOVE:ARG .STR .WHERE>>
97 <GDECL (BACKERS) VECTOR>
109 <DEFINE TOP-GEN (N RW
110 "AUX" (NN <1 <KIDS .N>>) (TY <RESULT-TYPE .NN>)
111 (TPS <STRUCTYP .TY>) OAC SAC (FLG <>) W DAC D)
112 #DECL ((N NN) NODE (W D) DATUM (TPS) ATOM (OAC SAC DAC) AC)
113 <SET W <GOODACS .N .RW>>
114 <SET D <GEN .NN <DATUM <COND (<ISTYPE? .TY>) (ELSE .TPS)> ANY-AC>>>
115 <PUT <SET SAC <DATVAL .D>> ,ACPROT T>
116 <COND (<==? <DATVAL .W> <DATVAL .D>> <SET OAC <GETREG <>>> <SET FLG T>)
117 (<TYPE? <DATVAL .W> AC>
118 <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT T>
119 <SET OAC <GETREG <>>>
120 <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT <>>)
121 (ELSE <SET OAC <GETREG <>>>)>
122 <EMIT <INSTRUCTION `HLRE <ACSYM .OAC> <ADDRSYM .SAC>>>
123 <EMIT <INSTRUCTION `SUBM <ACSYM .SAC> <ADDRSYM .OAC>>>
124 <COND (<AND <NOT .FLG> <TYPE? <DATVAL .W> AC>>
125 <SET DAC <SGETREG <DATVAL .W> <>>>
126 <EMIT <INSTRUCTION `MOVEI <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)
127 (<OR .FLG <0? <CHTYPE <FREE-ACS T> FIX>>>
128 <MUNG-AC <SET DAC .SAC> .D>
129 <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> 2 (<ADDRSYM .OAC>)>>)
132 <SET DAC <GETREG <>>>
133 <EMIT <INSTRUCTION `MOVEI <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)>
134 <EMIT <INSTRUCTION `HLR <ACSYM .OAC> 1 (<ADDRSYM .OAC>)>>
135 <EMIT <INSTRUCTION `HRLI <ACSYM .OAC> -2 (<ADDRSYM .OAC>)>>
136 <EMIT <INSTRUCTION `SUB <ACSYM .DAC> <ADDRSYM .OAC>>>
137 <PUT .SAC ,ACPROT <>>
138 <PUT .OAC ,ACPROT <>>
140 <SET D <DATUM .TPS .DAC>>
141 <PUT .DAC ,ACLINK (.D)>