3 <ENTRY NTH-GEN REST-GEN PUT-GEN LNTH-GEN MT-GEN PUTREST-GEN IPUT-GEN
4 IREMAS-GEN FLUSH-COMMON-SYMT COMMUTE-STRUC DEFER-IT PUT-COMMON-DAT
7 <USE "CODGEN" "CACS" "COMCOD" "CHKDCL" "COMPDEC" "SPCGEN" "COMTEM" "CARGEN">
10 <UVECTOR [REST <LIST [REST <OR ATOM LIST>]>]>
11 (RESTERS NTHERS PUTTERS)
14 <UVECTOR [REST ATOM]>>
16 <DEFINE PREG? (TYP TRY "AUX" (FTYP <ISTYPE? .TYP>))
17 <COND (.FTYP <REG? .FTYP .TRY>) (ELSE <REG? TUPLE .TRY>
18 ;"Fool REG? into not losing.")>>
21 <DEFINE LIST-LNT-SPEC (N W NF BR DI NUM
22 "AUX" (K <KIDS .N>) REG RAC (FLS <==? .W FLUSHED>)
23 (B2 <COND (<AND .BR .FLS> .BR) (ELSE <MAKE:TAG>)>)
24 (SDIR .DI) (B3 <>) B4 F1 F2 F3
25 (SBR <NODE-NAME .N>) TT)
26 #DECL ((N) NODE (NUM) FIX (RAC) AC (K) <LIST [REST NODE]>)
28 <GEN <SET TT <1 <KIDS <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <2 .K>)
30 <COND (<SET TT <ISTYPE? <RESULT-TYPE .TT>>> <DATUM .TT ANY-AC>)
32 <SET RAC <DATVAL <SET REG <TOACV .REG>>>>
34 <AND .NF <SET DI <NOT .DI>>>
35 <SET DI <COND (<AND .BR <NOT .FLS>> <NOT .DI>) (ELSE .DI)>>
36 <AND .DI <SET SBR <FLIP .SBR>>>
38 <SET F1 <MEMQ .SBR '![==? G? G=? 1? 0?!]>>
39 <SET F2 <MEMQ .SBR '![G? G=?!]>>
40 <SET F3 <MEMQ .SBR '![L? L=?!]>>
41 <COND (<OR <==? .SBR L=?> <==? .SBR G?>> <SET NUM <- .NUM 1>>)>
43 <REPEAT ((FLG T) (RAC1 .RAC))
45 <COND (<OR <NOT <0? .NUM>> <NOT .F1>> `JUMPE )
51 <OR .B3 <SET B3 <MAKE:TAG>>>)
53 <COND (<L? <SET NUM <- .NUM 1>> 0>
54 <AND .B3 <LABEL:TAG .B3>>
56 <COND (<AND .FLG <ACRESIDUE .RAC>
57 <G? <CHTYPE <FREE-ACS T> FIX> 0>>
58 <SET RAC <GETREG <>>>)
59 (.FLG <MUNG-AC .RAC .REG>)
60 (ELSE <SET RAC1 .RAC>)>
62 <EMIT <INSTRUCTION `HRRZ
67 <EMIT <INSTRUCTION `MOVEI
69 <COND (<OR .F2 .F3> <+ .NUM 1>) (ELSE .NUM)>>>
70 <LABEL:TAG <SET B4 <MAKE:TAG>>>
71 <EMIT <INSTRUCTION `JUMPE
73 <COND (<AND <NOT .F3> <OR .F2 <NOT .F1>>>
74 <OR .B3 <SET B3 <MAKE:TAG>>>)
76 <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> (<ADDRSYM .RAC>)>>
77 <EMIT <INSTRUCTION `SOJG `O .B4>>
78 <COND (<OR .F3 .F2> <AND .B3 <BRANCH:TAG .B2>>)
80 <EMIT <INSTRUCTION <COND (.F1 `JUMPN ) (ELSE `JUMPE )>
83 <COND (.B3 <LABEL:TAG .B3>)>)>
86 <COND (<NOT .BR> <TRUE-FALSE .N .B2 .W>)
88 <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
93 <DEFINE LNTH-GEN (NOD WHERE
94 "AUX" (STRN <1 <KIDS .NOD>>) T1 T2 STR
95 (ITYP <RESULT-TYPE .STRN>) (TYP <STRUCTYP .ITYP>) RAC
96 REG (NEGOK <>) (*2OK <>) (HWOK <>) (SWOK <>) TR TRIN
98 #DECL ((STRN NOD) NODE (K) <LIST [REST NODE]> (STR REG) DATUM (RAC) AC
99 (T1 T2) ATOM (TRIN TROUT) <UVECTOR [7 FIX]> (TRANSFORM) TRANS)
100 <COND (<AND <ASSIGNED? TRANSFORM>
101 <==? <PARENT .NOD> <1 <SET TR .TRANSFORM>>>>
103 <SET NEGOK <NOT <0? <1 <SET TRIN <2 .TR>>>>>>
105 <AND <OR <==? .TYP VECTOR> <==? .TYP TUPLE>>
107 <AND <==? 2 <4 .TRIN>> <==? 2 <5 .TRIN>>>
112 <SET HWOK <==? 2 <6 .TRIN>>>
113 <SET SWOK <NOT <0? <7 .TRIN>>>>)>
114 <SET STR <GEN .STRN DONT-CARE>>
115 <RET-TMP-AC <SET RAC <DATVAL <SET REG <REG? FIX .WHERE T>>>>
121 <RET-TMP-AC <DATTYP .REG> .REG>
122 <PUT .REG ,DATTYP FIX>
123 <EMIT '<`MOVSI 0 *400000*>>
124 <LABEL:TAG <SET T1 <MAKE:TAG>>>
125 <EMIT <INSTRUCTION `JUMPE <ACSYM .RAC> <SET T2 <MAKE:TAG>>>>
126 <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> (<ADDRSYM .RAC>)>>
127 <EMIT <INSTRUCTION `AOBJN 0 .T1>>
129 <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> 0>>)
130 (<==? <TYPEPRIM .TYP> TEMPLATE>
133 <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP> .STR .RAC>
135 (<MEMQ .TYP '![UVECTOR VECTOR TUPLE STORAGE!]>
138 <COND (.SWOK <PUT .TROUT 7 1> <PUT .TROUT 6 1>)
142 <EMIT <INSTRUCTION `HLRZ <ACSYM .RAC> !<ADDR:VALUE .STR>>>)
144 <EMIT <INSTRUCTION `HLRE <ACSYM .RAC> !<ADDR:VALUE .STR>>>
146 <COND (.NEGOK <COND (<N==? <5 .TRIN> -2> <PUT .TROUT 1 1>)>)
148 <COND (.MUNG <EMIT <INSTRUCTION `MOVNS <ADDRSYM .RAC>>>)
150 <EMIT <INSTRUCTION `MOVN
152 !<ADDR:VALUE .STR>>>)>
154 <OR <==? .TYP UVECTOR>
158 <PUT .TROUT 5 <COND (<1? <4 .TRIN>> 2) (ELSE <5 .TRIN>)>>)
161 <EMIT <INSTRUCTION `MOVE
163 !<ADDR:VALUE .STR>>>)>
164 <EMIT <INSTRUCTION `ASH <ACSYM .RAC> -1>>
169 <PUT .STR ,DATTYP FIX>
171 (ELSE <RET-TMP-AC .STR>)>)
175 <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> !<ADDR:TYPE .STR>>>
177 <PUT .RAC ,ACPROT <>>
178 <MOVE:ARG .REG .WHERE>>
181 <DEFINE MT-GEN (NOD WHERE
182 "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
183 "AUX" (STRN <1 <KIDS .NOD>>) RAC STR (ITYP <RESULT-TYPE .STRN>)
184 (SDIR .DIR) (TYP <STRUCTYP .ITYP>)
185 (FLS <==? .WHERE FLUSHED>)
186 (B2 <COND (<AND .BRANCH .FLS> .BRANCH) (ELSE <MAKE:TAG>)>)
187 (TEMP? <==? <TYPEPRIM .TYP> TEMPLATE>))
188 #DECL ((STR) DATUM (STRN NOD) NODE (RAC) AC (B2) ATOM
189 (BRANCH) <OR ATOM FALSE>)
191 <SET STR <GEN .STRN DONT-CARE>>
193 <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT T>
194 <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP>
196 <SET RAC <GETREG <>>>>
197 <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT <>>
199 <SET STR <DATUM FIX .RAC>>
200 <PUT .RAC ,ACLINK (.STR !<ACLINK .RAC>)>)
201 (<AND <SET ITYP <ISTYPE-GOOD? .ITYP>> <G? <CHTYPE <FREE-ACS T> FIX> 0>>
202 <SET STR <GEN .STRN <DATUM .ITYP ANY-AC>>>)
203 (ELSE <SET STR <GEN .STRN DONT-CARE>>)>
204 <AND .NOTF <SET DIR <NOT .DIR>>>
206 <COND (<AND .BRANCH <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
208 <COND (<AND <TYPE? <DATVAL .STR> AC> <N==? .TYP STRING> <N==? .TYP BYTES>>
209 <SET RAC <DATVAL .STR>>
210 <COND (<OR <==? .TYP LIST> .TEMP?>
211 <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
215 <EMIT <INSTRUCTION <COND (.DIR `JUMPGE ) (ELSE `JUMPL )>
218 (<AND <TYPE? <DATTYP .STR> AC> <OR <==? .TYP STRING> <==? .TYP BYTES>>>
219 <SET RAC <DATTYP .STR>>
220 <EMIT <INSTRUCTION <COND (.DIR `TRNN ) (ELSE `TRNE )>
225 <COND (<==? .TYP LIST>
226 <EMIT <INSTRUCTION <COND (.DIR `SKIPN ) (ELSE `SKIPE )>
229 (<OR <==? .TYP STRING> <==? .TYP BYTES>>
230 <EMIT <INSTRUCTION `HRRZ !<ADDR:TYPE .STR>>>
231 <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
234 <EMIT <INSTRUCTION <COND (.DIR `SKIPL ) (ELSE `SKIPGE )>
238 <COND (<NOT .BRANCH> <TRUE-FALSE .NOD .B2 .WHERE>)
240 <SET WHERE <MOVE:ARG <REFERENCE .SDIR> .WHERE>>
246 <DEFINE REST-GEN (NOD WHERE
247 "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
248 (TPS <STRUCTYP .TYP>) (2ARG <2 .K>) (1ARG <1 .K>)
249 (NRP <NTH-REST-PUT? .1ARG>)
250 (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
251 (NUM <COND (.NUMKN <NODE-NAME .2ARG>) (ELSE 0)>)
252 (NR <GET-RANGE <RESULT-TYPE .2ARG>>) W TEM)
253 #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM) FIX)
254 <COND (<SET TEM <FIND-COMMON .NOD>>
255 <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .WHERE>>)
256 (<PROG ((COMMON-SUB <>))
257 #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
260 <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>>
272 <SET TEM .COMMON-SUB>>)>
284 <DEFINE VEC-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
285 "AUX" (ML <MINL .TYP>) N SAC STR (MP <MPCNT .TPS>) NUMN
286 (ONO .NO-KILL) (NO-KILL .ONO) (LCAREFUL .CAREFUL)
288 <COND (.R? DONT-CARE)
290 <REG? <COND (<SET TYP <ISTYPE? .TYP>>)
293 #DECL ((NOD NUMNOD STRNOD) NODE (STR NUMN) DATUM (ML N MP NUM) FIX
294 (SAC) AC (NUMNK R? RV) <OR ATOM FALSE>
295 (NR) <OR FALSE <LIST FIX FIX>> (WHERE W2) <OR ATOM DATUM>
296 (NO-KILL) <SPECIAL LIST>)
297 <SET RV <COMMUTE-STRUC .RV .STRNOD .NUMNOD>>
300 <MESSAGE ERROR "ARG OUT OF RANGE " <NODE-NAME .NOD>>)
302 <SET STR <GEN .STRNOD .W2>>
303 <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
305 <RCHK <DATVAL .STR> .R?>)>
306 <COND (<NOT <AND .TYP <NOT .R?>>>
308 <MUNG-AC <DATVAL .STR> .STR>)>)
310 <TOACV <SET STR <GEN .STRNOD .W2>>>
311 <MUNG-AC <SET SAC <DATVAL .STR>> .STR>
312 <EMIT <INSTRUCTION `ADD
314 [<FORM (<SET N <* .NUM .MP>>) .N>]>>
316 <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>
320 <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>
321 <SET STR <GEN .STRNOD DONT-CARE>>)
323 <SET STR <GEN .STRNOD DONT-CARE>>
324 <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>)>
325 <DELAY-KILL .NO-KILL .ONO>
327 <PUT <SET SAC <DATVAL .NUMN>> ,ACPROT T>
333 <COND (.R? <G=? <1 .NR> 0>)
334 (ELSE <G? <1 .NR> 0>)>>>
335 <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
338 <OR <1? .MP> <EMIT <INSTRUCTION `ASH <ACSYM .SAC> 1>>>
339 <EMIT <INSTRUCTION `HRLI <ACSYM .SAC> (<ADDRSYM .SAC>)>>
340 <EMIT <INSTRUCTION `ADD <ACSYM .SAC> !<ADDR:VALUE .STR>>>
341 <RET-TMP-AC <DATTYP .NUMN> .NUMN>
342 <PUT .NUMN ,DATTYP <DATTYP .STR>>
343 <COND (<TYPE? <DATTYP .STR> AC>
346 (.NUMN !<ACLINK <DATTYP .STR>>)>)>
348 <PUT .SAC ,ACPROT <>>
351 <NOT <AND .NR <L=? <2 .NR> .ML>>>
353 <COND (<NOT <==? .TPS TUPLE>>
355 <RET-TMP-AC <DATTYP .STR> .STR>
356 <PUT .STR ,DATTYP <COND (.R? .TPS) (ELSE .TYP)>>)>)>
357 <MOVE:ARG .STR .WHERE>>
359 <DEFINE LIST-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
360 "OPTIONAL" (PAC <>) PN (SAME? <>)
361 "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
363 <AND .PAC <NOT .SAME?>
364 <COMMUTE-STRUC <> .PN .NUMNOD>
365 <COMMUTE-STRUC <> .PN .STRNOD>>) VN
366 (NNUMKN .NUMKN) (NUMK <>) (NCAREFUL .CAREFUL) (FLAC <>)
367 STR SAC SAC1 (TYP1 <COND (<ISTYPE? .TYP>) (ELSE LIST)>)
368 NUMN NAC (T1 <MAKE:TAG>) (T2 <MAKE:TAG>) NTHCASE TEM
369 (ONE-OR-TWO-HRRZS <>) (PSTR <>) HI LO (REDEF <>))
370 #DECL ((PN NOD STRNOD NUMNOD) NODE (STR NUMN VN) DATUM (T1 T2 TYP1 TPS) ATOM
371 (SAC SAC1 NAC) AC (NUM NTHCASE) FIX (NO-KILL) <SPECIAL LIST>
372 (R? RR RV NUMK NUMKN NNUMKN) <OR ATOM FALSE> (WHERE) <OR ATOM DATUM>
373 (PAC) <OR ATOM FALSE AC> (PSTR) <OR DATUM FALSE> (HI LO) FIX
374 (NR) <OR FALSE <LIST FIX FIX>>)
376 <COND (<1? <CHTYPE <DEFERN <RESULT-TYPE .PN>> FIX>> <SET REDEF T>)
377 (<AND .NUMKN <1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP <+ .NUM 1>>> FIX>>>
379 (<1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP ALL>> FIX>> <SET REDEF T>)>)>
380 <SET RV <AND <NOT .SAME?> <COMMUTE-STRUC .RV .NUMNOD .STRNOD>>>
382 <COND (<==? <SET LO <1 .NR>> <SET HI <2 .NR>>> <SET NUMKN T>)
383 (ELSE <SET NNUMKN T>)>
386 <L=? .NUM <MINL .TYP>>
387 <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
389 <COND (<AND <G=? .LO 0> <L=? .NUM <MINL .TYP>>>
390 <SET NCAREFUL <>>)>)>
392 <+ <COND (.R? 0) (ELSE 12)>
393 <COND (<AND .NR <G? .LO 0> <G? .HI <MINL .TYP>>> 2)
396 <OR <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
397 <L=? .NUM <MINL .TYP>>>>
401 <L=? .NUM <MINL .TYP>>
402 <COND (.R? <L? .LO 0>) (ELSE <L=? .LO 0>)>>
405 <COND (<OR <AND <NOT .NUMK> <NOT .NUMKN>>
407 <G? <COND (.R? .NUM) (ELSE <+ .NUM 1>)>
411 <COND (<NOT .NUMKN> 8)
412 (<AND <NOT .NUMK> <SET FLAC <0? .NUM>>> 0)
413 (<AND <NOT .NUMK> <SET FLAC <1? .NUM>>> 2)
414 (<AND <NOT .NUMK> <SET FLAC <==? .NUM 2>>> 4)
416 <COND (<OR <AND <G? .NTHCASE 1> <L? .NTHCASE 6>>
417 <AND <G? .NTHCASE 13> <L? .NTHCASE 18>>>
418 <SET ONE-OR-TWO-HRRZS T>)>
421 <PREFER-DATUM .WHERE>
429 <OR <ISTYPE? <RESULT-TYPE .PN>>
431 <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
432 <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
433 <GET-ELE-TYPE <RESULT-TYPE .NOD>
434 <COND (.NUMKN <+ .NUM 1>)
437 (ELSE <DATUM ANY-AC ANY-AC>)>>>
438 <SET PUT-COMMON-DAT .VN>)>
442 <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>
445 <COND (.PAC <PREG? .TYP .WHERE>)
446 (ELSE <REG? .TYP1 .WHERE>)>>>)
450 <COND (.PAC <PREG? .TYP .WHERE>)
451 (ELSE <REG? .TYP1 .WHERE>)>>>
454 <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>)>
455 <COND (<OR .RR <NOT .PAC>> <DELAY-KILL .NO-KILL .ONO>)>
458 <SET PAC <CHTYPE <DATVAL .STR> AC>>
460 <NOT <==? .WHERE FLUSHED>>
461 <OR <G? .NTHCASE 13> .REDEF>>
462 <PUT <SET SAC <GETREG <SET PSTR <DATUM .TYP1 LIST>>>>
465 <PUT .PSTR ,DATVAL .SAC>
466 <OR .ONE-OR-TWO-HRRZS
467 <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> (<ADDRSYM .PAC>)>>>)
468 (ELSE <SET SAC <DATVAL .STR>>)>
470 <COND (<AND .NUMKN <NOT .FLAC>>
473 <MOVE:ARG <REFERENCE .NUM> <DATUM FIX ANY-AC>>>>>)
474 (<NOT .FLAC> <TOACV .NUMN> <SET NAC <DATVAL .NUMN>>)>
475 <COND (<AND <NOT .PSTR>
479 <NOT <AND <TYPE? .WHERE DATUM> <==? <DATVAL .WHERE> .SAC>>>
480 <G? <CHTYPE <FREE-ACS T> FIX> 0>>
481 <SET SAC1 <GETREG <>>>
482 <AND .PAC <SET PAC .SAC1>>)
483 (<AND .PSTR .ONE-OR-TWO-HRRZS>
486 (ELSE <SET SAC1 .SAC>)>
487 <PUT .SAC ,ACPROT <>>
488 <AND .PAC <PUT <CHTYPE .PAC AC> ,ACPROT <>>>
489 <AND <==? .SAC .SAC1>
490 <NOT <L=? .NTHCASE 1>>
493 <MUNG-AC .SAC <COND (.PSTR .PSTR) (ELSE .STR)>>>
494 <AND <ASSIGNED? NAC> <MUNG-AC .NAC .NUMN>>
497 #DECL ((APAT) <OR ATOM LIST>)
498 <COND (<TYPE? .APAT ATOM>
499 <LABEL:TAG <COND (<==? .APAT T1> .T1) (ELSE .T2)>>)
502 <EMIT <MAPF ,INSTRUCTION
504 <COND (<==? .ITM A11> <ACSYM .SAC>)
505 (<==? .ITM IA11> (<ADDRSYM .SAC>))
506 (<==? .ITM A1> <ACSYM .SAC1>)
507 (<==? .ITM A2> <ACSYM .NAC>)
508 (<==? .ITM IA1> (<ADDRSYM .SAC1>))
509 (<==? .ITM IA2> (<ADDRSYM .NAC>))
514 <NTH ,PATTRNS <+ .NTHCASE 1>>>
515 <OR .FLAC <RET-TMP-AC .NUMN>>
516 <COND (<AND <NOT .PSTR> <N==? .SAC .SAC1>>
518 <SET STR <DATUM .TYP1 .SAC1>>
519 <PUT .SAC1 ,ACLINK (.STR)>)>
521 (<AND .SAME? .PAC> <SPEC-GEN .PN <OR .PSTR .STR> LIST 0>)
533 <ISTYPE? <RESULT-TYPE .PN>>
535 <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
536 <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
537 <GET-ELE-TYPE <RESULT-TYPE .NOD>
538 <COND (.NUMKN <+ .NUM 1>)
541 (ELSE <DATUM ANY-AC ANY-AC>)>>>
542 <SET PUT-COMMON-DAT .VN>)>
543 <DELAY-KILL .NO-KILL .ONO>
544 <COND (.PSTR <TOACV .PSTR> <SET SAC <DATVAL .PSTR>>)
545 (ELSE <TOACV .STR> <SET SAC <DATVAL .STR>>)>
548 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>
550 <SET PUT-COMMON-DAT .VN>
551 <EMIT <INSTRUCTION `MOVEM <ACSYM <CHTYPE <DATTYP .VN> AC>>
556 <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
557 <COND (.NUMKN <+ .NUM 1>)
560 <SET PUT-COMMON-DAT .VN>
561 <EMIT <INSTRUCTION `HLLM <ACSYM <CHTYPE <DATTYP .VN> AC>>
564 <SET PUT-COMMON-DAT .VN>
565 <EMIT <INSTRUCTION `MOVEM
566 <ACSYM <CHTYPE <DATVAL .VN> AC>>
571 <PUT <CHTYPE .PAC AC> ,ACPROT <>>)
572 (<AND .R? <N==? <ISTYPE? .TYP> LIST>>
574 <PUT .STR ,DATTYP LIST>)>
575 <MOVE:ARG .STR .WHERE>>
580 ((`JUMPE A11 |CERR2 ) (`HRRZ A1 IA11))
582 ((`JUMPE A11 |CERR2 )
586 ((`HRRZ A1 IA11) (`HRRZ A1 IA1))
590 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
591 (T1 (`HRRZ A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
597 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
602 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
608 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
613 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
614 ((`JUMPE A1 |CERR2 ))
616 ((`JUMPE A11 |CERR2 ) (`HRRZ A1 IA11) (`JUMPE A1 |CERR2 ))
618 ((`JUMPE A11 |CERR2 )
623 ((`HRRZ A1 IA11) (`HRRZ A1 IA1))
627 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
629 (T1 (`HRRZ A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
630 ((`JUMPLE A2 |CERR2 )
635 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
641 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
643 ((`JUMPLE A2 |CERR1 )
647 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
653 (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
655 (`JUMPE A1 |CERR2 ))!]>
657 <DEFINE RCHK (AC RORN)
658 #DECL ((AC) AC (RORN) <OR FALSE ATOM>)
660 <EMIT <INSTRUCTION `CAILE <ACSYM .AC> -1>>
661 <BRANCH:TAG |CERR2 >)
662 (ELSE <EMIT <INSTRUCTION `JUMPGE <ACSYM .AC> |CERR2 >>)>>
664 <DEFINE NTH-GEN (NOD WHERE
665 "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
666 "AUX" (K <KIDS .NOD>) W2 B2 (SDIR .DIR)
667 (TYP <RESULT-TYPE <1 .K>>) (TPS <STRUCTYP .TYP>) W
668 (2ARG <2 .K>) (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
669 (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
671 <INDEX <NODE-NAME .2ARG>>)
672 (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
673 (COD <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>) FLS
674 (NR <GET-RANGE <RESULT-TYPE .2ARG>>) (TEM <>)
675 (1ARG <1 .K>) (NRP <NTH-REST-PUT? .1ARG>) NDAT
677 #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM COD) FIX
679 <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
680 <COND (<AND .BRANCH <NOT <NTH-PRED .COD>>>
681 <SET W <UPDATE-WHERE .NOD .WHERE>>)
682 (ELSE <SET W .WHERE>)>
683 <COND (<SET TEM <FIND-COMMON .NOD>>
684 <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .W>>
686 (<AND <SET TEM <FIND-COMMON-REST-NODE .NOD>>
687 <SET W <LOC-COMMON .TEM .NOD .TPS .1ARG .2ARG .W>>>
689 <PROG ((COMMON-SUB <>))
691 <SPECIAL <OR FALSE COMMON <LIST [REST COMMON]>>>)
693 <COND (<AND <NOT .DONE> <NTH-PRED .COD>>
694 <APPLY <NTH ,NTHERS .COD>
708 <AND .NOTF <SET DIR <NOT .DIR>>>
711 <APPLY <NTH ,NTHERS .COD>
723 <OR <==? .WHERE FLUSHED>
725 <OR <==? .WHERE DONT-CARE>
727 <SET DIR <NOT .DIR>>>
728 <D:B:TAG <COND (.FLS .BRANCH)
729 (ELSE <SET B2 <MAKE:TAG>>)>
734 <MOVE:ARG <COND (.NOTF
744 <APPLY <NTH ,NTHERS .COD>
755 <SET TEM .COMMON-SUB>>
757 <HACK-COMMON NTH .1ARG .TEM .WHERE .W .NUMKN .NUM .TPS .NRP>)>
760 <DEFINE VEC-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
761 "AUX" STRN (MP <MPCNT .TPS>) (RV <==? <NODE-NAME .NOD> INTH>)
762 STR (TYPR <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
763 #DECL ((NOD STRNOD NUMNOD) NODE (NUM MP) FIX (STR) DATUM
764 (WHERE) <OR ATOM DATUM> (TYPR RV NUMKN) <OR FALSE ATOM>)
765 <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " NTH>)
767 <OR <NOT .CAREFUL> <NOT <G? .NUM <MINL .TYP>>>>>
780 <SET STRN <OFFPTR <+ <* <- .NUM 1> .MP> -2 .MP> .STR .TPS>>)
795 <OFFPTR <- <COND (.NUMKN .MP) (ELSE 0)> 2> .STR .TPS>>)>
796 <MOVE:ARG <DATUM <COND (.TYPR .TYPR) (ELSE .STRN)> .STRN>
799 <DEFINE LIST-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
800 "AUX" STRN STR (ITYP <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
801 #DECL ((NOD STRNOD NUMNOD) NODE (NUM COD) FIX (STR) DATUM (SAC) AC
802 (WHERE) <OR DATUM ATOM> (ITYP) <OR ATOM FALSE>)
813 <==? <NODE-NAME .NOD> INTH>
815 <SET STR <DEFER-IT .NOD .STR>>
816 <SET STRN <OFFPTR 0 .STR LIST>>
817 <MOVE:ARG <DATUM <COND (.ITYP .ITYP) (ELSE .STRN)> .STRN>
820 <DEFINE STRING-REST (N W TYP TPS NK NUM STRN NUMN R? RV NR
822 "AUX" STRD VD ND SACT SSAC SAC (ML <MINL .TYP>)
823 (BSYZ <GETBSYZ .TYP>) NWDS NCHRS (ONO .NO-KILL)
824 (NO-KILL .ONO) TEM (LCAREFUL .CAREFUL)
825 (OT <COND (<==? .TPS STRING> CHARACTER) (ELSE FIX)>)
828 <COMMUTE-STRUC <> .VN .NUMN>
829 <COMMUTE-STRUC <> .VN .STRN>>)
832 <==? <NODE-TYPE .STRN> ,LVAL-CODE>
833 <NOT <EMPTY? <SET TEM <PARENT .N>>>>
834 <==? <NODE-TYPE <CHTYPE .TEM NODE>> ,SET-CODE>
835 <==? <NODE-NAME .STRN> <NODE-NAME <CHTYPE .TEM NODE>>>>)
837 <COND (<AND .R? <NOT .STAY-MEM>> <REG? .TPS .W>)
838 (<AND .VN <NOT .RR>> <DATUM ANY-AC ANY-AC>)
839 (ELSE DONT-CARE)>) (FLS <==? .W FLUSHED>)
841 #DECL ((N NUMN STRN) NODE (STRD SSTRD ND VD) DATUM (NUM ML NWDS NCHRS) FIX
842 (SACT SSAC SAC) AC (NO-KILL) <SPECIAL LIST>
843 (NR) <OR FALSE <LIST FIX FIX>> (VN) <OR NODE FALSE>
844 (BSYZ) <OR FIX FALSE>)
845 <COND (.RR <SET VD <GEN .VN <DATUM .OT ANY-AC>>> <SET PUT-COMMON-DAT .VD>)>
849 (<L? .NUM 0> <MESSAGE ERROR " ARG OUT OF RANGE " <NODE-NAME .N> .N>)
851 <SET STRD <GEN .STRN .W2>>
852 <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
853 <EMIT <INSTRUCTION `HRRZ !<ADDR:TYPE .STRD>>>
854 <EMIT <INSTRUCTION `JUMPE |CERR2 >>)>
855 <COND (<NOT <AND .TYP <NOT .R?>>>
857 <MUNG-AC <DATVAL .STRD> .STRD>)>
861 <SET VD <GEN .VN <DATUM .OT ANY-AC>>>>)>
862 <COND (<AND .FLS <TYPE? <DATVAL .STRD> AC>>
864 <MUNG-AC <SET SAC <DATVAL .STRD>> .STRD>
866 <EMIT <INSTRUCTION `IDPB
867 <ACSYM <CHTYPE <DATVAL .VD> AC>>
868 !<ADDR:VALUE .STRD>>>)
870 <EMIT <INSTRUCTION `MOVE `O !<ADDR:VALUE .STRD>>>
871 <EMIT <INSTRUCTION `IDPB <ACSYM <CHTYPE <DATVAL .VD> AC>> `O>>)>)>)
873 <SET STRD <GEN .STRN .W2>>
874 <COND (<OR <TYPE? <DATTYP .STRD> AC> <TYPE? <DATVAL .STRD> AC>>
876 <COND (<AND .VN <NOT .RR>>
877 <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
878 <SET PUT-COMMON-DAT .VD>)>
879 <DELAY-KILL .NO-KILL .ONO>
881 (<AND .LCAREFUL <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>>
882 <COND (<AND .R? <NOT .STAY-MEM>>
884 <MUNG-AC <SET SACT <DATTYP .STRD>>>)>
885 <COND (<TYPE? <DATTYP .STRD> AC>
886 <EMIT <INSTRUCTION `MOVEI `O (<ADDRSYM <DATTYP .STRD>>)>>)
887 (ELSE <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .STRD>>>)>
889 <EMIT <INSTRUCTION <COND (.R? `SOJL ) (ELSE `SOJLE )> |CERR2 >>)
891 <EMIT <INSTRUCTION `SUBI `O .NUM>>
892 <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
896 <COND (<TYPE? <DATTYP .STRD> AC>
897 <EMIT <INSTRUCTION `HRR <ACSYM <DATTYP .STRD>> `O >>)
899 <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .STRD>>>)>)>)
901 <COND (<NOT .STAY-MEM>
903 <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>)>
904 <EMIT <INSTRUCTION #OPCODE!-OP!-PACKAGE 33285996544
905 !<ADDR:TYPE .STRD>>>)
906 (<AND .R? <NOT .STAY-MEM>>
908 <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>
909 <EMIT <INSTRUCTION `SUBI <ACSYM .SACT> .NUM>>)
911 <EMIT <INSTRUCTION `MOVNI `O .NUM>>
912 <EMIT <INSTRUCTION `ADDM `O !<ADDR:TYPE .STRD>>>)>
913 <COND (<OR <NOT .R?> <NOT .STAY-MEM>>
915 <SET SAC <DATVAL .STRD>>)
916 (<TYPE? <DATVAL .STRD> AC> <SET SAC <DATVAL .STRD>>)>
917 <COND (<AND <NOT .FLS> .VN>
918 <SET SSAC <PUT .SAC ,ACPROT T>>
919 <SET SAC <GETREG <>>>
920 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> <ADDRSYM .SSAC>>>
921 <SET SSTRD <DATUM <DATTYP .STRD> .SAC>>
922 <PUT .SSAC ,ACPROT <>>)
923 (ELSE <SET SSTRD .STRD>)>
926 <SET NWDS </ 36 .BSYZ>>
927 <SET NCHRS <MOD .NUM .NWDS>>
928 <SET NWDS </ .NUM .NWDS>>
929 <COND (<AND <ASSIGNED? SAC> <NOT .FLS>> <MUNG-AC .SAC .SSTRD>)>
930 <COND (<NOT <0? .NWDS>>
931 <COND (<ASSIGNED? SAC>
932 <EMIT <INSTRUCTION `ADDI <ACSYM .SAC> .NWDS>>)
934 <EMIT <INSTRUCTION `MOVEI `O .NWDS>>
935 <EMIT <INSTRUCTION `ADDM `O !<ADDR:VALUE
938 <COND (<L? <SET NCHRS <- .NCHRS 1>> 0> <RETURN>)>
939 <EMIT <INSTRUCTION `IBP `O !<ADDR:VALUE .SSTRD>>>>)
941 <SET TEM <STRINGER .NUM .STRD .SSTRD>>
942 <COND (.TEM <SET SSTRD <RSTRING .SSTRD .TEM .STAY-MEM>>)
944 <COND (<TYPE? <DATVAL .SSTRD> AC>
945 <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
946 <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .SSTRD>>>)
948 <COND (<TYPE? <DATVAL .SSTRD> AC>
949 <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
951 <COND (<L? <SET NUM <- .NUM 1>> 0> <RETURN>)>
952 <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .SSTRD>>>>)>)>
956 <PUT .SAC ,ACPROT <>>
957 <EMIT <INSTRUCTION `IDPB <ACSYM <CHTYPE <DATVAL .VD> AC>>
959 (ELSE <SET STRD .SSTRD>)>)>)
961 <SET RV <COMMUTE-STRUC .RV .NUMN .STRN>>
963 <SET ND <GEN .NUMN <REG? FIX .W>>>
964 <SET STRD <GEN .STRN DONT-CARE>>)
965 (<NOT <SIDE-EFFECTS .N>>
966 <SET STRD <GEN .STRN DONT-CARE>>
967 <SET ND <GEN .NUMN <REG? FIX .W>>>)
969 <SET STRD <GEN .STRN <DATUM ANY-AC ANY-AC>>>
970 <SET ND <GEN .NUMN <DATUM FIX ANY-AC>>>)>
971 <COND (<OR <TYPE? <DATVAL .STRD> AC> <TYPE? <DATTYP .STRD> AC>>
973 <COND (<AND .VN <NOT .RR>>
974 <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
975 <SET PUT-COMMON-DAT .VD>)>
976 <DELAY-KILL .NO-KILL .ONO>
978 <COND (<AND .LCAREFUL
980 <COND (.R? <L? <1 .NR> 0>) (ELSE <L=? <1 .NR> 0>)>>>
981 <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
982 <ACSYM <CHTYPE <DATVAL .ND> AC>>
984 <COND (<OR .R? <AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>>
985 <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .STRD>>>
986 <COND (<TYPE? <DATVAL .ND> AC>
987 <EMIT <INSTRUCTION `SUBI `O (<ADDRSYM <DATVAL .ND>>)>>)
988 (ELSE <EMIT <INSTRUCTION `SUB `O !<ADDR:VALUE .ND>>>)>
989 <COND (<AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>
990 <EMIT <INSTRUCTION `JUMPL `O |CERR2 >>)>
991 <COND (<AND .STAY-MEM <NOT <TYPE? <DATTYP .STRD> AC>>>
992 <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .STRD>>>)
995 <MUNG-AC <DATTYP .STRD> .STRD>
996 <EMIT <INSTRUCTION `HRR <ACSYM <CHTYPE <DATTYP .STRD> AC>> `O >>)>)>
998 <SET BSYZ </ 36 .BSYZ>>
1000 <PUT <SET SAC <DATVAL .ND>> ,ACPROT T>
1002 <COND (<==? .SAC ,LAST-AC>
1003 <SGETREG <SET SAC ,LAST-AC-1> <>>
1004 <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
1005 <EMIT <INSTRUCTION `MOVE
1007 <ADDRSYM ,LAST-AC>>>)
1009 <SGETREG <SET SACT <NTH ,ALLACS <+ <ACNUM .SAC> 1>>> <>>
1010 <PUT .SAC ,ACPROT <>>)>
1011 <EMIT <INSTRUCTION `IDIVI <ACSYM .SAC> .BSYZ>>)
1012 (ELSE <SET SAC <STRINGER <> .ND .STRD>>)>
1014 <COND (<AND .VN <NOT .FLS>>
1015 <PUT <SET SACT <NTH ,ALLACS <+ <ACNUM <PUT .SAC ,ACPROT T>> 1>>>
1018 <SET SSAC <GETREG <>>>
1019 <EMIT <INSTRUCTION `MOVE <ACSYM .SSAC> !<ADDR:VALUE .STRD>>>
1020 <PUT .SAC ,ACPROT <>>
1021 <PUT .SACT ,ACPROT <>>
1022 <RSTRING <DATUM <DATTYP .STRD> .SSAC> .SAC .STAY-MEM>)
1023 (ELSE <SET STRD <RSTRING .STRD .SAC .STAY-MEM>>)>
1027 <EMIT <INSTRUCTION `DPB
1028 <ACSYM <CHTYPE <DATVAL .VD> AC>>
1029 !<ADDR:VALUE .STRD>>>)
1031 <PUT .SSAC ,ACPROT T>
1033 <PUT .SSAC ,ACPROT <>>
1034 <EMIT <INSTRUCTION `DPB
1035 <ACSYM <CHTYPE <DATVAL .VD> AC>>
1036 <ADDRSYM .SSAC>>>)>)>)>
1037 <COND (.VN <RET-TMP-AC .VD>)>
1038 <COND (.STAY-MEM <SET STORE-SET T> .STRD) (ELSE <MOVE:ARG .STRD .W>)>>
1040 <DEFINE STRING-NTH (N W TYP TPS NK NUM STRN NUMN NR "AUX" STRD RES)
1041 #DECL ((N STRN) NODE (STRD) DATUM (RES) <DATUM ATOM AC>)
1053 <==? <NODE-NAME .N> INTH>
1056 <DATUM <COND (<==? .TPS STRING> CHARACTER)
1058 <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
1059 <SGETREG <DATVAL .W> <>>)
1060 (ELSE <GETREG <>>)>>>
1061 <PUT <DATVAL .RES> ,ACLINK (.RES !<ACLINK <DATVAL .RES>>)>
1062 <COND (.NK <TOACV .STRD> <MUNG-AC <DATVAL .STRD> .STRD>)>
1064 <EMIT <INSTRUCTION <COND (.NK `ILDB ) (ELSE `LDB )>
1065 <ACSYM <DATVAL .RES>>
1066 !<ADDR:VALUE .STRD>>>
1069 <DEFINE STRING-PUT (N W TYP TPS NK NUM STRN NUMN VN NR SAME?
1070 "AUX" STRD RES (ONO .NO-KILL) (NO-KILL .ONO))
1071 #DECL ((NO-KILL) <SPECIAL LIST> (NR) <OR FALSE <LIST FIX FIX>>)
1085 <DEFINE STRINGER (NUM ND STRD "AUX" SAC SACT)
1086 #DECL ((STRD ND) DATUM (NUM) <OR FALSE FIX> (SAC SACT) AC)
1087 <COND (<AND .NUM <L? .NUM 5>> <>)
1090 <COND (<AND <NOT .NUM> <TYPE? <DATVAL .ND> AC>>
1091 <MUNG-AC <DATVAL .ND> .ND>
1093 (ELSE <GETREG <>>)>>
1096 <COND (<==? .SAC ,LAST-AC>
1097 <SET SAC <SGETREG ,LAST-AC-1 <>>>
1098 <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
1099 <SGETREG ,LAST-AC <>>)
1101 <SET SACT <SGETREG <NTH ,ALLACS <+ <ACNUM .SAC> 1>> <>>>)>
1102 <PUT .SAC ,ACPROT <>>
1103 <EMIT <INSTRUCTION `LDB
1105 [<FORM (98688) !<ADDR:VALUE .STRD>>]>>
1106 <EMIT '<`MOVEI `O 36>>
1107 <EMIT <INSTRUCTION `IDIVM `O <ADDRSYM .SACT>>>
1108 <COND (.NUM <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> .NUM>>)
1109 (<==? .SAC <DATVAL .ND>>)
1111 <PUT .SAC ,ACPROT T>
1112 <EMIT <INSTRUCTION `MOVE
1115 <PUT .SAC ,ACPROT <>>)>
1116 <EMIT <INSTRUCTION `IDIV <ACSYM .SAC> <ADDRSYM .SACT>>>
1119 <DEFINE RSTRING (ST SAC STAY-MEM "AUX" (SAC1 <NTH ,ALLACS <+ <ACNUM .SAC> 1>>))
1120 #DECL ((SAC SAC1) AC (ST) DATUM)
1121 <COND (<AND <TYPE? <DATVAL .ST> AC> <NOT <ACRESIDUE <DATVAL .ST>>>>
1122 <MUNG-AC <DATVAL .ST> .ST>
1123 <EMIT <INSTRUCTION `ADD <ACSYM <CHTYPE <DATVAL .ST> AC>> <ADDRSYM .SAC>>>
1124 <SET SAC <DATVAL .ST>>)
1126 <EMIT <INSTRUCTION `ADDM <ACSYM .SAC> !<ADDR:VALUE .ST>>>)
1128 <EMIT <INSTRUCTION `ADD <ACSYM .SAC> !<ADDR:VALUE .ST>>>
1129 <RET-TMP-AC <DATVAL .ST> .ST>
1130 <PUT .ST ,DATVAL .SAC>
1131 <PUT .SAC ,ACLINK (.ST !<ACLINK .SAC>)>)>
1132 <EMIT <INSTRUCTION `JUMPE <ACSYM .SAC1> '.HERE!-OP!-PACKAGE 3>>
1133 <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .ST>>>
1134 <EMIT <INSTRUCTION `SOJG <ACSYM .SAC1> '.HERE!-OP!-PACKAGE -1>>
1147 <SETG STYPES ![LIST TUPLE VECTOR UVECTOR STORAGE STRING BYTES TEMPLATE!]>
1149 <DEFINE NTH-PRED (C) #DECL ((C) FIX) <==? .C 1>>
1152 [<AND <GASSIGNED? TEMPLATE-NTH> ,TEMPLATE-NTH>
1161 <DEFINE PUT-GEN (NOD WHERE "OPTIONAL" (SAME? <>)
1162 "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
1163 (TPS <STRUCTYP .TYP>) (2ARG <2 .K>)
1164 (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
1165 (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
1167 <INDEX <NODE-NAME .2ARG>>)
1168 (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
1169 (NR <GET-RANGE <RESULT-TYPE .2ARG>>) TEM W (1ARG <1 .K>)
1170 (NRP <NTH-REST-PUT? <1 .K>>) PUT-COMMON-DAT)
1171 #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (NUM) FIX
1172 (PUT-COMMON-DAT) <SPECIAL DATUM> (W) DATUM)
1173 <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
1174 <COND (<AND <==? .WHERE FLUSHED>
1175 <SET TEM <FIND-COMMON-REST-NODE .NOD>>
1176 <OR <NOT .CAREFUL> <NOT <MEMQ .TPS '[UVECTOR STORAGE]>>>>
1178 <COMMON-CLOBBER .TEM
1189 <PROG ((COMMON-SUB <>))
1190 #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
1192 <APPLY <NTH ,PUTTERS <LENGTH <CHTYPE <MEMQ .TPS ,STYPES>
1205 <SET TEM .COMMON-SUB>>
1206 <OR <==? <TYPEPRIM .TPS> TEMPLATE>
1207 <AND <TYPE? <DATTYP .W> AC>
1208 <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
1209 <AND <TYPE? <DATVAL .W> AC>
1210 <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
1230 <OR <==? <TYPEPRIM .TPS> TEMPLATE>
1231 <AND <TYPE? <DATTYP .W> AC>
1232 <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
1233 <AND <TYPE? <DATVAL .W> AC>
1234 <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
1255 <DEFINE VEC-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?
1256 "AUX" VN (ONO .NO-KILL) (NO-KILL .ONO)
1257 (RV <AND <NOT .SAME?> <COMMUTE-STRUC <> .NNOD .SNOD>>)
1260 <COMMUTE-STRUC <> .VNOD .SNOD>
1261 <COMMUTE-STRUC <> .VNOD .NNOD>>) (MP <MPCNT .TPS>)
1262 (NN 0) NAC SAC STR NUMN TEM (CFLG 0))
1263 #DECL ((N SNOD NNOD VNOD) NODE (NUM NN MP CFLG) FIX (SAC NAC) AC
1264 (NUMN STR VN) DATUM (NO-KILL) <SPECIAL LIST>
1265 (NR) <OR FALSE <LIST FIX FIX>>)
1267 <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " PUT>)
1268 (<OR <NOT .CAREFUL> <L=? .NUM <MINL .TYP>> <1? <SET CFLG .NUM>>>
1270 <SET VN <GEN .VNOD DONT-CARE>>
1271 <SET PUT-COMMON-DAT .VN>
1272 <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1273 <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>)
1275 <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1276 <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>
1279 <SET VN <GEN .VNOD DONT-CARE>>>>)>
1280 <DELAY-KILL .NO-KILL .ONO>
1281 <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS .NUM>)
1282 (ELSE <DATCLOB .VNOD .VN .NUM .MP .STR .TYP T>)>
1286 <SET VN <GEN .VNOD DONT-CARE>>
1287 <SET PUT-COMMON-DAT .VN>
1288 <SET SAC <DATVAL <SET STR <GEN .SNOD <PREG? .TYP .W>>>>>
1289 <MUNG-AC .SAC .STR>)
1291 <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1293 <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>
1294 <SET SAC <DATVAL <SET STR <TOACV .STR>>>>
1295 <MUNG-AC .SAC .STR>)>
1296 <DELAY-KILL .NO-KILL .ONO>
1297 <EMIT <INSTRUCTION `ADD
1299 [<FORM <SET NN <* <- .NUM 1> .MP>> (.NN)>]>>
1301 <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS 1>)
1302 (ELSE <DATCLOB .VNOD .VN 1 .MP .STR .TYP T .NUM>)>
1303 <SET SAC <DATVAL <TOACV .STR>>>
1304 <OR <==? .W FLUSHED>
1305 <EMIT <INSTRUCTION `SUB
1307 [<FORM .NN (.NN)>]>>>
1308 <MOVE:ARG .STR .W>)>)
1310 <COND (.RR <SET VN <GEN .VNOD DONT-CARE>> <SET PUT-COMMON-DAT .VN>)>
1312 <PREFER-DATUM <SET STR <PREG? .TYP .W>>>
1313 <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>
1314 <SET STR <GEN .SNOD .STR>>
1316 <SET NAC <DATVAL .NUMN>>)
1318 <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1319 <SET NAC <DATVAL <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>>>)>
1320 <COND (.RR <DELAY-KILL .NO-KILL .ONO>)>
1322 <SET SAC <DATVAL .STR>>
1323 <MUNG-AC .NAC .NUMN>
1325 <NOT <AND .NR <G? <1 .NR> 0>>>
1326 <EMIT <INSTRUCTION `JUMPLE <ACSYM .NAC> |CERR1 >>>
1327 <OR <1? .MP> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>>
1328 <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
1329 <EMIT <INSTRUCTION `ADD <ACSYM .NAC> <ADDRSYM .SAC>>>
1330 <AND .CAREFUL <NOT <AND .NR <L=? <2 .NR> <MINL .TYP>>>> <RCHK .NAC T>>
1331 <RET-TMP-AC <DATTYP .NUMN> .NUMN>
1332 <COND (<==? .TPS TUPLE>
1333 <PUT .NUMN ,DATTYP <DATTYP .STR>>
1334 <COND (<TYPE? <DATTYP .STR> AC>
1335 <PUT <SET SAC <DATTYP .STR>>
1337 (.NUMN !<ACLINK .SAC>)>)>)
1338 (ELSE <PUT .NUMN ,DATTYP .TPS>)>
1340 <DELAY-KILL .NO-KILL .ONO>
1342 <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>)>
1343 <COND (.SAME? <SPEC-GEN .VNOD .NUMN .TPS 0>)
1344 (ELSE <DATCLOB .VNOD .VN 0 .MP .NUMN .TYP <>>)>
1346 <MOVE:ARG .STR .W>)>>
1348 <DEFINE LIST-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?)
1349 #DECL ((N SNOD NNOD NOD) NODE (NUM) FIX)
1365 [<AND <GASSIGNED? TEMPLATE-PUT> ,TEMPLATE-PUT>
1374 <DEFINE DATCLOB (VNOD N O TY N2 TP NK
1376 "AUX" (ETYP <GET-ELE-TYPE .TP <COND (.NK .RN) (ELSE ALL)>>)
1377 (VTYP <RESULT-TYPE .VNOD>) TT TEM)
1378 #DECL ((N) DATUM (O RN TY) FIX (N2) DATUM (VNOD) NODE)
1379 <SET O <+ <* <- .O 1> .TY> -2 .TY>>
1383 (<AND .CAREFUL <NOT <TYPESAME .ETYP .VTYP>>>
1384 <COND (<SET TT <ISTYPE? .ETYP>>
1385 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .N>>>
1386 <EMIT <INSTRUCTION `CAIE `O <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
1387 <BRANCH:TAG |CERR3 >)
1388 (<SET TT <ISTYPE? .VTYP>>
1390 <GETUVT <DATVAL .N2> ,ACO T>
1391 <EMIT <INSTRUCTION `CAIE `O <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
1392 <BRANCH:TAG |CERR3 >)
1394 <PUT <SET TT <GETREG <>>> ,ACPROT T>
1395 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
1399 <GETUVT <DATVAL .N2> ,ACO T>
1400 <EMIT <INSTRUCTION `CAIE `O (<ADDRSYM .TT>)>>
1401 <BRANCH:TAG |CERR3 >
1402 <PUT .TT ,ACPROT <>>)>
1403 <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)
1405 <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)>)
1408 <COND (<AND <SET ETYP <ISTYPE-GOOD? .ETYP>>
1409 <TYPESAME .ETYP .VTYP>>
1410 <DATUM .ETYP <OFFPTR .O .N2 VECTOR>>)
1411 (ELSE <DATUM <SET TEM <OFFPTR .O .N2 VECTOR>> .TEM>)>>)>>
1415 <COND (<OR <==? .TY UVECTOR> <==? .TY STORAGE>> 1)
1418 <DEFINE IPUT-GEN (NOD WHERE
1419 "AUX" (OS .STK) (STK (0 !.STK)) PINDIC (K <KIDS .NOD>) PITEM)
1420 #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (PITEM PINDIC) DATUM
1421 (STK) <SPECIAL LIST>)
1422 <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
1423 <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
1424 <RET-TMP-AC <STACK:ARGUMENT <GEN <3 .K> DONT-CARE>>>
1426 <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
1427 <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
1430 <EMIT <INSTRUCTION `PUSHJ `P* <COND (<==? <NODE-SUBR .NOD> ,PUT> |CIPUT)
1433 <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1435 <DEFINE IREMAS-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) PINDIC PITEM)
1436 #DECL ((NOD) NODE (K) <LIST NODE NODE> (PINDIC PITEM) DATUM)
1437 <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
1438 <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
1439 <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
1440 <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
1443 <EMIT <INSTRUCTION `PUSHJ `P* |CIREMA >>
1444 <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1446 <DEFINE PUTREST-GEN (NOD WHERE
1447 "AUX" ST1 ST2 (K <KIDS .NOD>) (FLG T) N CD (ONO .NO-KILL)
1448 (NO-KILL .ONO) (2RET <>))
1449 #DECL ((NOD N) NODE (K) <LIST NODE NODE> (ST1 ST2) DATUM
1450 (NO-KILL) <SPECIAL LIST> (ONO) LIST)
1451 <COND (<==? <NODE-SUBR .NOD> ,REST>
1454 <SET 2RET T>)> ;"Really <REST <PUTREST ...."
1455 <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
1456 <==? <NODE-NAME <2 .K>> ()>>
1457 <SET ST1 <GEN <1 .K> <UPDATE-WHERE .NOD .WHERE>>>)
1458 (<AND <NOT <SIDE-EFFECTS? <1 .K>>>
1459 <NOT <SIDE-EFFECTS? <2 .K>>>
1460 <MEMQ <NODE-TYPE <1 .K>> ,SNODES>>
1461 <AND <==? <NODE-TYPE <SET N <1 .K>>> ,LVAL-CODE>
1462 <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
1464 <SET CD <NODE-NAME .N>>
1467 #DECL ((LL) <LIST SYMTAB ANY>)
1468 <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
1470 <SET NO-KILL ((.CD <>) !.NO-KILL)>>
1473 <COND (.2RET <GOODACS <2 .K> .WHERE>)
1474 (ELSE <DATUM LIST ANY-AC>)>>>
1477 <COND (.2RET DONT-CARE)
1478 (ELSE <UPDATE-WHERE .NOD .WHERE>)>>>
1479 <DELAY-KILL .NO-KILL .ONO>)
1484 <COND (<OR <==? .WHERE FLUSHED> .2RET>
1487 <SET ST2 <GEN <2 .K> <DATUM LIST ANY-AC>>>)>
1490 <G? 1 <MINL <RESULT-TYPE <1 .K>>>>
1491 <COND (<TYPE? <DATVAL .ST1> AC>
1492 <EMIT <INSTRUCTION `JUMPE <ACSYM <DATVAL .ST1>> |CERR2 >>)
1494 <EMIT <INSTRUCTION `SKIPN !<ADDR:VALUE .ST1>>>
1495 <BRANCH:TAG |CERR2 >)>>
1496 <AND <ASSIGNED? ST2> <TOACV .ST2>>
1497 <OR <TYPE? <DATVAL .ST1> AC> <SET FLG <>>>
1498 <COND (<ASSIGNED? ST2>
1500 <EMIT <INSTRUCTION `HRRM
1501 <ACSYM <CHTYPE <DATVAL .ST2> AC>>
1502 (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
1504 <EMIT <INSTRUCTION `HRRM
1505 <ACSYM <CHTYPE <DATVAL .ST2> AC>>
1507 !<ADDR:VALUE .ST1>>>)>
1508 <RET-TMP-AC <COND (.2RET .ST1) (ELSE .ST2)>>)
1511 <EMIT <INSTRUCTION `HLLZS (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
1513 <EMIT <INSTRUCTION `HLLZS `@ !<ADDR:VALUE .ST1>>>)>)>
1514 <MOVE:ARG <COND (.2RET .ST2) (ELSE .ST1)> .WHERE>>
1516 <DEFINE SIDE-EFFECTS? (N)
1518 <AND <N==? <NODE-TYPE .N> ,QUOTE-CODE> <SIDE-EFFECTS .N>>>
1520 <DEFINE COMMUTE-STRUC (RV NUMNOD STRNOD "AUX" N (L .NO-KILL) CD (FLG T))
1521 #DECL ((NO-KILL) LIST (NUMNOD STRNOD) NODE (L) LIST)
1524 <OR <AND <==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
1526 <NOT <SIDE-EFFECTS .NUMNOD>>>
1527 <MEMQ <SET CD <NODE-TYPE <SET N .STRNOD>>> ,SNODES>>
1529 <OR <AND <==? <NODE-TYPE .STRNOD> ,QUOTE-CODE>
1531 <NOT <SIDE-EFFECTS .STRNOD>>>
1532 <NOT <MEMQ <SET CD <NODE-TYPE <SET N .NUMNOD>>> ,SNODES>>>>
1534 <==? .CD ,LVAL-CODE>
1535 <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
1537 <SET CD <NODE-NAME .N>>
1540 #DECL ((LL) <LIST SYMTAB ANY>)
1541 <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
1543 <SET NO-KILL ((.CD <>) !.L)>)>
1548 <DEFINE DEFER-IT (NOD STR "AUX" SAC SAC1 STR1 COD)
1549 #DECL ((STR STR1) DATUM (NOD) NODE (SAC SAC1) AC (COD) FIX)
1551 (<1? <SET COD <DEFERN <RESULT-TYPE .NOD>>>>
1552 <COND (<AND <ACRESIDUE
1554 <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>>
1555 <NOT <0? <CHTYPE <FREE-ACS T> FIX>>>>
1556 <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
1557 <PUT .STR1 ,DATVAL .SAC1>
1558 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC1> 1 (<ADDRSYM .SAC>)>>
1563 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>)
1564 (<AND <NOT <0? .COD>>
1565 <G? <CHTYPE <FREE-ACS T> FIX> 0>
1566 <ACRESIDUE <SET SAC <DATVAL .STR>>>
1569 #DECL ((ITEM) SYMBOL)
1570 <COND (<AND <TYPE? .ITEM SYMTAB> <NOT <STORED .ITEM>>>
1574 <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
1575 <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
1576 <PUT .STR1 ,DATVAL .SAC1>
1577 <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC1> (<ADDRSYM .SAC>)>>
1578 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
1579 <EMIT <INSTRUCTION `CAIN `O TDEFER!-OP!-PACKAGE>>
1580 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC1> 1 (<ADDRSYM .SAC1>)>>
1585 <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
1587 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
1588 <EMIT <INSTRUCTION `CAIN `O TDEFER!-OP!-PACKAGE>>
1589 <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>
1594 "ROUTINES TO DO COMMON SUBEXPRESSION HACKING IN SIMPLE CASES
1595 (CURRENTLY NTH REST)."
1597 "ROUTINE TO CREATE A COMMON"
1599 <DEFINE COMMON (CODE SYMT OBJ PTYP DAT)
1600 #DECL ((CODE) ATOM (SYMT) <OR SYMTAB COMMON> (OBJ) FIX)
1601 <CHTYPE [.CODE .SYMT .OBJ .PTYP .DAT] COMMON>>
1603 "THIS ROUTINE BUILDS A CANONACAILZED COMMON. THIS ROUTINE CAN RETURN
1604 EITHER A COMMON OR A LIST OF COMMONS."
1606 <DEFINE BUILD-COMMON (CODE COMSYMT ITEM PTYP DAT "AUX" INAC COMM COMT CUR-COM)
1607 #DECL ((CODE) ATOM (COMSYMT) <OR SYMTAB COMMON LIST> (ITEM) FIX
1608 (CUR-COM) <OR COMMON <LIST [REST COMMON]>>)
1609 <COND (<TYPE? .COMSYMT LIST>
1610 <REPEAT ((PTR .COMSYMT) (CLIST ()))
1611 <COND (<EMPTY? .PTR>
1612 <RETURN <COND (<1? <LENGTH .CLIST>> <1 .CLIST>)
1614 <SET CUR-COM <BUILD-COMMON .CODE <1 .PTR> .ITEM .PTYP .DAT>>
1615 <COND (<TYPE? .CUR-COM COMMON>
1616 <SET CLIST (.CUR-COM !.CLIST)>)
1617 (<PUTREST <REST .CUR-COM <- <LENGTH .CUR-COM> 1>>
1619 <SET PTR <REST .PTR>>>)
1620 (<TYPE? .COMSYMT SYMTAB>
1621 <COND (<AND <SET INAC <INACS .COMSYMT>>
1622 <SET COMM <FIND-COMMON-AC <DATVAL .INAC>>>>
1623 <SET COMT <BUILD-COMMON .CODE .COMM .ITEM .PTYP .DAT>>
1624 <COND (<TYPE? .COMT LIST>
1625 (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> !.COMT))
1627 (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> .COMT))>)
1628 (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)
1630 <COND (<==? <COMMON-TYPE .COMSYMT> REST>
1631 (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>
1633 <COMMON-SYMT .COMSYMT>
1634 <+ .ITEM <COMMON-ITEM .COMSYMT>>
1637 (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)>>
1639 "ROUTINE TO FIND A COMMON GIVEN A NODE"
1641 <DEFINE FIND-COMMON (NOD "OPTIONAL" (NAME <>) (NUM <>))
1645 <FUNCTION (AC "AUX" ACR)
1648 (<SET ACR <ACRESIDUE .AC>>
1651 <COND (<AND <TYPE? .ITEM COMMON>
1654 .NAME .NOD .NUM .ITEM>)
1655 (<COMMON-EQUAL .NOD .ITEM>)>>
1656 <RETURN .ITEM .RTPNT>)>>
1660 "ROUTINE TO SEE IF A COMMON AND A NODE ARE EQUAL"
1662 <DEFINE COMMON-EQUAL (NODE COM)
1663 #DECL ((NODE) <OR NODE SYMTAB> (COM) <OR SYMTAB COMMON>)
1664 <COND (<==? .NODE .COM>)
1665 (<NOT <OR <TYPE? .NODE SYMTAB> <TYPE? .COM SYMTAB>>>
1666 <AND <EQCODE .NODE .COM>
1668 <EQKIDS .NODE .COM>>)>>
1670 "ROUTINE TO SEE IF THE CODES OF THE COMMONS ARE EQUAL"
1672 <DEFINE EQCODE (NODE COM "OPTIONAL" (NT <NODE-TYPE .NODE>))
1673 #DECL ((NODE) NODE (COM) COMMON)
1674 <OR <AND <==? .NT ,NTH-CODE> <==? <COMMON-TYPE .COM> NTH>>
1675 <AND <==? .NT ,REST-CODE> <==? <COMMON-TYPE .COM> REST>>>>
1677 "ROUTINE TO SEE IF THE NUMBERS OF A COMMON AND A NODE ARE EQUAL"
1679 <DEFINE EQNUM (NODE COM "OPTIONAL" (NUM <NODE-NAME <2 <KIDS .NODE>>>))
1680 #DECL ((NODE) NODE (COM) COMMON)
1681 <==? <COMMON-ITEM .COM> .NUM>>
1683 "ROUTINE TO SEE IF THE KIDS OF A COMMON AND A NODE ARE EQUAL"
1685 <DEFINE EQKIDS (NODE COM "OPTIONAL" (KID <1 <KIDS .NODE>>))
1686 #DECL ((NODE) NODE (COM) COMMON)
1687 <COMMON-EQUAL <COND (<SYMTAB? .KID T>) (.KID)>
1688 <COMMON-SYMT .COM>>>
1690 "ROUTINE TO FLUSH COMMONS IF PUTS OR PUTRESTS COME ALONG
1691 IF TYP IS FALSE THEN KILL ALL COMMONS.
1692 OTHERWISE KILL THOSE COMMONS WHICH ARE TYE SAME TYPE AS TYP OR UNKNOWN."
1694 <DEFINE KILL-COMMON (PTYP)
1695 #DECL ((TYP) <OR FALSE ATOM>)
1697 <FUNCTION (AC "AUX" ACR)
1699 <COND (<SET ACR <ACRESIDUE .AC>>
1700 <PUT .AC ,ACRESIDUE <FLUSH-COMMONS .ACR .PTYP>>)>>
1703 "FLUSH-COMMONS IS USED TO FLUSH ALL THE COMMONS FROM AN AC"
1705 <DEFINE FLUSH-COMMONS FC (ACR PTYP)
1706 #DECL ((TYP) <OR ATOM FALSE> (ACR) LIST)
1708 <COND (<FLUSH? <1 .ACR> .PTYP>
1709 <COND (<EMPTY? <SET ACR <REST .ACR>>> <RETURN <> .FC>)>)
1711 <REPEAT ((PTR <REST .ACR>) (TOPACR .ACR))
1712 <COND (<EMPTY? .PTR> <RETURN .TOPACR>)>
1713 <COND (<FLUSH? <1 .PTR> .PTYP> <PUTREST .ACR <REST .PTR>>)>
1714 <SET ACR <REST .ACR>>
1715 <SET PTR <REST .PTR>>>>
1717 "FLUSH? SEES IF A COMMON SHOULD BE FLUSHED"
1719 <DEFINE FLUSH? (COM PTYP)
1721 <AND <TYPE? .COM COMMON>
1722 <==? <COMMON-PRIMTYPE .COM> .PTYP>>>>
1724 "FLUSH-COMMON-SYMT IS USED TO FLUSH THE COMMONS ASSOCATED WITH A GIVEN SYMTAB"
1726 <DEFINE FLUSH-COMMON-SYMT (SYMT)
1727 #DECL ((SYMT) SYMTAB)
1729 <FUNCTION (AC "AUX" ACR)
1732 <COND (<SET ACR <ACRESIDUE .AC>>
1733 <COND (<EQSYMT <1 .ACR> .SYMT> <REST .ACR>)
1734 (<REPEAT ((PTR <REST .ACR>) (SACR .ACR))
1735 <COND (<EMPTY? .PTR> <RETURN .SACR>)>
1736 <COND (<EQSYMT <1 .PTR> .SYMT>
1737 <PUTREST .ACR <REST .PTR>>
1739 <SET PTR <REST .PTR>>
1740 <SET ACR <REST .ACR>>>)>)>>
1741 <PUT .AC ,ACRESIDUE <COND (<EMPTY? .ACR> <>) (ELSE .ACR)>>>
1744 <DEFINE EQSYMT (ITEM SYMT "AUX" COM)
1745 <COND (<TYPE? .ITEM COMMON>
1746 <OR <==? <SET COM <COMMON-SYMT .ITEM>> .SYMT>
1747 <EQSYMT .COM .SYMT>>)>>
1749 "SEE IF NODE CONTAINS SYMTABS"
1751 <DEFINE SYMTAB? (NOD "OPTIONAL" (SRCHCOM <>))
1753 <COND (<OR <==? <NODE-TYPE .NOD> ,LVAL-CODE>
1754 <AND <NOT .SRCHCOM> <==? <NODE-TYPE .NOD> ,SET-CODE>>>
1757 "SEE IF THIS IS A NTH OR REST OR PUT CODE"
1759 <DEFINE NTH-REST-PUT? (NOD "AUX" (COD <NODE-TYPE .NOD>))
1761 <OR <==? .COD ,PUT-CODE>
1762 <==? .COD ,REST-CODE>
1763 <==? .COD ,NTH-CODE>>>
1765 "SMASH A COMMON INTO AN DATUM"
1767 <DEFINE SMASH-COMMON (COM DAT "AUX" AC)
1768 #DECL ((DAT) DATUM (COM) COMMON)
1769 <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
1770 <OR <MEMQ .COM <ACRESIDUE .AC>>
1771 <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
1772 <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
1773 <OR <MEMQ .COM <ACRESIDUE .AC>>
1774 <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
1775 <PUT .COM ,COMMON-DATUM <DATUM !.DAT>>>
1777 <DEFINE HACK-COMMON (COD 2NARGNOD TEM WHERE W NUMKN NUM PTYP NRP
1778 "AUX" (COM-ITEM <>) COM)
1780 <COND (<AND <N==? .WHERE FLUSHED> <TYPE? <DATVAL .W> AC> .NUMKN>
1781 <COND (<SET COM-ITEM <SYMTAB? .2NARGNOD>>)
1782 (.NRP <SET COM-ITEM .TEM>)>
1784 <SET COM <BUILD-COMMON .COD .COM-ITEM .NUM .PTYP .W>>
1785 <COND (<TYPE? .COM LIST>
1786 <MAPF <> <FUNCTION (X) <SMASH-COMMON .X .W>> .COM>)
1787 (<SMASH-COMMON .COM .W>)>
1788 <SET COMMON-SUB .COM>)>)>>
1790 <DEFINE FIND-COMMON-AC (AC)
1791 <COND (<TYPE? .AC AC>
1794 <COND (<TYPE? .ITEM COMMON> <MAPLEAVE .ITEM>)>>
1797 <DEFINE FIND-COMMON-REST-NODE (NOD "AUX" (K <KIDS .NOD>))
1798 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
1799 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
1802 <- <CHTYPE <NODE-NAME <2 .K>> FIX> 1>>>>
1804 <DEFINE SPEC-COMMON-EQUAL (NAME KID NUM COM)
1805 #DECL ((NAME) ATOM (NUM) FIX (KID) NODE (COM) COMMON)
1806 <AND <==? <COMMON-TYPE .COM> .NAME>
1807 <EQNUM .KID .COM .NUM>
1808 <EQKIDS .KID .COM .KID>>>
1810 <DEFINE COMMON-CLOBBER (TEM NOD VAL NUM OBJ TPS SAME?
1811 "AUX" TSM (NDAT <COMMON-DATUM .TEM>)
1812 (ETYP <GET-ELE-TYPE .OBJ .NUM>)
1813 (VTYP <RESULT-TYPE .VAL>) ODAT VDAT AC)
1814 #DECL ((VDAT ODAT NDAT) DATUM (TEM) COMMON (NOD) NODE (NUM) FIX
1817 <OR <TYPESAME .ETYP .VTYP>
1818 <MEMQ .TPS '![STORAGE UVECTOR STRING!]>>>
1819 <SET ODAT <DATUM .TPS <DATVAL .NDAT>>>
1820 <COND (<AND <NOT .TSM> <TYPE? <SET AC <DATTYP .NDAT>> AC>> <SGETREG .AC .ODAT>)>
1821 <COND (<TYPE? <SET AC <DATVAL .NDAT>> AC> <SGETREG .AC .ODAT>)>
1825 <DATUM <COND (<NOT .TSM> ANY-AC) (FLUSHED)> ANY-AC>>>>
1826 <COND (.SAME? <SPEC-GEN .VAL .ODAT .TPS 0>)
1828 <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT T>
1829 <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT T>)>
1830 <COND (<NOT <TYPE? <DATVAL .ODAT> AC>> <TOACV .ODAT>)>
1831 <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT <>>
1832 <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT <>>)>
1834 <EMIT <INSTRUCTION <COND (<=? .TPS LIST> `HLLM ) (ELSE `MOVEM )>
1835 <ACSYM <CHTYPE <DATTYP .VDAT> AC>>
1836 (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>
1837 <COND (<==? .TPS STRING>
1838 <EMIT <INSTRUCTION `IDPB
1839 <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
1840 <ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>>>)
1841 (<EMIT <INSTRUCTION `MOVEM
1842 <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
1844 (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>)>
1849 <DEFINE LOC-COMMON (TEM NOD TPS 1ARG 2ARG WHERE "AUX" W NDAT)
1850 #DECL ((TEM) COMMON (NOD 1ARG 2ARG) NODE (WHERE W) <OR ATOM DATUM>
1852 <COND (<AND <N==? .WHERE FLUSHED> <N==? .TPS STRING>>
1854 <DATUM <OFFPTR 0 <SET NDAT <GET-COMMON-DATUM .TEM>> .TPS>
1855 <OFFPTR 0 .NDAT .TPS>>
1859 <DEFINE GET-COMMON-DATUM (COM "AUX" TEM DAT)
1860 #DECL ((COM) COMMON (DAT) DATUM)
1861 <SET DAT <DATUM !<COMMON-DATUM .COM>>>
1862 <COND (<TYPE? <SET TEM <DATTYP .DAT>> AC>
1863 <PUT .TEM ,ACLINK (.DAT !<ACLINK .TEM>)>)>
1864 <PUT <SET TEM <CHTYPE <DATVAL .DAT> AC>> ,ACLINK (.DAT !<ACLINK .TEM>)>