5 <USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN">
8 "ROUTINES TO GENERATE SUBSTRUCT FOR THE COMPILER. CURRENTLY ONLY
\r
9 HACKS UVECTOR AND VECTOR
10 CASES 1) COPYING (ALWAYS HACKED) (I.E 1 ARG)
11 2) COPYING PORTIONS (2 OR 3 ARGS) (ALWAYS HACKED)
12 3) COPYING INTO STRUCTURES HACKED IN 2 CASES
13 <SUBSTRUC .X .N1 .N2 <REST .X>>
14 <SUBSTRUC <REST .X> .N1 .N2 .X>"
16 "NODE STRUCTURE IS FAIRLY MUNGED TO ALLOW FOR REASONABILITY.
18 THIS IS ACTUALLY RESTED
19 2==> NUMBER NODE (IF IT EXISTS)
20 3==> RESTED STRUCTURE NODE (IF IT EXISTS)
21 DECISION AS TO FOURTH ARG WILL TRY TO BE MADE DURING PASS1 OR SYMANA"
23 <DEFINE SUBSTRUC-GEN (NOD WHERE
24 "AUX" (K <KIDS .NOD>) (STRNOD <1 .K>)
25 (TPS <STRUCTYP <RESULT-TYPE .STRNOD>>) L)
26 #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
27 <COND (<1? <SET L <LENGTH .K>>> <COPY-SB-GEN .STRNOD .TPS .WHERE>)
28 (<==? .L 2> <COPY-ELE-SB-GEN .STRNOD .TPS <2 .K> .WHERE>)
29 (<==? .L 3> <COPY-INTO-SB-GEN .STRNOD .TPS <2 .K> <3 .K> .WHERE>)
30 (<MESSAGE INCONSISTENCY "BAD NODE TO SUBSTRUC">)>>
34 "ROUTINE TO COPY INTO A NEW STRUCTION (1 OR 2 ARGUMENT SUBSTRUCTS."
36 <DEFINE COPY-SB-GEN (STRNOD TPS WHERE
37 "AUX" SDAT TDAT NDAT NAC SAC (END-LABEL <MAKE:TAG "SUB">)
39 #DECL ((STRNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
40 (SDAT TDAT NDAT) DATUM (TAC NAC SAC) AC)
41 <SET SDAT <GEN .STRNOD DONT-CARE>>
42 <COND (<==? <DATVAL .SDAT> ,AC-A>
44 <EMIT <INSTRUCTION `HLRE `A* `A >>)
46 <EMIT <INSTRUCTION `HLRE `A* !<ADDR:VALUE .SDAT>>>)>
48 <EMIT <INSTRUCTION `MOVNS `A >>
49 <EMIT <INSTRUCTION `PUSH `P* `A >>
50 <SET TDAT <GEN-COPY .TPS>>
51 <SET TAC <DATVAL .TDAT>>
53 <SET NDAT <DATUM FIX ANY-AC>>
54 <SET NAC <GETREG .NDAT>>
55 <PUT .NDAT ,DATVAL .NAC>
56 <SET NAC <DATVAL .NDAT>>
57 <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
58 <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
59 <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
62 <SET SAC <DATVAL .SDAT>>
63 <BLTAC .SAC .TAC .NAC <==? .TPS UVECTOR> .SDAT>
69 <LABEL:TAG .END-LABEL>
70 <MOVE:ARG .TDAT .WHERE>>
74 "HERE FOR 3 ARGUMENT SUBSTRUCS"
76 <DEFINE COPY-ELE-SB-GEN (STRNOD TPS NUMNOD WHERE
77 "AUX" TDAT (SDAT <>) NDAT
79 <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
80 <NODE-NAME .NUMNOD>)>) TAC
81 (END-LABEL <MAKE:TAG "SUB">) (ONO .NO-KILL)
82 (NO-KILL .ONO) NAC SAC)
83 #DECL ((STRNOD NUMNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
84 (SDAT) <OR FALSE DATUM> (NDAT TDAT) DATUM (TAC NAC SAC) AC
85 (NO-KILL) <SPECIAL LIST>)
87 <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
89 <COND (<==? .TPS VECTOR>
90 <EMIT <INSTRUCTION `MOVEI `A* <* .NUM 2>>>)
91 (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `MOVEI `A* .NUM>>)
92 (<MESSAGE INCONSISTENCY "BAD SUBSTRUC NODE">)>
93 <SET TDAT <GEN-COPY .TPS>>
94 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
95 <PUT <SET SAC <DATVAL .SDAT>> ,ACPROT T>
97 <SET TAC <DATVAL .TDAT>>
100 (<COND (.CAREFUL <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>)>
101 <BLTAC+NUM .SAC .TAC .NUM <> .TPS .SDAT>
102 <COND (<==? .TPS UVECTOR>
103 <SET NAC <GETREG <>>>
104 <EMIT <INSTRUCTION `MOVE
106 !<ADDR:VALUE .TDAT>>>
107 <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .NAC>>>
108 <EMIT <INSTRUCTION `SUB <ACSYM .NAC> 0>>
109 <UVECTOR-MUNG-SB .SDAT .NAC>)>)>)
111 <COND (<NOT <COMMUTE-STRUC <> .STRNOD .NUMNOD>>
112 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)>
113 <SET NDAT <DATUM FIX ,AC-A>>
114 <SET NAC <SGETREG ,AC-A <>>>
115 <SET NDAT <GEN .NUMNOD .NDAT>>
117 <EMIT <INSTRUCTION `JUMPL <ACSYM <DATVAL .NDAT>> |CERR1 >>)>
118 <COND (<==? .TPS VECTOR>
119 <EMIT <INSTRUCTION `ASH <ACSYM <DATVAL .NDAT>> 1>>
120 <MUNG-AC .NAC .NDAT T>)>
121 <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM .NAC>>>
124 <SET TDAT <GEN-COPY .TPS>>
125 <COND (.SDAT <TOACV .SDAT>)
126 (<SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
127 <DELAY-KILL .NO-KILL .ONO>)>
128 <SET SAC <DATVAL .SDAT>>
131 <SET TAC <DATVAL .TDAT>>
133 <SET NAC <GETREG <>>>
134 <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
135 <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
136 <COND (.CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>)>
137 <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
139 <BLTAC .SAC .TAC .NAC <> .SDAT>
140 <PUT .NAC ,ACPROT <>>
141 <PUT .TAC ,ACPROT <>>
142 <PUT .SAC ,ACPROT <>>
144 <AND <==? .TPS UVECTOR> <UVECTOR-MUNG-SB .SDAT .NAC>>)>
146 <LABEL:TAG .END-LABEL>
147 <MOVE:ARG .TDAT .WHERE>>
151 "ROUTINE TO COPY INTO A UVECTOR OR VECTOR
152 <SUBSTRUC .X .N1 .N2 <REST .X>> or
153 <SUBSTRUC <REST .X> .N1 .N2 .X>."
155 <DEFINE COPY-INTO-SB-GEN (STRNOD TPS NUMNOD CPYNOD WHERE
156 "AUX" NDAT TDAT SDAT SAC TAC NAC
158 <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
159 <NODE-NAME .NUMNOD>)>) RV FLG DDAT DAC
160 (ONO .NO-KILL) (NO-KILL .ONO) TEM TEM2
161 (OTHN <>) END-LABEL RR)
162 #DECL ((STRNOD NUMNOD CPYNOD) NODE (WHERE) <OR ATOM DATUM>
163 (NDAT DDAT TDAT SDAT) DATUM (DAC NAC TAC SAC) AC
164 (NO-KILL) <SPECIAL LIST>)
165 <SET FLG <SUB-CASE-1 .STRNOD .CPYNOD>>
166 <COND (<AND <==? <NODE-TYPE <SET TEM <2 <KIDS .STRNOD>>>> ,QUOTE-CODE>
167 <OR <AND <==? <NODE-TYPE .CPYNOD> ,LVAL-CODE> <SET TEM2 0>>
168 <AND <==? <NODE-TYPE .CPYNOD> ,REST-CODE>
169 <==? <NODE-TYPE <SET TEM2 <2 <KIDS .CPYNOD>>>>
171 <SET TEM2 <NODE-NAME .TEM2>>>>>
172 <SET OTHN <ABS <- <NODE-NAME .TEM> .TEM2>>>
173 <OR <==? .TPS UVECTOR> <SET OTHN <* .OTHN 2>>>)>
176 <SET RV <COMMUTE-STRUC <> .STRNOD .CPYNOD>>
177 <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
179 <SET TDAT <GEN .CPYNOD DONT-CARE>>
180 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
182 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
183 <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
189 <SET SAC <DATVAL .SDAT>>
192 <SET TAC <DATVAL .TDAT>>
193 <PUT .SAC ,ACPROT <>>
195 <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>
196 <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)>
198 <BLTAC+NUM .SAC .TAC .NUM <> .TPS <>>)
201 <SET SAC <DATVAL .SDAT>>
202 <MUNG-AC .SAC .SDAT <>>
204 <COND (.OTHN <PUT <SET DAC <GETREG <>>> ,ACPROT T>)
206 <SET DDAT <DATUM .TPS ANY-AC>>
207 <SET DAC <GETREG .DDAT>>
208 <PUT .DDAT ,DATVAL .DAC>
209 <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>
211 <COND (<NOT .CAREFUL>
212 <EMIT <INSTRUCTION `SUBI
214 (<ADDRSYM .SAC>)>>)>)>
215 <REST-IT .SAC <- .NUM 1> .TPS>
217 <COND (.OTHN <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)
219 <REST-IT .DAC <- .NUM 1> .TPS>
220 <EMIT <INSTRUCTION `SUBI
222 (<ADDRSYM .SAC>)>>)>)>
223 <BBLT .SAC .DAC .NUM .OTHN .TPS>
224 <PUT .DAC ,ACPROT <>>
226 <OR .OTHN <RET-TMP-AC .DDAT>>)>)>)
228 <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
230 <AND <COMMUTE-STRUC <> .CPYNOD .NUMNOD>
231 <COMMUTE-STRUC <> .CPYNOD .STRNOD>>>
232 <COND (.RR <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
234 <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>
235 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
237 <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
238 <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>)>
239 <DELAY-KILL .NO-KILL .ONO>
240 <COND (<NOT .RR> <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
242 <SET NAC <DATVAL .NDAT>>
244 <EMIT <INSTRUCTION `JUMPE
246 <SET END-LABEL <MAKE:TAG "SUBSTR">>>>
247 <COND (.CAREFUL <EMIT <INSTRUCTION `JUMPL <ACSYM .NAC> |CERR1 >>)>
248 <MUNG-AC .NAC .NDAT T>
252 <SET SAC <DATVAL .SDAT>>
254 <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
255 <AND .CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>>
256 <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
257 <EMIT <INSTRUCTION `ADD <ACSYM .NAC> !<ADDR:VALUE .TDAT>>>
258 <AND .CAREFUL <RCHK .NAC T>>
259 <PUT .NAC ,ACPROT <>>
260 <PUT .SAC ,ACPROT <>>
261 <BLTAC+DAT .SAC .TDAT .NAC>)
263 <COND (.OTHN <SET DAC <GETREG <>>>)
265 <SET DDAT <DATUM .TPS ANY-AC>>
266 <SET DAC <GETREG .DDAT>>
267 <PUT .DDAT ,DATVAL .DAC>
268 <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>)>
269 <EMIT <INSTRUCTION `SUBI <ACSYM .NAC> 1>>
270 <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
271 <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
274 <SET SAC <DATVAL .SDAT>>
276 <COND (<AND <NOT .CAREFUL> <NOT .OTHN>>
277 <EMIT <INSTRUCTION `SUBI <ACSYM .DAC> (<ADDRSYM .SAC>)>>)>
278 <REST-IT .SAC .NAC .TPS>
281 <COND (<NOT <0? .OTHN>>
282 <EMIT <INSTRUCTION `CAML
284 [<FORM (<- .OTHN>) 0>]>>
285 <EMIT '<`JRST |CERR2 >>)>)
287 <REST-IT .DAC .NAC .TPS>
288 <EMIT <INSTRUCTION `SUBI
290 (<ADDRSYM .SAC>)>>)>)>
291 <BBLT .SAC .DAC .NAC .OTHN .TPS>
292 <PUT .SAC ,ACPROT <>>
293 <PUT .NAC ,ACPROT <>>
294 <PUT .DAC ,ACPROT <>>
295 <OR .OTHN <RET-TMP-AC .DDAT>>)>
297 <LABEL:TAG .END-LABEL>)>
299 <MOVE:ARG .TDAT .WHERE>>
303 "ROUTINE TO GENERATE A CALL TO IBLOCK AND ALSO GENERATE THE APPROPRIATE DATUM"
305 <DEFINE GEN-COPY (TPS "AUX" (DAT <DATUM .TPS ,AC-B>))
306 #DECL ((DAT) DATUM (TPS) ATOM)
308 <COND (<==? .TPS UVECTOR>
309 <EMIT <INSTRUCTION `MOVEI `O |IBLOCK >>)
310 (<EMIT <INSTRUCTION `MOVEI `O 1 |IBLOK1 >>)>
311 <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
314 "ROUTINES TO DETERMINE THE CASE OF THE SUBSTRUC WITH 4 ARGUMENTS"
316 "SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
317 BLTS ARE ALWAYS POSSIBLE.
318 STRNOD== NODE OF STRUCTURE
319 CPYNOD== NODE OF STRUCTURE TO COPY INTO"
321 <DEFINE SUB-CASE-1 (STRNOD CPYNOD
322 "AUX" (DATA <GET-SUB-DATA .STRNOD>)
323 (DATAC <GET-SUB-DATA .CPYNOD>))
324 #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
327 <==? <1 .DATA> <1 .DATAC>>
328 <TYPE? <2 .DATAC> FIX>
330 <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
332 <DEFINE SUB-CASE-2 (STRNOD CPYNOD
333 "AUX" (DATA <GET-SUB-DATA .STRNOD>)
334 (DATAC <GET-SUB-DATA .CPYNOD>))
335 #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
338 <==? <1 .DATA> <1 .DATAC>>
339 <TYPE? <2 .DATA> FIX>
341 <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
343 <DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
344 #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
345 <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
346 (<NODE-NAME .NOD> 0))
347 (<AND <==? .NTYP ,REST-CODE>
348 <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
350 <==? .NTYP ,SET-CODE>>
351 <SET SYM <NODE-NAME .TNOD>>)>>
352 (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>>
355 "ROUTINE TO DO BLT: AC1==> SOURCE
359 <DEFINE BLTAC (AC1 AC2 AC3 FLG SD)
360 #DECL ((AC3 AC1 AC2) AC (FLG) <OR FALSE ATOM> (SD) DATUM)
361 <EMIT <INSTRUCTION `HRLI `O* (<ADDRSYM .AC1>)>>
362 <EMIT <INSTRUCTION `HRRI `O* (<ADDRSYM .AC2>)>>
363 <EMIT <INSTRUCTION `BLT
365 <COND (.FLG 0) (ELSE -1)>
368 "HERE TO BLT WITH SOME KNOWLEDGE
371 AC3==> NUMBER OF WORDS TO TRANSMIT"
373 <DEFINE BLTAC+NUM (AC1 AC2 NUM FLG TPS DAT)
374 #DECL ((AC1 AC2) AC (NUM) FIX (FLG) <OR FALSE ATOM>)
375 <OR <==? .TPS UVECTOR> <SET NUM <* .NUM 2>>>
377 <EMIT <INSTRUCTION `HRLI <ACSYM .AC1> (<ADDRSYM .AC1>)>>
378 <EMIT <INSTRUCTION `HRRI <ACSYM .AC1> (<ADDRSYM .AC2>)>>
379 <EMIT <INSTRUCTION `BLT
381 <COND (.FLG .NUM) (ELSE <- .NUM 1>)>
384 "HERE TO BLT BUT WITH A DATUM AS DEST SLOT"
386 <DEFINE BLTAC+DAT (SAC TDAT NAC)
387 #DECL ((NAC SAC) AC (TDAT) DATUM)
388 <PUT .SAC ,ACPROT <>>
390 <EMIT <INSTRUCTION `HRLI <ACSYM .SAC> (<ADDRSYM .SAC>)>>
391 <EMIT <INSTRUCTION `HRR <ACSYM .SAC> !<ADDR:VALUE .TDAT>>>
392 <EMIT <INSTRUCTION `BLT <ACSYM .SAC> -1 (<ADDRSYM .NAC>)>>>
394 "ROUTINE TO GENERATE CHECKS FOR THE CASE WHERE THE LENGTH IS KNOWN."
396 <DEFINE KNOWN-CAREFUL-CHECK (SAC TPS NUM)
397 #DECL ((SAC) DATUM (TPS) ATOM (NUM) FIX)
398 <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
399 <COND (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI `O .NUM>>)
400 (<EMIT <INSTRUCTION `ADDI `O <* .NUM 2>>>)>
401 <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
403 <DEFINE UNKNOWN-CAREFUL-CHECK (SAC NAC)
404 #DECL ((NAC) AC (SAC) DATUM)
405 <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
406 <EMIT <INSTRUCTION `ADDI `O (<ADDRSYM .NAC>)>>
407 <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
409 "ROUTINE TO REST A VECTOR/UVECTOR AND CHECK FOR BOUNDS
412 NUM== AMOUNT TO REST."
414 <DEFINE REST-IT (AC NUM TPS)
415 #DECL ((AC) AC (TPS) ATOM (NUM) <OR FIX AC>)
416 <COND (<TYPE? .NUM AC>
417 <EMIT <INSTRUCTION `ADD <ACSYM .AC> <ADDRSYM .NUM>>>)
419 <COND (<==? .TPS UVECTOR>) (<SET NUM <* .NUM 2>>)>
420 <EMIT <INSTRUCTION `ADD <ACSYM .AC> [<FORM (.NUM) .NUM>]>>)>
421 <COND (.CAREFUL <RCHK .AC T>)>>
423 <DEFINE BBLT (SAC DAC NUM OTHN TPS "AUX" (TG <MAKE:TAG>))
424 #DECL ((AC1 AC2) AC (NUM) <OR FIX AC> (OTHN) <OR FALSE FIX>)
426 <EMIT <INSTRUCTION `MOVE
428 [<FORM (<ADDRSYM .SAC>) .OTHN>]>>)
429 (ELSE <EMIT <INSTRUCTION `HRLI <ACSYM .DAC> <ADDRSYM .SAC>>>)>
430 <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI <ACSYM .SAC> 1>>)>
431 <EMIT <COND (<TYPE? .NUM FIX> <INSTRUCTION `HRLI <ACSYM .SAC> .NUM>)
435 <COND (<==? .TPS UVECTOR> 1) (ELSE 2)>
438 <EMIT <INSTRUCTION `POP <ACSYM .SAC> `@ <ADDRSYM .DAC>>>
439 <EMIT <INSTRUCTION `TLNE <ACSYM .SAC> -1>>
440 <EMIT <INSTRUCTION `JRST .TG>>>
442 <DEFINE UVECTOR-MUNG-SB (SDAT TAC "AUX" SAC)
443 #DECL ((SDAT) DATUM (TAC SAC) AC)
445 <SET SAC <DATVAL .SDAT>>
446 <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .SAC>>>
447 <EMIT <INSTRUCTION `SUB <ACSYM .SAC> `O* >>
448 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* (<ADDRSYM .SAC>)>>
449 <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O* (<ADDRSYM .TAC>)>>
450 <PUT .TAC ,ACPROT <>>>