3 <ENTRY PROG-REP-GEN RETURN-GEN AGAIN-GEN TAG-GEN GO-GEN CLEANUP-STATE
4 AGAIN-UP RETURN-UP PROG-START-AC>
6 <USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC" "CUP">
8 " Generate code for a poor innocent PROG or REPEAT."
13 <DEFINE PROG-REP-GEN (PNOD PWHERE
14 "AUX" (BSTB .BSTB) (NTSLOTS .NTSLOTS) XX (SPECD <>)
15 START:TAG (STB .STK) (STK (0 !.STK))
18 (<STACK:L .STK .BSTB>)
19 (ELSE (0))>) (TMPS .TMPS) BTP (BASEF .BASEF)
20 EXIT EXIT:OFF AGAIN (FRMS .FRMS) (OPRE .PRE) DEST
21 (CD <>) (AC-HACK .AC-HACK) (K <KIDS .PNOD>)
22 (SPEC-LIST .SPEC-LIST) TEM (ONS .NTSLOTS)
23 (ORPNOD <AND <ASSIGNED? RPNOD> .RPNOD>) RPNOD
25 #DECL ((NTSLOTS STB) <SPECIAL LIST> (BASEF PNOD RPNOD) <SPECIAL NODE>
26 (PWHERE DEST) <OR ATOM DATUM> (SPECD PRE) <SPECIAL ANY>
27 (STK FRMS) <SPECIAL LIST> (BTP NSTB) LIST
28 (AC-HACK) <SPECIAL <PRIMTYPE LIST>> (TMPS) <SPECIAL LIST>
29 (START:TAG) <SPECIAL ATOM> (K) <LIST [REST NODE]>
30 (SPEC-LIST) <SPECIAL LIST>)
32 <COND (<N==? <NODE-SUBR .PNOD> ,BIND> <SET RPNOD .PNOD>)
33 (.ORPNOD <SET RPNOD .ORPNOD>)>
34 <PUT .PNOD ,SPECS-START <- <SPECS-START .PNOD> .TOT-SPEC>>
36 <BEGIN-FRAME <TMPLS .PNOD> <ACTIVATED .PNOD> <PRE-ALLOC .PNOD>>
38 <COND (<==? .PWHERE FLUSHED> FLUSHED)
39 (ELSE <GOODACS .PNOD .PWHERE>)>>
40 <PROG ((PRE .PRE) (TOT-SPEC .TOT-SPEC))
41 #DECL ((PRE) <SPECIAL ANY> (TOT-SPEC) <SPECIAL FIX>)
43 <EMIT-PRE <NOT <OR <ACTIVATED .PNOD> <0? <SSLOTS .BASEF>>>>>>
44 <COND (<ACTIVATED .PNOD>
49 <SET FRMID <+ .FRMID 1>>
50 <PUT .FRMS 5 .NTSLOTS>
56 (<STACK:L .STK <2 .FRMS>>)
58 (<FORM GVAL <TMPLS .PNOD>>)
63 <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>>)>
64 <COND (<NOT <==? .PWHERE FLUSHED>>
65 <SET DEST <FUNCTION:VALUE>>)>
66 <BUILD:FRAME <SET EXIT:OFF <MAKE:TAG "EXIT">>>
69 <SET EXIT <MAKE:TAG "EXIT">>
70 <PUT .PNOD ,STK-B .STB>
71 <COND (<AND <NOT .PRE> <NOT <ACTIVATED .PNOD>>>
72 <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>> !.NTSLOTS)>)>
74 <SET SPEC-LIST (.PNOD .SPECD <SPECS-START .PNOD> !.SPEC-LIST)>
76 <OR .OPRE <SET BASEF .PNOD>>
78 <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
79 <PROG-START-AC .PNOD>)
80 (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
81 <LABEL:TAG <SET AGAIN <MAKE:TAG "AGAIN">>>
82 <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
84 <PUT .PNOD ,BTP-B .BTP>
85 <PUT .PNOD ,DST .DEST>
86 <PUT .PNOD ,SPCS-X .SPECD>
87 <PUT .PNOD ,ATAG .AGAIN>
88 <PUT .PNOD ,RTAG .EXIT>
89 <PUT .PNOD ,PRE-ALLOC .PRE>
90 <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
91 <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT>
93 <RET-TMP-AC <SET TEM <SEQ-GEN .K FLUSHED T T>>>)
95 <SET TEM <SET CD <SEQ-GEN .K .DEST T T>>>
96 <COND (<==? .TEM ,NO-DATUM>
97 <COND (<EMPTY? <CDST .PNOD>>
99 (ELSE <SET CD <CDST .PNOD>>)>)>)>)
101 <COND (<==? .DEST FLUSHED>
102 <RET-TMP-AC <SET TEM <SEQ-GEN .K .DEST T>>>
103 <COND (<NOT <==? .TEM ,NO-DATUM>>)>)
105 <SET TEM <SET CD <SEQ-GEN .K .DEST T>>>
106 <COND (<==? .TEM ,NO-DATUM>
107 <COND (<EMPTY? <CDST .PNOD>>
109 (ELSE <SET CD <CDST .PNOD>>)>)>)>)>
110 <OR <ASSIGNED? NPRUNE> <PUT .PNOD ,KIDS ()>>
111 <AND .CD <TYPE? .CD DATUM> <PROG ()
113 <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT>
114 <N==? .TEM ,NO-DATUM>>
115 <COND (<ACTIVATED .PNOD> <PROG:END>)
118 <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
119 (ELSE <UNBIND:LOCS .STK .STB>)>)
120 (<==? <NODE-SUBR .PNOD> ,REPEAT>
122 <BRANCH:TAG .AGAIN>)>
123 <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
125 <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <NOT <AGND .PNOD>>>
126 <NON-LOOP-CLEANUP .PNOD>
127 <PROG ((STK .STB) (NTSLOTS .ONS))
128 #DECL ((NTSLOTS STK) <SPECIAL LIST>)
130 <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
131 <CLEANUP-STATE .PNOD>)
132 (ELSE <CHECK:VARS .SACS T>)>
133 <COND (<AND <==? <NODE-SUBR .PNOD> ,REPEAT>
134 <NOT <==? .DEST FLUSHED>>>
135 <MOVE:ARG .DEST .DEST>)>
136 <COND (<AND <TYPE? .DEST DATUM>
137 <ISTYPE? <DATTYP .DEST>>
139 <TYPE? <DATTYP .CD> AC>>
140 <RET-TMP-AC <DATTYP .CD> .CD>)>
142 <COND (<ACTIVATED .PNOD> <LABEL:OFF .EXIT:OFF>)
143 (ELSE <SET TEM .TOT-SPEC>)>>
144 <OR <ACTIVATED .PNOD> <SET TOT-SPEC .TEM>>
147 <AND <TYPE? <DATTYP .DEST> AC>
148 <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
149 <AND <TYPE? <DATVAL .DEST> AC>
150 <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
151 <SET XX <MOVE:ARG .DEST .PWHERE>>
157 " Generate code for a RETURN."
159 <DEFINE RETURN-GEN (NOD WHERE
160 "AUX" (SPECD .SPECD) N NN (CD1 <>) DEST (NF 0)
161 NOT-HANDLED-PROG (NT .NTSLOTS))
162 #DECL ((NOD N RPNOD) NODE (WHERE) <OR ATOM DATUM> (CD1) <OR DATUM
164 (SPECD) <SPECIAL ANY> (NF) FIX)
166 <COND (<1? <LENGTH <KIDS .NOD>>> <SET N .RPNOD>)
167 (<SET NN <RET-AGAIN-ONLY <NODE-NAME <2 <KIDS .NOD>>>>>
169 (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
170 <SET NOT-HANDLED-PROG
171 <NOT <OR <==? <NODE-SUBR .N> ,REPEAT>
172 <AND <==? <NODE-SUBR .N> ,PROG> <AGND .N>>>>>
173 <COND (<==? <SET DEST <DST .N>> FLUSHED>
174 <RET-TMP-AC <GEN <1 <KIDS .NOD>> FLUSHED>>)
178 <SET CD1 <GEN <1 <KIDS .NOD>> <DATUM !.DEST>>>>
180 <ACFIX <DST .N> .CD1>)>
181 <AND .NOT-HANDLED-PROG <VAR-STORE>>
182 <COND (<ACTIVATED .N>
185 <COND (<==? <3 .L> .N> <RETURN>)>
186 <AND <EMPTY? <SET L <REST .L 5>>> <RETURN>>
190 <OR .NOT-HANDLED-PROG <RETURN-UP .N>>
193 <REPEAT ((LL .SPEC-LIST))
195 <AND <2 .LL> <RETURN <SET SPECD T>>>
196 <AND <==? <1 .LL> .N> <RETURN>>
197 <SET LL <REST .LL 3>>>
198 <COND (<TYPE? .CD1 DATUM>
199 <COND (<TYPE? <DATTYP .CD1> AC>
200 <PUT <DATTYP .CD1> ,ACPROT T>)>
201 <COND (<TYPE? <DATVAL .CD1> AC>
202 <PUT <DATVAL .CD1> ,ACPROT T>)>)>
203 <COND (<PRE-ALLOC .N>
204 <POP:LOCS .STK <STK-B .N>>
205 <UNBIND:FUNNY <SPECS-START .N> !.NT>)
206 (ESLE <UNBIND:LOCS .STK <STK-B .N>>)>
207 <COND (<TYPE? .CD1 DATUM>
208 <COND (<TYPE? <DATTYP .CD1> AC>
209 <PUT <DATTYP .CD1> ,ACPROT <>>)>
210 <COND (<TYPE? <DATVAL .CD1> AC>
211 <PUT <DATVAL .CD1> ,ACPROT <>>)>)>
212 <OR .NOT-HANDLED-PROG
213 <PROG ((STB <STK-B .N>))
214 #DECL ((STB) <SPECIAL LIST>)
216 <BRANCH:TAG <RTAG .N>>)>
219 <DEFINE GO:BACK:FRAMES (NF)
223 <EMIT '<`MOVE `TB* |OTBSAV `(TB) >>
224 <COND (<0? <SET NF <- .NF 1>>> <RETURN>)>>>>
228 " Generate code for an AGAIN."
230 <DEFINE AGAIN-GEN (NOD WHERE
231 "AUX" N NN (SPECD .SPECD) (PRE <>) NOT-HANDLED-PROG)
232 #DECL ((NOD N RPNOD) NODE (SPECD) <SPECIAL ANY>)
234 <COND (<EMPTY? <KIDS .NOD>> <SET N .RPNOD>)
235 (<SET NN <RET-AGAIN-ONLY <NODE-NAME <1 <KIDS .NOD>>>>>
237 (ELSE <VAR-STORE <>> <RETURN <SUBR-GEN .NOD .WHERE>>)>
238 <COND (<SET NOT-HANDLED-PROG
239 <NOT <OR <==? <NODE-SUBR .N> ,PROG>
240 <==? <NODE-SUBR .N> ,REPEAT>
241 <==? <NODE-SUBR .N> ,BIND>>>>
243 <COND (<N==? .N <1 .SPEC-LIST>>
244 <REPEAT ((L1 ()) (LL .SPEC-LIST))
246 <AND <EMPTY? <SET L1 <REST .LL 3>>> <RETURN>>
247 <AND <2 .LL> <SET SPECD <3 .LL>>>
248 <COND (<==? <4 .LL> .N>
249 <RETURN <SET PRE <PRE-ALLOC <1 .LL>>>>)
250 (ELSE <SET LL .L1>)>>)>
251 <COND (.PRE <POP:LOCS .STK <BTP-B .N>> <UNBIND:FUNNY .SPECD !.NTSLOTS>)
252 (ELSE <UNBIND:LOCS .STK <BTP-B .N>>)>
253 <OR .NOT-HANDLED-PROG <PROG ((STK <BTP-B .N>)) #DECL ((STK) <SPECIAL LIST>)
255 <BRANCH:TAG <ATAG .N>>
258 " Generate code for a GO in a PROG/REPEAT."
260 <DEFINE GO-GEN (NOD WHERE "AUX" (N <1 <KIDS .NOD>>) (RT <RESULT-TYPE .N>))
261 #DECL ((NOD N) NODE (WHERE) <OR ATOM DATUM>)
263 <COND (<==? .RT ATOM>
264 <POP:LOCS .STK <BTP-B .RPNOD>>
266 <BRANCH:TAG <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>>)
268 <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
270 <EMIT '<MCALL!-OP!-PACKAGE 1 GO>>)>
273 <DEFINE TAG-GEN (NOD WHERE
274 "AUX" (ATM <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>))
276 <EMIT <INSTRUCTION `MOVEI `O .ATM>>
277 <EMIT '<`SUBI `O `(M) >>
278 <EMIT '<`PUSH `TP* <TYPE-WORD!-OP!-PACKAGE FIX>>>
279 <EMIT '<`PUSH `TP* 0>>
281 <EMIT '<`PUSHJ `P* |MAKACT >>
282 <EMIT '<`PUSH `TP* `A >>
283 <EMIT '<`PUSH `TP* `B >>
284 <EMIT '<MCALL!-OP!-PACKAGE 2 TAG>>
285 <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
288 " Generate code to flush stack for leaving a PROG etc."
290 <DEFINE PROG:UNBIND ()
291 #DECL ((STK STB) LIST (PNOD) NODE)
294 <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
295 (ELSE <UNBIND:LOCS .STK .STB>)>>
299 "ROUTINES TO ALLOW KEEPING VARIABLES IN AC'S THRU LOOPS. THE OUTINES KEEP INFORMATION
300 IN THE PROG NODE TELLING INFORMATION AT VARIOUS POINTS (I.E. AGAIN AND RETURN POINTS).
301 VARIABLES KEPT IN ACS WILL CONTAIN POINTERS TO THE PROG NODES INVOLVED AND THE DECISION
302 WILL BE MADE TO KEEP THEM IN AC'S WHEN THEY ARE FIRST REFERENCED. AGAINS AND RETURNS
303 WILL EMIT NULL MACROS AND A FIXUP ROUTINE WILL BE USED AT THE END TO COERCE THE STATES
306 "ROUTINE TO INITIALIZE STATE INFORMATION ON ENTERING LOOPS. IT TAKES A PROG/REPEAT NODE
307 AND WILL UPDATE INFORMATION CONTAING SLOTS AS WELL AS PUTTING THE NODE INTO PROG-AC
308 SLOTS OF APPROPRIATE SYMTABS. THE SLOTS MAY CONTAIN MULTIPLE PROG NODES BUT THE ONE
309 CURRENTLY BEING HACKED WILL BE FIRST. IF FLUSHING A VAR THE ENTIRE SLOT WILL BE
312 <DEFINE PROG-START-AC (PNOD "AUX" (PVARS ()) ONSYMT OPROG-AC OPOTLV)
315 <FUNCTION (AC "AUX" SYMT)
317 <COND (<SET SYMT <CLEAN-AC .AC>>
318 <COND (<NOT <MEMQ .PNOD <PROG-AC .SYMT>>>
319 <SET ONSYMT <NUM-SYM .SYMT>>
320 <SMASH-NUM-SYM .SYMT>
321 <SET OPROG-AC <PROG-AC .SYMT>>
322 <SET OPOTLV <POTLV .SYMT>>
323 <PUT .SYMT ,POTLV <>>
329 <DATUM <DATTYP <INACS .SYMT>>
330 <DATVAL <INACS .SYMT>>>)>
338 <PUT .PNOD ,LOOP-VARS ()>
339 <PUT .PNOD ,AGAIN-STATES ()>
340 <PUT .PNOD ,RETURN-STATES ()>
341 <PUT .PNOD ,PROG-VARS .PVARS>
343 <REPEAT ((PTR .PVARS) SYMT)
344 <COND (<EMPTY? .PTR> <RETURN>)>
345 <SET SYMT <SYM-SLOT .PTR>>
346 <OR <STORED-SLOT <PROG-AC .SYMT>>
347 <PUT <PROG-AC .SYMT> ,NUM-SYM-SLOT <2 <NUM-SYM .SYMT>>>>
348 <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
350 <DEFINE CLEAN-AC (AC "AUX" ACRES INAC OAC)
351 #DECL ((AC) AC (INAC) DATUM)
353 (<SET ACRES <ACRESIDUE .AC>>
354 <PUT .AC ,ACRESIDUE <>>
361 <COND (<N==? .SYMT .SYM>
362 <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
364 <SMASH-INACS .SYMT <>>)
365 (ELSE <STOREV .SYMT T>)>)>>
368 (<AND <SET INAC <INACS .SYM>>
369 <OR <AND <==? <DATTYP .INAC> .AC>
370 <TYPE? <SET OAC <DATVAL .INAC>> AC>>
371 <AND <==? <DATVAL .INAC> .AC>
372 <TYPE? <SET OAC <DATTYP .INAC>> AC>>>>
375 <COND (<N==? .SYMT .SYM>
376 <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
378 <SMASH-INACS .SYMT <>>)
379 (ELSE <STOREV .SYMT T>)>)>>
381 <PUT .OAC ,ACRESIDUE (.SYM)>)>
382 <PUT .AC ,ACRESIDUE (.SYM)>
383 <MAPLEAVE <1 <ACRESIDUE .AC>>>)
384 (ELSE <SMASH-INACS .SYM <>> <>)>>
387 <DEFINE AGAIN-UP (PNOD "OPTIONAL" (RET <>) "AUX" CSTATE)
388 #DECL ((PNOD) NODE (RET) <OR ATOM FALSE>)
389 <SET CSTATE <CURRENT-AC-STATE>>
392 (.CSTATE .CODE:PTR <STACK:INFO> .RET !<AGAIN-STATES .PNOD>)>>
394 <DEFINE RETURN-UP (PNOD "OPTIONAL" (STK .STB) "AUX" CSTATE)
395 #DECL ((PNOD) NODE (STK) <SPECIAL LIST>)
396 <COND (<NOT <AND <OR <==? <NODE-SUBR .PNOD> ,PROG>
397 <==? <NODE-SUBR .PNOD> ,BIND>>
399 <SET CSTATE <CURRENT-AC-STATE .PNOD>>
406 !<RETURN-STATES .PNOD>)>)>>
408 <DEFINE STACK:INFO ()
409 (.FRMS .BSTB .NTSLOTS .STK)>
412 "OK FOLKS HERE IT IS. THIS IS THE ROUTINE THAT MERGES ALL THE STATES IN LOOPS
413 AND DOES THE RIGHT THING IN ALL CASES (MAYBE?). IT TAKES A PROG AND MAKES SURE
414 THAT STATES ARE CONSISTENT AT AGAIN AND RETURN POINTS. FOR AGAIN POINTS IT
415 MAKES SURE THAT ALL LOOP VARIABLES IN THE RIGHT ACS."
417 <DEFINE CLEANUP-STATE (PNOD
418 "AUX" (LOOPVARS <LOOP-VARS .PNOD>)
419 (AGAIN-ST <AGAIN-STATES .PNOD>)
420 (RETURN-ST <RETURN-STATES .PNOD>))
421 #DECL ((PNOD) NODE (RETURN-ST) <SPECIAL LIST>)
422 <FIXUP-STORES .AGAIN-ST>
423 <FIXUP-STORES .RETURN-ST>
424 <CLEANUP-VARS <PROG-VARS .PNOD>>
425 <LOOP-REPEAT .LOOPVARS .AGAIN-ST>
426 <LOOP-RETURN .RETURN-ST>>
428 <DEFINE LOOP-REPEAT (LOOPVARS AGAIN-ST)
429 <REPEAT ((APTR .AGAIN-ST) REST-CODE-PTR)
431 <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>
434 <COND (<EMPTY? .APTR> <RETURN>)>
435 <SET REST-CODE-PTR <REST <SAVED-CODE:PTR .APTR>>>
436 <LOOP-RESTORE <LIST !.LOOPVARS>
437 <SAVED-CODE:PTR .APTR>
438 <SAVED-AC-STATE .APTR>
439 <SAVED-STACK-STATE .APTR>
440 <SAVED-RET-FLAG .APTR>>
442 (<SAVED-RET-FLAG .APTR>
444 (<SAVED-AC-STATE .APTR>
446 <FUNCTION (CP "AUX" (RCP <REST .CP>))
447 #DECL ((CP) <LIST ANY> (RCP) LIST)
448 <COND (<==? .RCP .REST-CODE-PTR>
450 <SAVED-CODE:PTR .APTR>>
451 <SAVED-STACK-STATE .APTR>
454 <SET APTR <REST .APTR ,LENGTH-CONTROL-STATE>>>>
456 <DEFINE LOOP-RESTORE (LPV INST ACS STACK-INFO RET)
457 #DECL ((LPV INST STACK-INFO) <PRIMTYPE LIST> (ACS) REP-STATE
458 (RET) <OR ATOM FALSE>)
459 <PROG ((SCODE:PTR .INST) (BSTB <SAVED-BSTB .STACK-INFO>)
460 (FRMS <SAVED-FRMS .STACK-INFO>)
461 (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
462 (STK <SAVED-STK .STACK-INFO>))
463 #DECL ((NTSLOTS BSTB FRMS STK SCODE:PTR) <SPECIAL LIST>)
464 <STORE-SAVED-ACS .LPV .ACS>
465 <MOVE-AROUND-ACS .LPV .ACS .RET>
466 <GET-ACS-FROM-STACK .LPV .ACS>>>
468 <DEFINE MOVE-AROUND-ACS (LPV ACS RET)
469 #DECL ((LPV) LIST (ACS) REP-STATE (RET) <OR ATOM FALSE>)
470 <REPEAT ((LPVP .LPV) CSYMT CINACS INAC)
471 #DECL ((SYMT) SYMTAB (CINACS) DATUM)
472 <COND (<EMPTY? .LPVP> <RETURN>)>
473 <SET CSYMT <LSYM-SLOT .LPVP>>
474 <SET CINACS <LINACS-SLOT .LPVP>>
475 <COND (<SET INAC <AC? .CSYMT .ACS>>
476 <PUT .LPVP ,LSYM-SLOT <>>
477 <COND (<OR <=? .INAC .CINACS>
478 <AND <TYPE? <DATTYP .CINACS> ATOM>
479 <==? <DATVAL .CINACS> <DATVAL .INAC>>>>)
480 (<TYPE? <DATTYP .CINACS> ATOM>
487 (<TWO-AC-EXCH .CINACS
493 <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
495 <DEFINE ONE-EXCH-AC (DEST-INAC CURR-INAC ACS CSYMT RET LPV
496 "AUX" (DEST-AC <DATVAL .DEST-INAC>)
498 <AND <NOT <AND .RET <ACLINK .DEST-AC>>>
499 <EMPTY? <NTH .ACS <ACNUM .DEST-AC>>>>))
500 #DECL ((DEST-INAC CURR-INAC) <DATUM ANY AC> (ACS) REP-STATE
502 <SEMIT <INSTRUCTION <COND (.NOEXCH `MOVE ) (ELSE `EXCH )>
503 <ACSYM <DATVAL .DEST-INAC>>
504 <ADDRSYM <DATVAL .CURR-INAC>>>>
505 <SWAP-INAC <DATVAL .CURR-INAC>
513 <DEFINE TWO-AC-EXCH (DEST-INAC CURR-INAC ACS CSYMT RET LPV
514 "AUX" (DTAC <DATTYP .DEST-INAC>)
515 (DVAC <DATVAL .DEST-INAC>)
517 <AND <NOT <AND .RET <ACLINK .DTAC>>>
518 <NTH .ACS <ACNUM .DTAC>>>)
520 <AND <NOT <AND .RET <ACLINK .DVAC>>>
521 <NTH .ACS <ACNUM .DVAC>>>))
522 #DECL ((DEST-INAC CURR-INAC) DATUM)
524 (<TYPE? <DATTYP .CURR-INAC> AC>
526 (<==? <DATTYP .CURR-INAC> .DTAC>
527 <ONE-EXCH-AC .DEST-INAC .CURR-INAC .ACS .CSYMT .RET .LPV>)
528 (<==? .DTAC <DATVAL .CURR-INAC>>
529 <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
531 <ADDRSYM <DATTYP .CURR-INAC>>>>
532 <SWAP-INAC <DATTYP .CURR-INAC>
539 <COND (<==? .DVAC <DATVAL .CURR-INAC>>)
541 <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
543 <ADDRSYM <DATVAL .CURR-INAC>>>>
544 <SWAP-INAC <DATVAL .CURR-INAC>
552 <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
554 <ADDRSYM <DATTYP .CURR-INAC>>>>
555 <SWAP-INAC <DATTYP .CURR-INAC>
562 <COND (<==? <DATVAL .DEST-INAC> <DATVAL .CURR-INAC>>)
564 <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
566 <ADDRSYM <DATVAL .CURR-INAC>>>>
567 <SWAP-INAC <DATVAL .CURR-INAC>
574 (<COND (<==? <DATVAL .CURR-INAC> .DVAC>)
576 <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
578 <ADDRSYM <DATVAL .CURR-INAC>>>>
579 <SWAP-INAC <DATVAL .CURR-INAC>
586 <SEMIT <INSTRUCTION `MOVE <ACSYM .DTAC> !<ADDR:TYPE .CURR-INAC>>>)>>
590 <DEFINE CURRENT-AC-STATE ("OPTIONAL" (RETPNOD <>) "AUX" (BST ()) PAC)
591 #DECL ((VALUE) REP-STATE)
592 <COND (.RETPNOD <SET BST <BINDING-STRUCTURE .RETPNOD>>)>
594 <FUNCTION (AC "AUX" (ACR <ACRESIDUE .AC>) (SACR ()))
598 (<AND <TYPE? .SYMT SYMTAB> <NOT <MEMQ .SYMT .BST>>>
602 <COND (<STORED .SYMT>
603 <OR <NOT <TYPE? <NUM-SYM .SYMT> LIST>>
604 <NOT <1 <NUM-SYM .SYMT>>>
605 <L? <LENGTH <NUM-SYM .SYMT>> 2>
606 <2 <NUM-SYM .SYMT>>>)>
607 <AND <SET PAC <PROG-AC .SYMT>>
608 <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>
615 <DEFINE LVAL-UP (SYMT "OPTIONAL" (PSLOT <PROG-AC .SYMT>) "AUX" PNAC)
616 #DECL ((SYMT) SYMTAB)
619 <SET PNAC <PROG-SLOT .PSLOT>>
620 <NOT <MEMQ .SYMT <LOOP-VARS .PNAC>>>>
624 (.SYMT <INACS-SLOT .PSLOT> !<LOOP-VARS .PNAC>)>
625 <COND (<STORED-SLOT .PSLOT>) (<KILL-STORE <NUM-SYM-SLOT .PSLOT>>)>
626 <COND (<NOT <POTLV .SYMT>> <PUT .SYMT ,STORED <>>)>
627 <REPEAT ((PTR <PROG-VARS .PNAC>))
629 <COND (<EMPTY? .PTR> <RETURN>)>
630 <COND (<==? .SYMT <SYM-SLOT .PTR>>
631 <LVAL-UP .SYMT <SAVED-PROG-AC-SLOT .PTR>>
633 <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>)
634 (ELSE <KILL-LOOP-AC .SYMT>)>)>>
638 <DEFINE STORE-SAVED-ACS (LPV ACS "AUX" CINAC)
639 #DECL ((LPV) LIST (ACS) REP-STATE)
641 <FUNCTION (ONE-ACS AC)
642 #DECL ((ONE-ACS) LIST)
643 <REPEAT ((PTR .ONE-ACS) SYMT)
644 #DECL ((PTR) LIST (SYMT) SYMBOL)
645 <COND (<EMPTY? .PTR> <RETURN>)
646 (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .PTR>> .LPV>>
647 <NOT <AND <TYPE? <DATTYP <SET CINAC <CINACS-SLOT .PTR>>>
649 <==? .AC <DATTYP .CINAC>>
650 <TYPE? <DATVAL .CINAC> AC>>>>
651 <SPEC-STOREV .SYMT .CINAC <CSTORED-SLOT .PTR>>
652 <PUT .PTR ,CSTORED-SLOT T>)>
653 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
657 <DEFINE AC? (SYMT ACS)
658 #DECL ((SYMT) SYMTAB (ACS) LIST)
664 <COND (<EMPTY? .PTR> <RETURN <>>)>
665 <COND (<==? <CSYMT-SLOT .PTR> .SYMT>
666 <MAPLEAVE <CINACS-SLOT .PTR>>)>
667 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
670 "THIS ROUTINE SWAPS PORTIONS OF DATUMS. IT TAKES TWO ACS AND THE ACS LIST AND SWAPS THE
671 INFORMATION IN THE ACS LIST. AC2 IS THE GOAL AC AND ENDS UP CONTAINING ONLY ONE DATUM."
673 <DEFINE SWAP-INAC (AC1 AC2 ACS SYMT RET NOEXCH LPV
674 "AUX" (NUM1 <ACNUM .AC1>) (NUM2 <ACNUM .AC2>) SWDAT1 SWDAT2
675 (ACL1 <ACLINK .AC1>) (ACL2 <ACLINK .AC2>) (PUTR ()))
676 #DECL ((AC1 AC2) AC (NUM1 NUM2) FIX (ACS) REP-STATE (RET) <OR ATOM FALSE>
678 <COND (<AND .RET <NOT .NOEXCH>>
679 <SWAP-DATUMS .ACL1 .AC1 .AC2>
680 <SWAP-DATUMS .ACL2 .AC2 .AC1>
681 <PUT .AC2 ,ACLINK .ACL1>
682 <PUT .AC1 ,ACLINK .ACL2>)>
683 <SET SWDAT1 <NTH .ACS .NUM1>>
684 <SET SWDAT2 <NTH .ACS .NUM2>>
685 <REPEAT ((PTR .SWDAT1) SUB-PTR)
687 <COND (<EMPTY? .PTR> <RETURN>)>
690 <SET SUB-PTR <MEMQ .AC1 <CINACS-SLOT .PTR>>>
693 <==? .SYMT <CSYMT-SLOT .PTR>>
694 <REPEAT ((S <CSYMT-SLOT .PTR>) (LP .LPV)
695 (DV <==? .AC1 <DATVAL <CINACS-SLOT .PTR>>>))
697 <COND (<EMPTY? .LP> <RETURN>)>
698 <COND (<==? <LSYM-SLOT .LP> .S>
699 <COND (.DV <RETURN <==? <DATVAL <LINACS-SLOT .LP>> .AC2>>)
701 <RETURN <==? <DATTYP <LINACS-SLOT .LP>> .AC2>>)>)>
702 <SET LP <REST .LP ,LOOPVARS-LENGTH>>>>>
703 <SET PUTR (.SUB-PTR .AC2 !.PUTR)>)>
704 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
706 <REPEAT ((PTR .SWDAT2) SUB-PTR)
708 <COND (<EMPTY? .PTR> <RETURN>)>
709 <COND (<SET SUB-PTR <MEMQ .AC2 <CINACS-SLOT .PTR>>>
710 <SET PUTR (.SUB-PTR .AC1 !.PUTR)>)>
711 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>)>
713 <COND (<EMPTY? .PUTR> <RETURN>)>
714 <PUT <1 .PUTR> 1 <2 .PUTR>>
715 <SET PUTR <REST .PUTR 2>>>
716 <COND (<NOT .NOEXCH> <PUT .ACS .NUM1 .SWDAT2>)>
717 <PUT .ACS .NUM2 .SWDAT1>>
719 <DEFINE SWAP-DATUMS (ACL ACOLD ACNEW)
720 #DECL ((ACL) <OR FALSE <LIST [REST DATUM]>>)
722 <FUNCTION (DAT "AUX" ACLTEM)
724 <COND (<SET ACLTEM <MEMQ .ACOLD .DAT>>
725 <PUT .ACLTEM 1 .ACNEW>)
726 (ELSE <MESSAGE INCONSISTENCY "BAD ACLINK">)>>
729 <DEFINE GET-ACS-FROM-STACK (LPV ACS)
730 #DECL ((LPV) LIST (ACS) REP-STATE)
731 <REPEAT ((LPVP .LPV) DAT DAT2)
732 #DECL ((LPVP) LIST (DAT) DATUM)
733 <COND (<EMPTY? .LPVP> <RETURN>)>
734 <COND (<LSYM-SLOT .LPVP>
735 <PUT <LSYM-SLOT .LPVP> ,INACS <>>
736 <SET DAT2 <LADDR <LSYM-SLOT .LPVP> <> <>>>
737 <SET DAT <LINACS-SLOT .LPVP>>
738 <COND (<TYPE? <DATTYP .DAT> AC>
741 <ACSYM <DATTYP .DAT>>
742 !<ADDR:TYPE .DAT2>>>)>
743 <SEMIT <INSTRUCTION `MOVE
744 <ACSYM <DATVAL .DAT>>
745 !<ADDR:VALUE .DAT2>>>)>
746 <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
750 <DEFINE NON-LOOP-CLEANUP (N "AUX" (B <BINDING-STRUCTURE .N>))
751 #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
753 <FUNCTION (S "AUX" (INA <INACS .S>))
756 <COND (<TYPE? <DATTYP .INA> AC>
757 <FLUSH-RESIDUE <DATTYP .INA> .S>)>
758 <COND (<TYPE? <DATVAL .INA> AC>
759 <FLUSH-RESIDUE <DATVAL .INA> .S>)>)>
764 "ROUTINES TO HANDLE LOOP-RETURNS."
766 <DEFINE LOOP-RETURN (RETINFO "AUX" LST)
767 #DECL ((LST RETINFO) LIST)
769 <FUNCTION (AC "AUX" ACR)
772 <COND (<SET ACR <ACRESIDUE .AC>>
774 <FUNCTION (IT) <SMASH-INACS .IT <> <>>>
776 <PUT .AC ,ACRESIDUE <>>>
778 <COND (<NOT <EMPTY? .RETINFO>>
779 <SET LST <MERGE-RETURNS .RETINFO>>
780 <REPEAT ((PTR .RETINFO))
782 <COND (<EMPTY? .PTR> <RETURN>)>
784 <SAVED-AC-STATE .PTR>
785 <SAVED-CODE:PTR .PTR>
787 <SAVED-STACK-STATE .PTR>>
788 <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>>
790 "ROUTINE TO FIGURE OUT A MERGE BETWEEN DIFFERENT RETURN POINTS. IN THE END A LIST OF
791 THINGS TO REMAIN IN AC'S ARE PRODUCED."
793 <DEFINE MERGE-RETURNS (RETINFO "AUX" (ACKEEP ()))
795 (RETINFO) <LIST [REST
800 <REPEAT ((CNT 1) MERGER)
802 <SET MERGER <LIST !<NTH <SAVED-AC-STATE .RETINFO> .CNT>>>
803 <COND (<NOT <EMPTY? .MERGER>>
804 <REPEAT ((PTR <REST .RETINFO ,LENGTH-CONTROL-STATE>))
805 <COND (<EMPTY? .PTR> <RETURN>)>
808 <NTH <SAVED-AC-STATE .PTR> .CNT>>>
809 <COND (<EMPTY? .MERGER> <RETURN>)>
810 <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>
811 <COND (<NOT <EMPTY? .MERGER>> <SET ACKEEP (!.MERGER !.ACKEEP)>)>
812 <COND (<G? <SET CNT <+ .CNT 1>> 5> <RETURN>)>>
815 "ROUTINE TO FIGURE OUT IF THINGS MERGE"
817 <DEFINE MERG-IT (CURR-STATE NEW-STATE
818 "AUX" (OLD-STATE .CURR-STATE) SPTR INAC1 INAC2)
819 #DECL ((CURR-STATE NEW-STATE) LIST)
820 <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .CURR-STATE> .NEW-STATE>>
821 <OR <=? <SET INAC1 <CINACS-SLOT .CURR-STATE>>
822 <SET INAC2 <CINACS-SLOT .SPTR>>>
823 <AND <==? <DATVAL .INAC1> <DATVAL .INAC2>>
824 <OR <AND <ISTYPE? <DATTYP .INAC1>>
825 <PUT .SPTR ,CINACS-SLOT .INAC1>>
826 <AND <ISTYPE? <DATTYP .INAC2>>
830 <COND (<AND <CSTORED-SLOT .CURR-STATE> <CSTORED-SLOT .SPTR>>)
831 (<PUT .CURR-STATE ,CSTORED-SLOT <>>
832 <PUT .SPTR ,CSTORED-SLOT <>>)>)
833 (<SET CURR-STATE <REST .CURR-STATE ,LENGTH-CSTATE>>)>
834 <REPEAT ((PTR .CURR-STATE))
836 <COND (<EMPTY? .PTR> <RETURN>)>
837 <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .PTR> .NEW-STATE>>
838 <=? <CINACS-SLOT .SPTR> <CINACS-SLOT .CURR-STATE>>>
839 <COND (<AND <CSTORED-SLOT .CURR-STATE>
840 <CSTORED-SLOT .SPTR>>)
841 (<PUT .CURR-STATE ,CSTORED-SLOT <>>
842 <PUT .SPTR ,CSTORED-SLOT <>>)>)
843 (ELSE ;"THIS ELSE USED TO B <CSTORED-STATE .CURR-STATE>"
844 <COND (<==? .PTR .CURR-STATE>
845 <SET OLD-STATE .CURR-STATE>
847 <REST .CURR-STATE ,LENGTH-CSTATE>>)
849 <PUTREST <REST .OLD-STATE <- ,LENGTH-CSTATE 1>>
850 <REST .PTR ,LENGTH-CSTATE>>
851 <SET PTR .OLD-STATE>)>)>
853 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
856 <DEFINE MERGE-SINGLE-RETURN (THISRETURN INS MERGEDRETURN STACK-INFO
858 #DECL ((INS THISRETURN MERGEDRETURN STACK-INFO) LIST
859 (MS) <LIST [REST SYMTAB]>)
860 <PROG ((SCODE:PTR .INS) (FRMS <SAVED-FRMS .STACK-INFO>)
861 (BSTB <SAVED-BSTB .STACK-INFO>) (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
862 (STK <SAVED-STK .STACK-INFO>))
863 #DECL ((FRMS BSTB NTSLOTS STK SCODE:PTR) <SPECIAL LIST>)
868 <COND (<EMPTY? .CP> <RETURN>)>
869 <COND (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .CP>>
871 <OR <==? .AC <DATVAL <CINACS-SLOT .CP>>>
872 <NOT <TYPE? <DATVAL <CINACS-SLOT .CP>> AC>>>>
873 <SPEC-STOREV .SYMT <CINACS-SLOT .CP> <CSTORED-SLOT .CP>>
874 <FLUSH-RESIDUE .AC .SYMT>
875 <SET MS (.SYMT !.MS)>)
876 (<MEMQ .SYMT .MS> <FLUSH-RESIDUE .AC .SYMT>)
878 <PUT .SYMT ,STORED <CSTORED-SLOT .CP>>
879 <SMASH-INACS .SYMT <CINACS-SLOT .CP>>
880 <SMASH-ITEM-INTO-DATUM .SYMT <CINACS-SLOT .CP>>)>
881 <SET CP <REST .CP ,LENGTH-CSTATE>>>>
885 <DEFINE SPEC-STOREV (SYMT INAC STORED)
886 <SMASH-INACS .SYMT .INAC>
887 <SMASH-ITEM-INTO-DATUM .SYMT .INAC>
888 <FLUSH-SYMTAB-FROM-AC .SYMT>
889 <COND (<TYPE? .SYMT SYMTAB>
893 <PROG ((CODE:TOP (())) (CODE:PTR .CODE:TOP))
894 #DECL ((CODE:TOP CODE:PTR) <SPECIAL LIST>)
895 <PUT .SYMT ,STORED <>>
898 <PUT .SYMT ,STORED T>)>
899 <SMASH-INACS .SYMT <>>>
901 <DEFINE CLEANUP-SYMT (SYM)
903 <PUT .SYM ,PROG-AC <>>
904 <PUT .SYM ,NUM-SYM T>>
907 #DECL ((SCODE:PTR CODE:PTR) LIST)
908 <PUTREST .SCODE:PTR (.FRM !<REST .SCODE:PTR>)>
909 <COND (<==? .CODE:PTR .SCODE:PTR> <SET CODE:PTR <REST .CODE:PTR>>)>
910 <SET SCODE:PTR <REST .SCODE:PTR>>>
914 <DEFINE FLUSH-SYMTAB-FROM-AC (SYMT "AUX" (INAC <SINACS .SYMT>) AC)
915 <COND (<TYPE? <SET AC <DATTYP .INAC>> AC>
916 <FLUSH-RESIDUE .AC .SYMT>)>
917 <COND (<TYPE? <SET AC <DATVAL .INAC>> AC>
918 <FLUSH-RESIDUE .AC .SYMT>)>>
920 <DEFINE SMASH-ITEM-INTO-DATUM (SYM DAT "AUX" AC)
921 #DECL ((SYM) SYMBOL (DAT) DATUM)
922 <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
923 <OR <MEMQ .SYM <ACRESIDUE .AC>>
924 <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>
925 <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
926 <OR <MEMQ .SYM <ACRESIDUE .AC>>
927 <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>>
930 <DEFINE CLEANUP-VARS (VARLST)
931 #DECL ((VARLST) LIST)
932 <REPEAT ((PTR .VARLST) VAR)
933 <COND (<EMPTY? .PTR> <RETURN>)>
934 <PUT <SET VAR <SYM-SLOT .PTR>>
936 <SAVED-NUM-SYM-SLOT .PTR>>
937 <PUT .VAR ,PROG-AC <SAVED-PROG-AC-SLOT .PTR>>
938 <PUT .VAR ,POTLV <SAVED-POTLV-SLOT .PTR>>
939 <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
941 <DEFINE FIXUP-STORES (STATE)
942 #DECL ((STATE) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
943 <REPEAT ((PTR .STATE))
944 #DECL ((PTR) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
945 <COND (<EMPTY? .PTR> <RETURN>)>
947 <FUNCTION (STATE-ITEMS "AUX" SYMT PAC (STATE-ITEM <1 .STATE-ITEMS>))
948 #DECL ((STATE-ITEMS) REP-STATE
950 <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>
951 (PAC) <OR FALSE LIST> (SYMT) SYMTAB)
953 <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
954 <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
955 <COND (<OR <CPOTLV-SLOT .STATE-ITEM>
956 <N==? <CSTORED-SLOT .STATE-ITEM> T>>
957 <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
958 <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
959 <AND <CPOTLV-SLOT .STATE-ITEM>
960 <CSTORED-SLOT .STATE-ITEM>
961 <SET PAC <PROG-AC .SYMT>>
962 <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
963 <NOT <STORED-SLOT .PAC>>>>
964 <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
965 <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
966 <OR <NOT <SET PAC <PROG-AC .SYMT>>>
967 <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
968 <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>)
971 (<NOT <EMPTY? .STATE-ITEM>>
972 <REPEAT ((START-STATE .STATE-ITEM)
973 (STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>))
974 <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
975 <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
977 (<OR <CPOTLV-SLOT .STATE-ITEM>
978 <N==? <CSTORED-SLOT .STATE-ITEM> T>>
979 <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
980 <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
981 <AND <CPOTLV-SLOT .STATE-ITEM>
982 <CSTORED-SLOT .STATE-ITEM>
983 <SET PAC <PROG-AC .SYMT>>
984 <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
985 <NOT <STORED-SLOT .PAC>>>>
986 <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
987 <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
988 <OR <NOT <SET PAC <PROG-AC .SYMT>>>
989 <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
990 <PUTREST .START-STATE <REST .STATE-ITEM ,LENGTH-CSTATE>>)>
991 <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>
992 <SET START-STATE <REST .START-STATE ,LENGTH-CSTATE>>>)>
993 <PUT .STATE-ITEMS 1 .STATE-ITEM>>
994 <SAVED-AC-STATE .PTR>>
995 <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>>