5 <USE "NEWSTRUC" "COMPDEC" "ADVMESS" "CHKDCL" "NPRINT" "LIST-HACKS" "MIMGEN">
7 '<DEFMAC DEBUG ("ARGS" X) <FORM PROG () !.X>>
9 <DEFMAC DEBUG ("ARGS" X) T>
11 <DEFINE PEEP (L) <PEEP-PASS1 .L> <DEBUG <PRINC "Peep pass1 done"> <CRLF>>>
13 <DEFINE PEEP-PASS1 (L "AUX" LR (EQV ()) LP LLP (OUTCHAN .OUTCHAN) LBP RETS)
14 #DECL ((LBP RETS LP LLP L LR EQV) LIST (OUTCHAN) <SPECIAL CHANNEL>)
17 #DECL ((WIN) <OR ATOM FALSE> (BF) <OR FALSE LIST>)
22 <REPEAT ((L .L) IT LN EQVP)
24 <COND (<EMPTY? .L> <RETURN>)>
25 <COND (<TYPE? <SET IT <1 .L>> ATOM>
26 <SET EQVP <OR <MEMQ .IT .EQV> <SET EQV (.IT () !.EQV)>>>
28 <SET LBP (.IT .L () !.LBP)>
30 <COND (<EMPTY? .LN> <RETURN>)>
31 <COND (<TYPE? <1 .LN> ATOM>
33 <DEBUG <PRINC "Successive labels ">
38 <PUT .EQVP 2 (<1 .LN> !<2 .EQVP>)>
42 (<AND <TYPE? .IT FORM>
49 <FUNCTION (LL "AUX" (FRM <1 .LL>) M N I LBL A)
50 #DECL ((FRM) <OR FORM ATOM> (M) <OR FALSE LIST> (LBL) ATOM
51 (N) <OR FALSE LIST> (I) FORM (LL) LIST)
52 <COND (<TYPE? .FRM ATOM> <SET BF <>> <MAPRET>)
53 (<==? <1 .FRM> `END> <MAPSTOP>)
54 (<OR <==? <1 .FRM> `OPT-DISPATCH> <==? <1 .FRM> `DISPATCH>>
57 <FUNCTION (F "AUX" LBL P)
59 <PUT .F 1 <SET LBL <FIND-EQV <1 .F> .EQV>>>
60 <BUILD-LABEL-TABLE .LBL .LBP .LL>>
62 <MAPRET !<REST .FRM 3>>)
63 (<OR <SET M <MEMQ + .FRM>>
65 <AND <==? <1 .FRM> `NTHR>
66 <TYPE? <SET A <NTH .FRM <LENGTH .FRM>>> LIST>
67 <==? <1 .A> `BRANCH-FALSE>
68 <SET BF <SET M <REST .A>>>>>
69 <COND (<SET N <MEMQ <SET LBL <FIND-EQV <2 .M> .EQV>> .L>>
71 (<OR <==? .LBL `COMPERR>
74 (T <COMPILE-LOSSAGE "Bad label: " .LBL .M .L>)>
75 <COND (<==? <1 <SET I <1 <NEXTINS .N>>>> `JUMP>
77 <DEBUG <PRINC "Jump to jump ">
83 <CHTYPE <FIND-EQV <3 .I> .EQV> ATOM>>>
85 <BUILD-LABEL-TABLE .LBL .LBP .LL>
87 (<AND <==? <1 .FRM> `JUMP>
88 <MEMQ <1 .I> '[`RETURN `MRETURN `RTUPLE `AGAIN]>>
89 <PUT .LL 1 <FORM !.I>>
92 <DEBUG <PRINC "Jump to RETURNish thing ">
98 (<AND <N==? <1 .FRM> `JUMP>
99 <NOT <EMPTY? <SET LP <REST .LL>>>>
100 <NOT <TYPE? <1 .LP> ATOM>>
101 <==? <1 <SET I <1 .LP>>> `JUMP>
102 <NOT <EMPTY? <SET LLP <REST .LP>>>>
103 <TYPE? <1 .LLP> ATOM>
104 <==? <FIND-EQV <1 .LLP> .EQV> .LBL>
106 <DEBUG <PRINC "Conditional jump followed by JUMP ">
111 <PUT .M 1 <COND (<==? <1 .M> +> -) (ELSE +)>>
114 <SET LBL <CHTYPE <FIND-EQV <3 .I> .EQV> ATOM>>>
115 <PUT .LP 1 <FIND-EQV <1 .LLP> .EQV>>
116 <PATCH-LABEL-TABLE .LBP <1 .LP> .LP>
117 <PUTREST .LP <REST .LLP>>
119 <BUILD-LABEL-TABLE .LBL .LBP .LL>
122 <COND (<N==? .BF .M> <SET BF <>>)>
123 <BUILD-LABEL-TABLE .LBL .LBP .LL>
125 (<==? <1 .FRM> `ICALL>
126 <PUT .FRM 2 <SET LBL <FIND-EQV <2 .FRM> .EQV>>>
128 <BUILD-LABEL-TABLE .LBL .LBP .LL>
130 (T <SET BF <>> <MAPRET>)>>
132 <REPEAT ((L .L) (OL .L) ITM TEM I TF IP TT)
133 #DECL ((L OL) LIST (ITM) ANY)
134 <COND (<EMPTY? .L> <RETURN>)
135 (<AND <TYPE? <1 .L> ATOM> <NOT <MEMQ <1 .L> .LR>>>
136 <PUTREST .OL <REST .L>>
137 <DEBUG <PRINC "Flush extra label "> <PRIN1 <1 .L>> <CRLF>>
139 (<AND <TYPE? <SET ITM <1 .L>> FORM> <==? <1 .ITM> `END>>
141 (<AND <TYPE? .ITM FORM>
142 <SET TEM <OR <MEMQ + .ITM> <MEMQ - .ITM>>>
144 <==? <2 .L> <2 .TEM>>
145 <N==? <SET TEM <1 .ITM>> `SYSOP>
147 <DEBUG <PRINC "Jump to .+1 "> <PRINC .ITM> <CRLF>>
148 <REMOVE-LABEL .LBP <2 .L> .L>
149 <PUTREST .OL <REST .L>>
151 (<AND <TYPE? .ITM FORM>
153 <NOT <EMPTY? <REST .L>>>
155 <==? <1 <2 .L>> `RETURN>
156 <==? <2 .ITM> <2 <2 .L>>>>
157 <PUT <2 .L> 2 <3 .ITM>>
158 <PUTREST .OL <REST .L>>
159 <DEBUG <PRINC "SET-RETURN combo"> <PRINC .ITM><CRLF>>)
160 (<AND <TYPE? .ITM FORM>
161 <OR <AND <==? <1 .ITM> `RETURN>
162 <SET RETS (.L !.RETS)>>
164 '[`JUMP `RTUPLE `MRETURN `AGAIN]>>
166 <NOT <TYPE? <SET ITM <2 .L>> ATOM>>
167 <NOT <AND <TYPE? .ITM FORM>
168 <G=? <LENGTH .ITM> 1>
169 <MEMQ <1 .ITM> '[`END `DEAD `ENDIF]>>>>
170 <DEBUG <PRINC "Unreachable code after ">
175 <PUTREST .L <REST .L 2>>
178 (<AND <TYPE? .ITM FORM>
179 <==? <1 .ITM> `CHTYPE>
180 <TYPE? <SET I <2 .L>> FORM>
183 <==? <2 .I> <5 .ITM>>>
184 ;"Look for 2 CHTYPEs of same thing in a row"
185 <DEBUG <PRINC "Two CHTYPEs in a row ">
191 <PUTREST .L <REST .L 2>>
194 (<AND <TYPE? .ITM FORM>
196 <OR <==? <SET TF <3 .ITM>> <>>
197 <AND <TYPE? .TF FORM>
201 <TYPE? <SET I <2 .L>> FORM>
203 <TYPE? <SET TEM <2 <SET IP <DEST-INS <3 .I> .LBP>>>>
205 <==? <1 .TEM> `TYPE?>
206 <==? <2 .TEM> <2 .ITM>>
207 <TYPE? <SET TT <3 .TEM>> FORM>
208 <==? <1 .TT> `TYPE-CODE>
209 <OR <==? <2 .TT> ATOM> <==? <2 .TT> FALSE>>>
210 <DEBUG <PRINC "Jump to conditional with known condition" >
217 <COND (<JUMP? .TF <2 .TT> <4 .TEM>>
218 <PUT .L 2 <FORM `JUMP + <5 .TEM>>>)
220 <PUT .L 2 <FORM `JUMP +
221 <SET TEM <MAKE-TAG "PEEP">>>>
223 <PUTREST <REST .IP> (.TEM !<REST .IP 2>)>)>
226 (<AND <TYPE? .ITM FORM>
228 <OR <==? <SET TF <3 .ITM>> <>>
229 <AND <TYPE? .TF FORM>
233 <TYPE? <SET TEM <2 .L>> FORM>
234 <==? <1 .TEM> `TYPE?>
235 <==? <2 .TEM> <2 .ITM>>
236 <TYPE? <SET TT <3 .TEM>> FORM>
237 <==? <1 .TT> `TYPE-CODE>
238 <OR <==? <2 .TT> ATOM> <==? <2 .TT> FALSE>>>
239 <DEBUG <PRINC " Conditional with known condition" >
244 <COND (<JUMP? .TF <2 .TT> <4 .TEM>>
245 <PUT .L 2 <FORM `JUMP + <5 .TEM>>>)
247 <PUTREST .L <REST .L 2>>)>
250 (<AND <TYPE? .ITM FORM>
251 <SET ITM <MEMQ = .ITM>>
252 <G=? <LENGTH .ITM> 2>
253 <TYPE? <SET ITM <2 .ITM>> FORM>
255 <==? <2 .ITM> FLUSHED>>
256 <DEBUG <PRINC "Instruction result being flushed: ">
259 <PUTREST .OL <REST .L>>
263 <COND (.WIN <SETG CHANGED T>)
264 (<EQV-CODE .L .LBP .RETS> <SETG CHANGED T>)
268 <DEFINE DEST-INS (ATM:ATOM LBP:<LIST [REST ATOM LIST LIST]>)
270 <COND (<EMPTY? .LBP> <RETURN <>>)>
271 <COND (<==? <1 .LBP> .ATM> <RETURN <2 .LBP>>)>
272 <SET LBP <REST .LBP 3>>>>
274 <DEFINE JUMP? (TF TNAME:ATOM DIR:ATOM)
275 <COND (.TF <SET TF ATOM>) (ELSE <SET TF FALSE>)>
276 <COND (<==? .TF .TNAME>
281 <DEFINE EQV-CODE (L LBLS RETS "AUX" (WIN <>) LB OTS OIP)
282 #DECL ((OTS OIP L RETS) LIST (LBLS) <LIST [REST ATOM LIST LIST]>)
283 <SET L <LREVERSE .L>>
284 <REPEAT (RL LAB) #DECL ((RL) <LIST [REST LIST]> (LAB) LAB)
285 <COND (<EMPTY? .LBLS> <RETURN>)>
287 (<NOT <EMPTY? <SET RL <3 .LBLS>>>>
288 <REPEAT ((TST <REST <2 .LBLS>>)) #DECL ((TST) LIST)
292 <FUNCTION (INSP "AUX" (INS <1 .INSP>))
293 #DECL ((INSP) <LIST ANY> (INS) <FORM ATOM>)
295 (<==? <1 .INS> `JUMP>
296 <SET INSP <REST .INSP>>
297 <REPEAT ((IP .INSP) (TS .TST) ONE TWO)
299 <COND (<AND <TYPE? <SET ONE <1 .IP>> FORM>
300 <TYPE? <SET TWO <1 .TS>> FORM>
301 <==? <LENGTH .ONE:FORM>
303 <NOT <EMPTY? .ONE:FORM>>
304 <N==? <1 .ONE:FORM> `ENDIF>
320 <SET IP <REST <SET OIP .IP>>>
321 <SET TS <REST <SET OTS .TS>>>)
322 (<AND <N==? .TS .TST>
323 <N==? <1 <1 .OIP>> `ENDIF>>
326 (<SET LB <MAKE-TAG "PEEP">>
328 <PUT .OIP 1 <FORM `JUMP + .LB>>
332 <COND (<AND <==? <1 <1 <SET TST <1 .RL>>>:FORM> `JUMP>
333 <NOT <EMPTY? <SET RL <REST .RL>>>>>
334 <SET TST <REST .TST>>)
336 <SET LBLS <REST .LBLS 3>>>
338 (<AND <NOT <EMPTY? .RETS>> <NOT <EMPTY? <REST .RETS>>>>
340 <FUNCTION (RP "AUX" (RI <1 .RP>) (RRP <REST .RP>))
341 #DECL ((RP) <LIST LIST [REST LIST]>
342 (RI) <LIST FORM [REST <OR ATOM FORM>]>
343 (RRP) <LIST [REST LIST]>)
347 <FUNCTION (TST "AUX" Y X)
348 #DECL ((TST) <LIST <FORM ANY>
349 [REST <OR ATOM FORM>]>
350 (X Y) <FORM ANY ANY>)
352 (<AND <==? <1 <SET X <1 .RI>>>
353 <1 <SET Y <1 .TST>>>>
355 <REPEAT ((IP <REST .RI>) (TS <REST .TST>)
358 <LIST [REST <OR ATOM FORM>]>)
360 (<AND <TYPE? <SET ONE <1 .IP>> FORM>
361 <TYPE? <SET TWO <1 .TS>> FORM>
362 <==? <LENGTH .ONE:FORM>
364 <NOT <EMPTY? .ONE:FORM>>
365 <N==? <1 .ONE:FORM> `ENDIF>
381 <SET IP <REST <SET OIP .IP>>>
382 <SET TS <REST <SET OTS .TS>>>)
383 (<AND <N==? .TS <REST .TST>>
384 <N==? <1 <1 .OIP>> `ENDIF>>
387 (<SET LB <MAKE-TAG "PEEP">>
389 <PUT .OTS 1 <FORM `JUMP + .LB>>
394 <SET L <LREVERSE .L>>
397 <DEFINE BUILD-LABEL-TABLE (LBL:ATOM LBP:<LIST [REST ATOM LIST LIST]> L:LIST)
399 <COND (<EMPTY? .LBP> <RETURN>)>
400 <COND (<==? <1 .LBP> .LBL>
401 <3 .LBP (.L !<3 .LBP>)>
403 <SET LBP <REST .LBP 3>>>>
405 <DEFINE PATCH-LABEL-TABLE (LBP:<LIST [REST ATOM LIST LIST]> ATM:ATOM L:LIST)
407 <COND (<EMPTY? .LBP> <RETURN>)>
408 <COND (<==? <1 .LBP> .ATM>
411 <SET LBP <REST .LBP 3>>>>
413 <DEFINE REMOVE-LABEL (LBP:<LIST [REST ATOM LIST LIST]> ATM:ATOM L:LIST)
415 <COND (<EMPTY? .LBP> <RETURN>)>
416 <COND (<==? <1 .LBP> .ATM>
417 <SET B <SET A <3 .LBP>>>
419 <COND (<EMPTY? .A> <RETURN>)>
420 <COND (<==? <1 .A> .L>
424 <PUTREST .B <REST .A>>)>
429 <SET LBP <REST .LBP 3>>>>
432 #DECL ((L VALUE) LIST)
434 <FUNCTION (LL "AUX" (ITM <1 .LL>))
435 #DECL ((ITM) <OR ATOM FORM> (LL) <LIST <OR ATOM FORM>>)
436 <COND (<TYPE? .ITM FORM> <MAPLEAVE .LL>)>>
439 <DEFINE FIND-EQV (ATM EQVL)
440 #DECL ((VALUE ATM) ATOM (EQVL) <LIST [REST ATOM <LIST [REST ATOM]>]>)
441 <COND (<OR <==? .ATM `COMPERR> <==? .ATM `UNWCONT>> .ATM)
444 <COND (<MEMQ .ATM <2 .EQVL>> <RETURN <1 .EQVL>>)>
445 <COND (<EMPTY? <SET EQVL <REST .EQVL 2>>>