4 <ENTRY PROG-REP-GEN RETURN-GEN AGAIN-GEN ACTIV? MULTI-RETURN-GEN>
6 <USE "COMPDEC" "CODGEN" "CHKDCL" "MIMGEN" "ADVMESS" "NOTGEN">
8 " Generate code for a poor innocent PROG or REPEAT."
12 <DEFINE PROG-REP-GEN (PNOD PWHERE
13 "OPT" (NOTF <>) (BRANCH <>) (DIR <>)
14 "AUX" START-TAG (BASEF .BASEF) EXIT AGAIN (CD <>)
16 <COND (<==? .PWHERE FLUSHED> FLUSHED)
17 (<==? .PWHERE DONT-CARE> <GEN-TEMP <>>)
18 (ELSE .PWHERE)>) (K <KIDS .PNOD>) TEM SPECD
19 (ORPNOD <AND <ASSIGNED? RPNOD> .RPNOD>) RPNOD
20 BNDTMP (OTMPS .TMPS) (OTMPS-NEXT .TMPS-NEXT)
21 (OFREE-TEMPS .FREE-TEMPS) RDEST
22 (RT <RESULT-TYPE <NTH .K <LENGTH .K>>>)
23 (FOK <TYPE-OK? .RT FALSE>)
24 (TRUE-OK <N==? <ISTYPE? .RT> FALSE>) (STK 0)
25 (STK-CHARS7 0) (STK-CHARS8 0) STKTMP)
26 #DECL ((NTSLOTS STB) <SPECIAL LIST> (BASEF PNOD RPNOD) <SPECIAL NODE>
27 (START-TAG) <SPECIAL ATOM> (K) <LIST [REST NODE]>
28 (STK-CHARS7 STK-CHARS8 STK) <SPECIAL FIX> (STKTMP) <SPECIAL ANY>
29 (SPECD) <SPECIAL ANY>)
30 <COND (<AND <OR <ACTIVATED .PNOD> <ACTIV? <BINDING-STRUCTURE .PNOD>>>
33 <PROG ((TMPS .TMPS) (TMPS-NEXT .TMPS-NEXT) (FREE-TEMPS .FREE-TEMPS)
34 (ALL-TEMPS-LIST .ALL-TEMPS-LIST) MYFRAME)
35 #DECL ((TMPS-NEXT FREE-TEMPS ALL-TEMPS-LIST) <SPECIAL LIST>
36 (TMPS) <SPECIAL FORM>)
37 <COND (<N==? <NODE-SUBR .PNOD> ,BIND> <SET RPNOD .PNOD>)
38 (.ORPNOD <SET RPNOD .ORPNOD>)>
40 <SET EXIT <MAKE-TAG "EXIT">>
41 <COND (<OR <ACTIVATED .PNOD> <ACTIV? <BINDING-STRUCTURE .PNOD>>>
42 <PUT .PNOD ,ACTIVATED T>
45 ((.TMPS .TMPS-NEXT .FREE-TEMPS <>) !.ALL-TEMPS-LIST)>
46 <COND (<==? .DEST FLUSHED> <IEMIT `ICALL .EXIT>)
47 (ELSE <IEMIT `ICALL .EXIT = .DEST>)>
51 <SET MYFRAME <GEN-TEMP>>
53 <PUT <1 .ALL-TEMPS-LIST> 4 .MYFRAME>
54 <COND (<NOT <==? .PWHERE FLUSHED>> <SET DEST <GEN-TEMP <>>>)>)>
56 <COND (<ACTIVATED .PNOD> <BIND-CODE .PNOD>)
57 (ELSE <BIND-CODE .PNOD T <SET BNDTMP <GEN-TEMP <>>>>)>>
59 <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
61 <LABEL-TAG <SET AGAIN <MAKE-TAG "AGAIN">>>
62 <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
64 <COND (.NOTF <SET DIR <NOT .DIR>>)>
65 <PUT .PNOD ,CDST <COND (.BRANCH (.BRANCH .DIR)) (ELSE ,NO-DATUM)>>
66 <PUT .PNOD ,DST .DEST>
67 <PUT .PNOD ,SPCS-X .SPECD>
68 <PUT .PNOD ,ATAG .AGAIN>
69 <PUT .PNOD ,RTAG .EXIT>
70 <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
71 <COND (<==? <NODE-SUBR .PNOD> ,REPEAT>
72 <SET TEM <SEQ-GEN .K FLUSHED>>)
74 <COND (<AND .BRANCH .FOK .TRUE-OK>
75 <SET TEM <PSEQ-GEN .K FLUSHED .BRANCH .DIR <>>>)
76 (<AND .BRANCH <COND (.DIR .TRUE-OK) (ELSE .FOK)>>
77 <SET TEM <SEQ-GEN .K FLUSHED>>
79 (ELSE <SET TEM <SEQ-GEN .K FLUSHED>>)>)
81 <SET TEM <SET CD <SEQ-GEN .K .DEST>>>
82 <COND (<==? .TEM ,NO-DATUM>
83 <COND (<EMPTY? <CDST .PNOD>> <SET CD ,NO-DATUM>)
84 (ELSE <SET CD <CDST .PNOD>>)>)
85 (<==? <CDST .PNOD> ,NO-DATUM>
86 <PUT .PNOD ,CDST .CD>)>)>)
88 <COND (<==? .DEST FLUSHED>
89 <COND (<AND .BRANCH .FOK .TRUE-OK>
90 <SET TEM <PSEQ-GEN .K FLUSHED .BRANCH .DIR <>>>)
91 (<AND .BRANCH <COND (.DIR .TRUE-OK) (ELSE .FOK)>>
92 <SET TEM <SEQ-GEN .K FLUSHED>>
94 (ELSE <SET TEM <SEQ-GEN .K FLUSHED>>)>)
96 <SET TEM <SET CD <SEQ-GEN .K .DEST T>>>
97 <COND (<==? .TEM ,NO-DATUM>
98 <COND (<OR <EMPTY? <CDST .PNOD>>
99 <==? <CDST .PNOD> ,NO-DATUM>>
101 (ELSE <SET CD <CDST .PNOD>>)>)
102 (<==? <CDST .PNOD> ,NO-DATUM>
103 <PUT .PNOD ,CDST .CD>)>)>)>
104 <COND (<NOT <ASSIGNED? NPRUNE>> <PUT .PNOD ,KIDS ()>)>
105 <COND (<N==? <NODE-SUBR .PNOD> ,REPEAT>
106 <COND (<ACTIVATED .PNOD> <PROG-END .DEST> <FREE-TEMP .MYFRAME>)
107 (.SPECD <IEMIT `UNBIND .BNDTMP> <FREE-TEMP .BNDTMP>)>)
108 (ELSE <BRANCH-TAG .AGAIN>)>
110 <COND (<N==? .STK-CHARS8 0>
111 <SET STK-CHARS8 <+ .STK-CHARS8 .STK>>
112 <SET STK-CHARS7 <+ .STK-CHARS7 .STK>>
114 <COND (<ACTIVATED .PNOD>)
116 <COND (<ASSIGNED? STKTMP>
118 <IEMIT `SUB .STKTMP .STK = .STKTMP (`TYPE FIX)>)
119 (<N==? .STK-CHARS7 0>
120 <IEMIT `IFSYS "TOPS20">
121 <IEMIT `SUB .STKTMP .STK-CHARS7 = .STKTMP>
122 <IEMIT `ENDIF "TOPS20">
123 <IEMIT `IFSYS "UNIX">
124 <IEMIT `SUB .STKTMP .STK-CHARS8 = .STKTMP>
125 <IEMIT `ENDIF "UNIX">)>
128 (<N==? .STK 0> <IEMIT `ADJ <- .STK>>)
129 (<N==? .STK-CHARS8 0>
130 <IEMIT `IFSYS "TOPS20">
131 <IEMIT `ADJ <- .STK-CHARS7>>
132 <IEMIT `ENDIF "TOPS20">
133 <IEMIT `IFSYS "UNIX">
134 <IEMIT `ADJ <- .STK-CHARS8>>
135 <IEMIT `ENDIF "UNIX">)>
136 <SET OFREE-TEMPS .FREE-TEMPS>)>>
137 <SET FREE-TEMPS .OFREE-TEMPS>
138 <SET TMPS-NEXT <REST .TMPS <- <LENGTH .TMPS> 1>>>
139 <COND (<OR <==? <CDST .PNOD> ,NO-DATUM> .BRANCH>
140 <COND (<AND <ACTIVATED .PNOD> <N==? .PWHERE FLUSHED>>
141 <MOVE-ARG .RDEST .PWHERE>)
143 (ELSE <MOVE-ARG .RDEST .PWHERE>)>>
145 <DEFINE PROG-END (RESULT)
146 <COND (<==? .RESULT FLUSHED> <MIM-RETURN T>)
147 (ELSE <MIM-RETURN .RESULT>)>>
150 #DECL ((BST) <LIST [REST SYMTAB]>)
152 <COND (<EMPTY? .BST> <RETURN <>>)>
153 <COND (<AND <==? <CODE-SYM <1 .BST>> ,ARGL-ACT>
154 <OR <NOT <RET-AGAIN-ONLY <1 .BST>>>
155 <SPEC-SYM <1 .BST>>>>
157 <SET BST <REST .BST>>>>
161 " Generate code for a RETURN."
163 <DEFINE RETURN-GEN (NOD WHERE
164 "AUX" N NN (CD1 <>) DEST (NF 0) LL RT (FOK <>) RTA)
165 #DECL ((NOD N RPNOD) NODE (NF) FIX)
167 <COND (<1? <LENGTH <KIDS .NOD>>> <SET N .RPNOD>)
168 (<SET NN <RET-AGAIN-ONLY <NODE-NAME <2 <KIDS .NOD>>>>> <SET N .NN>)
169 (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
172 (<==? <SET DEST <DST .N>> FLUSHED>
174 (<AND <TYPE? <SET LL <CDST .N>> LIST> <N==? .LL ,NO-DATUM>>
176 (<AND <TYPE-OK? <SET RT <RESULT-TYPE <SET NN <1 <KIDS .NOD>>>>>
179 <N==? <ISTYPE? .RT> FALSE>>
180 <PRED-BRANCH-GEN <1 .LL> .NN <2 .LL> FLUSHED <>>)
181 (<COND (<2 .LL> <NOT .FOK>) (ELSE .FOK)>
182 <COND (<N==? <NODE-TYPE .NN> ,QUOTE-CODE> <GEN .NN FLUSHED>)>
184 (<N==? <NODE-TYPE .NN> ,QUOTE-CODE> <GEN .NN FLUSHED>)>)
185 (ELSE <GEN <1 <KIDS .NOD>> FLUSHED>)>)
187 <COND (<==? .DEST DONT-CARE> <SET DEST <GEN-TEMP <>>>)>
188 <SET CD1 <GEN <1 <KIDS .NOD>> .DEST>>
189 <COND (<==? <DST .N> DONT-CARE> <PUT .N ,DST .CD1>)>
190 <COND (<N==? <CDST .N> ,NO-DATUM> <DEALLOCATE-TEMP .CD1>)>
191 <PUT .N ,CDST .CD1>)>
192 <COND (<ACTIVATED .N> <PROG-END .DEST>)
194 <COND (<SPCS-X .N> <IEMIT `UNBIND <SPCS-X .N>>)>
198 <DEFINE MULTI-RETURN-GEN (NOD WHERE
199 "AUX" (K <KIDS .NOD>) NN (CD1 <>) DEST FTMP
200 (N <1 .K>) (LOCAL <>) FR SEGTMP (I 0))
201 #DECL ((NOD N RPNOD) NODE)
203 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
206 <COND (<ASSIGNED? SEGLABEL> <SET FTMP .COUNTMP>)>)
207 (<AND <==? <NODE-TYPE .N> ,LVAL-CODE>
208 <SET NN <RET-AGAIN-ONLY <NODE-NAME .N>>>>
211 (ELSE <SET FR <GEN .N DONT-CARE>>)>
215 <COND (<N==? <NODE-TYPE .N> ,SEGMENT-CODE>
219 <FUNCTION (NOD "AUX" TG STYP N TT)
221 <COND (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
222 <COND (<NOT <ASSIGNED? SEGTMP>>
223 <COND (<ASSIGNED? FTMP>
225 <IEMIT `ADD .FTMP .I = .FTMP>)>)
227 <SET FTMP <GEN-TEMP>>
228 <IEMIT `SET .FTMP .I>)>
229 <SET SEGTMP <GEN-TEMP <>>>)>
230 <SET STYP <STRUCTYP-SEG
231 <RESULT-TYPE <SET N <1 <KIDS .NOD>>>>>>
238 <ISTYPE? <RESULT-TYPE .N>>>)
240 <PROG ((SEGLABEL <MAKE-TAG>) (COUNTMP .FTMP)
242 #DECL ((SEGLABEL COUNTMP SEGCALLED)
244 <SET RES <GEN .N .SEGTMP>>
245 <COND (<OR <N==? .RES ,NO-DATUM>
247 <SEGMENT-STACK .SEGTMP
250 <ISTYPE? <RESULT-TYPE .N>>
253 <LABEL-TAG .SEGLABEL>)>>)>)
254 (ELSE <GEN .NOD ,POP-STACK>)>>
257 <OR <==? <SET DEST <DST .N>> FLUSHED>
258 <NOT <ASSIGNED? SEGLABEL>>>>
259 <COMPILE-ERROR "MULTI-RETURN to nothing" .NOD>)
260 (<AND .LOCAL <ASSIGNED? SEGLABEL>>
261 <COND (<NOT <ASSIGNED? SEGTMP>> <IEMIT `SET .FTMP .I>)>
262 <COND (<SPCS-X .N> <IEMIT `UNBIND <SPCS-X .N>>)>
263 <BRANCH-TAG .SEGLABEL>)
265 <IEMIT `MRETURN <COND (<ASSIGNED? FTMP> .FTMP) (ELSE .I)> .FR>)>
270 " Generate code for an AGAIN."
272 <DEFINE AGAIN-GEN (NOD WHERE "AUX" N NN)
273 #DECL ((NOD N RPNOD) NODE)
275 <COND (<EMPTY? <KIDS .NOD>> <SET N .RPNOD>)
276 (<SET NN <RET-AGAIN-ONLY <NODE-NAME <1 <KIDS .NOD>>>>>
278 (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
279 <BRANCH-TAG <ATAG .N>>
282 <DEFINE UNBIND-LOCS () T>