2 <GDECL (LOOKAHEAD?) <OR ATOM FALSE>>
18 <SETG EMPU '[EMPUV?!-MIMOP EMPUU?!-MIMOP EMPUS?!-MIMOP EMPUB?!-MIMOP]>
20 <SETG LENU '[LENUV!-MIMOP LENUU!-MIMOP LENUS!-MIMOP LENUB!-MIMOP]>
22 <SETG NTHU '[NTHUV!-MIMOP NTHUU!-MIMOP NTHUS!-MIMOP NTHUB!-MIMOP]>
24 <SETG PUTU '[PUTUV!-MIMOP PUTUU!-MIMOP PUTUS!-MIMOP PUTUB!-MIMOP]>
26 <SETG RESTU '[RESTUV!-MIMOP RESTUU!-MIMOP RESTUS!-MIMOP RESTUB!-MIMOP]>
28 <PUTPROP RESTUV!-MIMOP PUT-PAIR PUTUV!-MIMOP>
30 <PUTPROP PUTUV!-MIMOP PUT-PAIR RESTUV!-MIMOP>
32 <PUTPROP RESTUU!-MIMOP PUT-PAIR PUTUU!-MIMOP>
34 <PUTPROP PUTUU!-MIMOP PUT-PAIR RESTUU!-MIMOP>
36 <PUTPROP RESTUS!-MIMOP PUT-PAIR PUTUS!-MIMOP>
38 <PUTPROP PUTUS!-MIMOP PUT-PAIR RESTUS!-MIMOP>
40 <PUTPROP RESTUB!-MIMOP PUT-PAIR PUTUB!-MIMOP>
42 <PUTPROP PUTUB!-MIMOP PUT-PAIR RESTUB!-MIMOP>
44 <PUTPROP RESTUV!-MIMOP PAIR NTHUV!-MIMOP>
46 <PUTPROP NTHUV!-MIMOP PAIR RESTUV!-MIMOP>
48 <PUTPROP RESTUU!-MIMOP PAIR NTHUU!-MIMOP>
50 <PUTPROP NTHUU!-MIMOP PAIR RESTUU!-MIMOP>
52 <PUTPROP RESTUS!-MIMOP PAIR NTHUS!-MIMOP>
54 <PUTPROP NTHUS!-MIMOP PAIR RESTUS!-MIMOP>
56 <PUTPROP RESTUB!-MIMOP PAIR NTHUB!-MIMOP>
58 <PUTPROP NTHUB!-MIMOP PAIR RESTUB!-MIMOP>
60 <GDECL (ARITH NTHU PUTU RESTU LENU EMPU) <VECTOR [REST ATOM]>>
62 <NEWSTRUC OP-INFO (VECTOR)
64 OP-RES <OR ATOM VARTBL>
65 OP-HINT <OR LIST ATOM FALSE>
66 OP-BRANCH <OR ATOM FALSE>
69 <SETG OP-INFO [<IVECTOR 5 <>> T <> <> T]>
71 <DEFINE NTH-LOOK-AHEAD NLA (CINS STRUC1 OFF1 RES
72 "OPTIONAL" (HINT <>) (STYPE1 <>)
73 "AUX" (L .CODPTR) INCINS NXT (OP-INFO ,OP-INFO)
74 (ADDVAL 0) STRUC2 OFF2 (ELTYPE1 <>)
75 (ELTYPE2 <>) (EMPTY? <>)
76 (ARGVEC <OP-ARGS .OP-INFO>) (ARITH? <>)
77 (ILDB? <>) OL (IDPB? <>) NINS RES1 RES2
78 (RES1? <>) (RES2? <>) PINS (STYPE2 <>) AMT
79 CMPINS TMIML (NOPUT? <>))
80 #DECL ((CINS) ATOM (RES) <OR VARTBL ATOM> (NXT) <OR ATOM FORM>
81 (L) <SPECIAL <LIST [REST <OR ATOM FORM>]>> (OP-INFO) OP-INFO)
82 <COND (<NOT ,LOOKAHEAD?> <RETURN <> .NLA>)>
83 <COND (.STYPE1 <SET STYPE1 <PARSE-HINT .STYPE1 STRUCTURE-TYPE>>)
85 <COND (<==? .CINS NTHUV!-MIMOP> <SET STYPE1 VECTOR>)
86 (<==? .CINS NTHUU!-MIMOP> <SET STYPE1 UVECTOR>)
87 (<==? .CINS NTHUS!-MIMOP> <SET STYPE1 STRING>)
88 (<==? .CINS NTHUB!-MIMOP> <SET STYPE1 BYTES>)
89 (<==? .CINS NTHL!-MIMOP> <SET STYPE1 LIST>)>)>
90 <COND (<==? .CINS ILDB!-MIMOP> <SET ILDB? .OFF1> <SET OFF1 1>)>
92 (<AND <OR <MEMQ .CINS ,NTHU>
93 <==? .CINS ILDB!-MIMOP>
94 <==? .CINS NTHL!-MIMOP>>
97 <TYPE? .STRUC1 VARTBL>
99 <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
100 <COND (<OR <SET ARITH? <MEMQ <SET INCINS <1 .NXT>> ,ARITH>>
101 <MEMQ .INCINS ,RESTU>>
102 <AND <PARSE-OP .NXT .OP-INFO>
103 <==? <1 <OP-ARGS .OP-INFO>> .RES>
104 <==? <OP-RES .OP-INFO> .RES>
105 <SET ADDVAL <2 <OP-ARGS .OP-INFO>>>
106 <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>>)
107 (T <SET INCINS <>> T)>
109 <NOT <MEMQ .INCINS ,LOGIC>>
110 <NOT <MEMQ .STYPE1 '[STRING BYTES]>>>
111 <OR <MEMQ <SET PINS <1 .NXT>> ,PUTU>
112 <==? .PINS PUTL!-MIMOP>
113 <SET IDPB? <==? .PINS IDPB!-MIMOP>>
114 <COND (.ARITH? <SET PINS <>> <SET NOPUT? T> <SET STRUC2 .RES>)>>
115 ;"In case of CHTYPE here (for rest), will fall into
118 <PARSE-OP .NXT .OP-INFO>
119 <SET ARGVEC <OP-ARGS .OP-INFO>>
120 <COND (.IDPB? <==? <2 .ARGVEC> .RES>)
121 (<==? <3 .ARGVEC> .RES>)>)
124 <COND (<WILL-DIE? .RES .L>)
126 ; "Work for NTH ? ADD when NTH ? ADD ? PUT can't
127 because of life/death"
132 <COND (<NOT .NOPUT?> <SET STRUC2 <1 .ARGVEC>>) (T)>
133 <COND (.NOPUT? <PROTECT-VAL .STRUC2>)
134 (.IDPB? <SET STYPE2 <PARSE-HINT <OP-HINT .OP-INFO> STRUCTURE-TYPE>>)
135 (<==? .PINS PUTUV!-MIMOP> <SET STYPE2 VECTOR>)
136 (<==? .PINS PUTL!-MIMOP> <SET STYPE2 LIST>)
137 (<==? .PINS PUTUU!-MIMOP> <SET STYPE2 UVECTOR> <SET ELTYPE2 FIX>)
138 (<==? .PINS PUTUS!-MIMOP>
140 <SET ELTYPE2 CHARACTER>)
141 (<==? .PINS PUTUB!-MIMOP> <SET ELTYPE2 FIX> <SET STYPE2 BYTES>)>
142 <COND (.IDPB? <SET OFF2 1> <SET IDPB? <3 .ARGVEC>>)
145 <SET OFF2 <2 .ARGVEC>>
146 <COND (<OP-HINT .OP-INFO>
147 <SET ELTYPE2 <PARSE-HINT <OP-HINT .OP-INFO> TYPE>>)>)>
149 <COND (<TYPE? .HINT ATOM> <SET ELTYPE1 .HINT>)
150 (<SET ELTYPE1 <PARSE-HINT .HINT TYPE>>)>)
151 (<==? .STYPE1 BYTES> <SET ELTYPE1 FIX>)
152 (<==? .STYPE1 STRING> <SET ELTYPE1 CHARACTER>)
153 (<==? .STYPE1 UVECTOR> <SET ELTYPE1 FIX>)>
154 <COND (<AND <MEMQ .INCINS ,RESTU>
155 <OR <NOT .ELTYPE1> <NOT .ELTYPE2> <N==? .ELTYPE1 .ELTYPE2>>
156 <OR .ILDB? .IDPB? <N==? .STRUC1 .STRUC2> <N==? .OFF1 .OFF2>>>
158 (<NTH-AOS-PUT-GEN .CINS
164 <COND (<NOT .NOPUT?> .OFF2)>
170 <COND (<NOT .NOPUT?> .STYPE2)>
172 <COND (<NOT .NOPUT?> .ELTYPE2)>>
174 (<AND <SET L .CODPTR>
175 <OR <==? .CINS ILDB!-MIMOP>
177 <==? .CINS NTHL!-MIMOP>>
179 <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>>
181 (<AND <OR <MEMQ <1 .NXT> ,LENU>
183 <OR <==? <1 .NXT> EMPL?!-MIMOP> <MEMQ <1 .NXT> ,EMPU>>>>
184 <PARSE-OP .NXT .OP-INFO>
185 <==? <1 <SET ARGVEC <OP-ARGS .OP-INFO>>> .RES>
186 <OR <==? <1 .ARGVEC> <OP-RES .OP-INFO>>
187 <AND <WILL-DIE? .RES .L>
190 "If empty?, make sure <3 .x> isn't used after
191 the branch. WILL-DIE? on .L won't find this,
192 because L has already been rested past the branch."
193 <AND <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>
194 <WILL-DIE? .RES .TMIML>>>>>>
195 ;"Have <length <3 .x>> or <empty? <3 .x>>"
198 <FLUSH-TO .L .CODPTR>
199 <NTH-LENGTH-COMP-GEN .CINS
208 <SET ADDVAL <OP-RES .OP-INFO>>
209 <COND (<AND <G? <LENGTH .L> 2>
210 <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
212 '[LESS?!-MIMOP GRTR?!-MIMOP VEQUAL?!-MIMOP]>
213 <PARSE-OP .NXT .OP-INFO>
215 <1 <SET ARGVEC <OP-ARGS .OP-INFO>>>>
216 <SET CMPINS <1 .NXT>>
217 <SET AMT <2 .ARGVEC>>)
218 (<==? .ADDVAL <2 .ARGVEC>>
219 <SET AMT <1 .ARGVEC>>
220 <COND (<==? <SET CMPINS <1 .NXT>>
222 <SET CMPINS GRTR?!-MIMOP>)
223 (<==? .CMPINS GRTR?!-MIMOP>
224 <SET CMPINS LESS?!-MIMOP>)
226 <WILL-DIE? .ADDVAL <REST .L>>>
227 ;"Have length comparison of nth.."
228 <FLUSH-TO .L .CODPTR>
229 <NTH-LENGTH-COMP-GEN .CINS
238 <FLUSH-TO .OL .CODPTR>
239 <NTH-LENGTH-GEN .CINS .STRUC1 .OFF1 .STYPE1 .ADDVAL>
241 (<AND <OR <==? <SET NINS <1 .NXT>> ILDB!-MIMOP>
243 <==? .NINS NTHL!-MIMOP>>
244 <NOT <EMPTY? <REST .L>>>
245 <PARSE-OP .NXT .OP-INFO>
246 <COND (<==? .NINS ILDB!-MIMOP>
247 <SET STYPE2 <PARSE-HINT <OP-HINT .OP-INFO> STRUCTURE-TYPE>>)
248 (<==? .NINS NTHL!-MIMOP> <SET STYPE2 LIST>)
250 <2 <MEMBER <REST <SPNAME .NINS> 3>
259 <SET STRUC2 <1 <SET ARGVEC <OP-ARGS .OP-INFO>>>>
260 <OR <==? .STYPE1 .STYPE2>
261 <AND <MEMQ .STYPE1 '[VECTOR UVECTOR LIST]>
262 <MEMQ .STYPE2 '[VECTOR UVECTOR LIST]>>
263 <AND <MEMQ .STYPE1 '[STRING BYTES]>
264 <MEMQ .STYPE2 '[STRING BYTES]>>>
265 <SET OFF2 <2 .ARGVEC>>
266 <SET RES2 <OP-RES .OP-INFO>>
267 <WILL-DIE? .RES2 <REST .L>>
268 <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
269 <MEMQ <1 .NXT> '[LESS?!-MIMOP GRTR?!-MIMOP VEQUAL?!-MIMOP]>
270 <OR <MEMQ .RES .NXT> <MEMQ .RES2 .NXT>>>
271 <PARSE-OP .NXT .OP-INFO>
272 <COND (<OR <NOT <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>>
273 <NOT <WILL-DIE? .RES2 .TMIML>>>
274 ;"See comment above for EMPTY?"
276 <FLUSH-TO .L .CODPTR>
277 <SLOT-COMPARE <COND (<==? <1 .ARGVEC> .RES> <SET RES1? 1> .STRUC1)
278 (<==? <1 .ARGVEC> .RES2> <SET RES2? 1> .STRUC2)
280 <COND (<==? <2 .ARGVEC> .RES> <SET RES1? 2> .STRUC1)
281 (<==? <2 .ARGVEC> .RES2> <SET RES2? 2> .STRUC2)
285 <COND (<==? .RES1? 1> .OFF1) (<==? .RES2? 1> .OFF2)>
286 <COND (<==? .RES1? 1> .STYPE1) (<==? .RES2? 1> .STYPE2)>
287 <COND (<==? .RES1? 2> .OFF1) (<==? .RES2? 2> .OFF2)>
288 <COND (<==? .RES1? 2> .STYPE1) (<==? .RES2? 2> .STYPE2)>>
290 (<AND <MEMQ <1 .NXT> '[GRTR?!-MIMOP LESS?!-MIMOP VEQUAL?!-MIMOP]>
291 <PARSE-OP .NXT .OP-INFO>
292 <OR <==? <1 .ARGVEC> .RES> <==? <2 .ARGVEC> .RES>>
293 <AND <WILL-DIE? .RES .L>
294 <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>
295 <WILL-DIE? .RES .TMIML>>>
296 <COND (<==? <1 .ARGVEC> .RES> <SET RES1? T>)
297 (<==? <2 .ARGVEC> .RES> <SET RES2? T>)>
298 <FLUSH-TO .L .CODPTR>
299 <SLOT-COMPARE <COND (.RES1? .STRUC1) (<1 .ARGVEC>)>
300 <COND (.RES2? .STRUC1) (<2 .ARGVEC>)>
303 <COND (.RES1? .OFF1)>
304 <COND (.RES1? .STYPE1)>
305 <COND (.RES2? .OFF1)>
306 <COND (.RES2? .STYPE1)>>
307 CONDITIONAL-BRANCH)>)>>
309 <DEFINE FLUSH-TO (NL OL)
311 <SETG FLUSH-NEXT <- <LENGTH .OL> <LENGTH .NL>>>>
313 <DEFINE GET-NEXT-INST (LL)
316 <COND (<NOT <GETPROP <SET FROB <1 .LL>> DONE>>
319 <COND (<EMPTY? <SET LL <REST .LL>>> <RETURN <>>)>>>
321 <DEFINE PARSE-OP (FRM OP-INFO
322 "AUX" (ARGVEC <OP-ARGS .OP-INFO>) (RES? <>) HINT
324 #DECL ((FRM) FORM (OP-INFO) OP-INFO)
325 <OP-HINT .OP-INFO <>>
326 <OP-BRANCH .OP-INFO <>>
330 <COND (<OR <NOT <TYPE? .X LIST>> <EMPTY? .X>>
331 <COND (.RES? <SET RES? <>> <OP-RES .OP-INFO .X>)
334 <OP-BRANCH .OP-INFO .X>)
335 (<OR <==? .X -> <==? .X +>>
338 (<TYPE? .X RES-IND> <SET RES? T>)
342 <SET ARGVEC <REST .ARGVEC>>)>)
343 (<OR <==? <1 .X> TYPE> <==? <1 .X> STRUCTURE-TYPE>>
344 <OP-HINT .OP-INFO .X>)
345 (<==? <1 .X> BRANCH-FALSE>
346 <OP-BRANCH .OP-INFO <2 .X>>
348 (<==? <1 .X> BRANCH-TRUE>
349 <OP-BRANCH .OP-INFO <2 .X>>
350 <OP-DIR .OP-INFO +>)>>
354 <DEFINE WILL-DIE? (ARG
355 "OPT" (MIML .CODPTR) (BEG-LABEL T) "AUX" FOO (CP .CODPTR)
358 <COND (<==? .CP .MIML> ,FLUSH-NEXT)
360 <- <LENGTH .CP> <LENGTH .MIML>>>)>))
361 #DECL ((BEG-LABEL) ATOM (ARG) ANY (MIML) LIST (N) FIX)
364 <REPEAT LEAVE (NXT ITM JMP?)
365 #DECL ((NXT) <OR ATOM FORM LIST>)
367 (<EMPTY? .MIML> <RETURN T>)
368 (<AND <L=? <LENGTH .MIML> 1>
369 <OR <NOT <TYPE? <SET ITM <1 .MIML>> FORM>>
370 <AND <N==? <1 .ITM> JUMP!-MIMOP>
372 <NOT <MEMQ - .ITM>>>>>
373 <COND (<AND <TYPE? .ITM FORM>
374 <==? <1 .ITM> RETURN!-MIMOP>
379 (<TYPE? <SET NXT <1 .MIML>> ATOM>
380 <SET LR <GET-LREF .NXT T>>
381 <COND (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>> <RETURN <>>)
382 (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>> <RETURN T>)>
383 <COND (<WILL-DIE? .ARG <REST .MIML> .NXT>
384 <LABEL-REF-DEAD-VARS .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>
387 <LABEL-REF-LIVE-VARS .LR (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
389 (<AND <TYPE? .NXT FORM>
390 <L? <SET N <- .N 1>> 0>
391 <NOT <GETPROP .NXT DONE>>>
392 <COND (<==? <SET ITM <1 .NXT>> DEAD!-MIMOP>
393 <COND (<MEMQ .ARG <REST .NXT>>
394 ; "Definitely dies if DEADed"
396 (<==? .ITM RETURN!-MIMOP>
397 ; "Dies if not returned"
398 <RETURN <N==? <2 .NXT> .ARG>>)
399 (<==? .ITM END!-MIMOP>
400 ; "Dies if run out of code"
402 (<==? .ITM SET!-MIMOP>
403 <COND (<==? <2 .NXT> .ARG>
407 ; "Doesn't die if something set to this"
409 (<AND <==? .ITM SETLR!-MIMOP>
411 ; "If doing SETLR, current value is dead"
415 (<==? .ITM JUMP!-MIMOP> <SET JMP? T>)
417 ; "Unconditional jump is special case, slightly"
419 <FUNCTION (XP "AUX" (X <1 .XP>))
420 <COND (<TYPE? .X RES-IND>
421 <COND (<==? <SET X <2 .XP>> .ARG>
422 ; "Result of something, so dead"
426 ; "Arg to something, so not dead"
427 <RETURN <> .LEAVE>)>>
429 <COND (<==? .ITM DISPATCH!-MIMOP>
432 <COND (<==? .LAB .BEG-LABEL>)
433 (<SET FOO <MEMQ .LAB .MIML>>
434 <SET LR <GET-LREF .LAB T>>
435 <COND (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>>
437 (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>>)
438 (<WILL-DIE? .ARG <REST .FOO>>
440 .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>)
442 <LABEL-REF-LIVE-VARS .LR
443 (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
444 <RETURN <> .LEAVE>)>)
446 <RETURN <> .LEAVE>)>>
448 (<OR <AND <==? .ITM ICALL!-MIMOP>
450 <SET FOO <MEMQ + <SET NXT <REST .NXT>>>>
451 <SET FOO <MEMQ - .NXT>>
452 <AND <==? .ITM NTHR!-MIMOP>
453 <TYPE? <SET ITM <NTH .NXT <LENGTH .NXT>>> LIST>
454 <==? <1 .ITM> BRANCH-FALSE>
455 <SET FOO <REST .ITM>>>>
457 <COND (<SET FOO <MEMQ <SET LABEL <2 .FOO>> .MIML>>
458 ; "Hair to remember who's alive/dead at each place"
459 <SET LR <GET-LREF .LABEL T>>
460 <COND (<==? .LABEL .BEG-LABEL>
461 ; "If you hit a jump to the label where you
462 started, and you don't know the variable
463 is alive, then the jump won't make it live
464 either. If the jump is unconditional,
465 the variable is dead."
466 <COND (.JMP? <RETURN T>)>)
467 (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>>
469 (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>>
470 <COND (.JMP? <RETURN T>)>)
471 (<WILL-DIE? .ARG <REST .FOO>>
473 .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>
474 ; "If dies at branch loc, might die here"
476 ; "Unconditional jump, definitely dead"
480 .LR (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
483 ; "Lose, so not dead"
485 <SET MIML <REST .MIML>>>)>>
489 <DEFINE NTH-AOS-PUT-GEN NG
490 (NTHINS INCINS PUTINS STRUC1 OFFSET1 STRUC2 OFFSET2 AMOUNT CODELIST
491 ILDB? IDPB? STYPE1 STYPE2 ELTYPE1 ELTYPE2
492 "AUX" SAC1 SAC2 (ADDRTUP1 <ITUPLE 4 <>>) (ADDRTUP2 <ITUPLE 4 <>>)
494 #DECL ((NTHINS) ATOM (INCINS) <OR ATOM FALSE> (STRUC) VARTBL)
496 <AND <==? .STRUC1 .STRUC2>
497 <==? .OFFSET1 .OFFSET2>
500 <COND (<OR <AND .OFFSET2
503 <OR <AND .ILDB? <==? .STYPE1 VECTOR>>
504 <AND .IDPB? <==? .STYPE2 VECTOR>>
505 <AND <MEMQ .STYPE1 '[VECTOR LIST UVECTOR]>
506 <NOT <MEMQ .STYPE2 '[VECTOR LIST UVECTOR]>>>
507 <AND <MEMQ .STYPE2 '[VECTOR LIST UVECTOR]>
508 <NOT <MEMQ .STYPE1 '[VECTOR
513 <NOT <OR <==? .STYPE1 .STYPE2>
514 <AND <MEMQ .STYPE1 '[STRING BYTES UVECTOR]>
516 '[STRING BYTES UVECTOR]>>>>>
517 <AND .ILDB? <NOT <TYPE? .OFFSET2 FIX>>>
518 <AND .IDPB? <NOT <TYPE? .OFFSET1 FIX>>>>
520 "When we're dealing with the first element of a vector
521 via ILDB/IDPB, might as well not try anything fancy here."
523 <COND (.PUTINS <FLUSH-TO .CODELIST .CODPTR>)
525 <FLUSH-TO <REST .CODPTR
526 <- <LENGTH .CODPTR> <LENGTH .CODELIST> 1>>
528 <COND (<NOT <SET SAC1 <VAR-VALUE-IN-AC? .STRUC1>>>
529 <SET SAC1 <LOAD-VAR .STRUC1 VALUE <> PREF-VAL>>)>
531 <COND (<AND .PUTINS <NOT .SELF?>>
532 <COND (<AND <==? .STRUC1 .STRUC2> <N==? .STYPE1 LIST>>
534 (<NOT <SET SAC2 <VAR-VALUE-IN-AC? .STRUC2>>>
535 <SET SAC2 <LOAD-VAR .STRUC2 VALUE <> PREF-VAL>>
536 <PROTECT-USE .SAC2>)>)>
538 "Struc1 is now in sac1, appropriately rested; struc2 is in sac2,
539 also rested. (Two may be same, if struc1==struc2 and not rested"
548 <COND (<AND .PUTINS <NOT .SELF?>>
549 <COND (<AND <3 .ADDRTUP1>
550 <==? .OFFSET1 .OFFSET2>
551 <OR <AND <==? .STYPE1 VECTOR> <==? .STYPE2 VECTOR>>
552 <AND <N==? .STYPE1 VECTOR>
553 <N==? .STYPE2 VECTOR>>>>
578 (<MEMQ .INCINS ,ARITH>
582 <COND (.PUTINS <1 .ADDRTUP2>) (T .STRUC2)>
591 WORD> ;"Decrement count on length"
592 <COND (<TYPE? .AMOUNT FIX>
594 <COND (<==? .INCINS RESTUV!-MIMOP>
595 <MA-IMM <* 8 .AMOUNT>>)
596 (<==? .INCINS RESTUU!-MIMOP>
597 <MA-IMM <* 4 .AMOUNT>>)
604 <COND (<OR <==? .INCINS RESTUS!-MIMOP>
605 <==? .INCINS RESTUB!-MIMOP>>
606 <SET TMPAC <VAR-VALUE-ADDRESS .AMOUNT>>)
607 (<SET TMPAC <VAR-VALUE-IN-AC? .AMOUNT>>
609 <SET TMPAC <MA-REG .TMPAC>>
611 <COND (<==? .INCINS RESTUV!-MIMOP>
617 <SET TMPAC <GET-AC PREF-VAL>>
619 <COND (<==? .INCINS RESTUV!-MIMOP>
622 <VAR-VALUE-ADDRESS .AMOUNT>
623 <SET TMPAC <MA-REG .TMPAC>>>)>
630 <COND (.ILDB? <REST-BLOCK-GEN .STRUC1 1 .ILDB? 0 .STYPE1 T>)>
631 <COND (.IDPB? <REST-BLOCK-GEN .STRUC2 1 .IDPB? 0 .STYPE2 T>)>
634 <DEFINE MOVE-ELT (TUP1 TUP2 ST1 ST2 EL1 EL2 IDPB? "AUX" INS ADDR1 ADDR2)
635 #DECL ((TUP1 TUP2) TUPLE (ST1 ST2 EL1 EL2) <OR ATOM FALSE>)
636 <COND (<AND <MEMQ .ST1 '[VECTOR LIST]> <MEMQ .ST2 '[VECTOR LIST]>>
638 <SET ADDR1 <4 .TUP1>>
639 <SET ADDR2 <4 .TUP2>>)
641 <SET ADDR1 <1 .TUP1>>
642 <SET ADDR2 <1 .TUP2>>
643 <COND (<MEMQ .ST1 '[VECTOR LIST]>
644 <COND (<==? .ST2 UVECTOR>
646 <SET INS ,INST-MOVL>)
647 (<MEMQ .ST2 '[STRING BYTES]>
648 <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
650 <SET INS ,INST-CVTLB>)>)
654 <EMIT ,INST-MOVL <TYPE-WORD FIX> !.ADDR2>)>
655 <COND (<MEMQ .ST2 '[VECTOR LIST UVECTOR]>
657 <SET INS ,INST-MOVL>)
659 <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
661 <SET INS ,INST-CVTLB>)>)
665 <EMIT ,INST-MOVL <TYPE-WORD FIX> !.ADDR2>)>
666 <COND (<MEMQ .ST2 '[VECTOR UVECTOR LIST]>
667 <COND (<==? .ST2 UVECTOR> <SET EL2 FIX>)>
668 <SET INS ,INST-MOVZBL>)
670 <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
672 <SET INS ,INST-MOVB>)>)>)>
673 <EMIT .INS !.ADDR1 !.ADDR2>
675 <COND (.EL1 <EMIT ,INST-MOVW <TYPE-WORD .EL1> !<2 .TUP2>>)>)>>
677 <DEFINE DO-ARITH (INS AMOUNT ADDR1 ADDR2 SELF? STYPE1 "AUX" (VAC <>) RAC)
678 <COND (.SELF? <SET ADDR2 .ADDR1>)>
679 <COND (<TYPE? .ADDR2 VARTBL>
680 <COND (<NOT <SET RAC <VAR-VALUE-IN-AC? .ADDR2>>>
681 <SET RAC <GET-AC PREF-VAL T>>
683 <DEST-DECL .RAC .ADDR2 <COND (<MEMQ .INS ,FLOATS> FLOAT)
687 <COND (<TYPE? .AMOUNT FIX>
688 <COND (<==? .INS EQV!-MIMOP>
689 <SET AMOUNT <CHTYPE <XORB .AMOUNT -1> FIX>>
690 <SET INS XOR!-MIMOP>)
691 (<==? .INS AND!-MIMOP>
692 <SET AMOUNT <CHTYPE <XORB .AMOUNT -1> FIX>>)>)
693 (<OR <==? .INS EQV!-MIMOP> <==? .INS AND!-MIMOP>>
694 <EMIT ,INST-MCOML !.ADDR1 <SET VAC <GET-AC PREF-VAL T>>>
695 <COND (<==? .INS EQV!-MIMOP> <SET INS XOR!-MIMOP>)>)>
697 <COND (<TYPE? .ADDR2 VARTBL>
698 <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
699 (<==? .INS XOR!-MIMOP> ,INST-XORL3)
700 (<==? .INS OR!-MIMOP> ,INST-BISL3)>
702 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
703 (<VAR-VALUE-ADDRESS .AMOUNT>)>
706 <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
707 (<==? .INS XOR!-MIMOP> ,INST-XORL3)
708 (<==? .INS OR!-MIMOP> ,INST-BISL3)>
710 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
711 (<VAR-VALUE-ADDRESS .AMOUNT>)>
714 <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL2)
715 (<==? .INS XOR!-MIMOP> ,INST-XORL2)
716 (<==? .INS OR!-MIMOP> ,INST-BISL2)>
717 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
718 (<VAR-VALUE-ADDRESS .AMOUNT>)>
721 <COND (<TYPE? .ADDR2 VARTBL>
722 <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
723 (<==? .INS XOR!-MIMOP> ,INST-XORL3)
724 (<==? .INS OR!-MIMOP> ,INST-BISL3)>
726 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
727 (<VAR-VALUE-ADDRESS .AMOUNT>)>
730 <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
731 (<==? .INS XOR!-MIMOP> ,INST-XORL3)
732 (<==? .INS OR!-MIMOP> ,INST-BISL3)>
734 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
735 (<VAR-VALUE-ADDRESS .AMOUNT>)>
737 (<AND .SELF? <==? .AMOUNT 1>> <EMIT <PICK-ARITH .INS .STYPE1 1> !.ADDR1>)
739 <EMIT <PICK-ARITH .INS .STYPE1 2>
740 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
741 (<TYPE? .AMOUNT FLOAT> <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
742 (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
746 <COND (<TYPE? .ADDR2 VARTBL>
747 <EMIT <PICK-ARITH .INS .STYPE1 3>
748 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
749 (<TYPE? .AMOUNT FLOAT>
750 <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
751 (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
754 <VAR-VALUE-ADDRESS .ADDR2>>)
756 <EMIT <PICK-ARITH .INS .STYPE1 3>
757 <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
758 (<TYPE? .AMOUNT FLOAT>
759 <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
760 (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
766 [[,INST-INCB ,INST-INCW ,INST-INCL]
767 [,INST-ADDB2 ,INST-ADDW2 ,INST-ADDL2]
768 [,INST-ADDB3 ,INST-ADDW3 ,INST-ADDL3]]>
771 [[,INST-DECB ,INST-DECW ,INST-DECL]
772 [,INST-SUBB2 ,INST-SUBW2 ,INST-SUBL2]
773 [,INST-SUBB3 ,INST-SUBW3 ,INST-SUBL3]]>
777 [,INST-MULB2 ,INST-MULW2 ,INST-MULL2]
778 [,INST-MULB3 ,INST-MULW3 ,INST-MULL3]]>
782 [,INST-DIVB2 ,INST-DIVW2 ,INST-DIVL2]
783 [,INST-DIVB3 ,INST-DIVW3 ,INST-DIVL3]]>
787 [,INST-ADDF2 ,INST-SUBF2 ,INST-MULF2 ,INST-DIVF2]
788 [,INST-ADDF3 ,INST-SUBF3 ,INST-MULF3 ,INST-DIVF3]]>
790 <GDECL (LOGIC) VECTOR (FLOAT-OPS ADDS SUBS MULS DIVS) <VECTOR [REST VECTOR]>>
792 <SETG LOGIC '[AND!-MIMOP OR!-MIMOP XOR!-MIMOP EQV!-MIMOP]>
794 <SETG FLOATS '[ADDF!-MIMOP SUBF!-MIMOP MULF!-MIMOP DIVF!-MIMOP]>
796 <DEFINE PICK-ARITH (OP STYPE NUMOPS "AUX" TV)
797 #DECL ((NUMOPS) FIX (OP) ATOM (STYPE) ATOM (TV) VECTOR)
798 <COND (<==? .OP ADD!-MIMOP> <SET TV <NTH ,ADDS .NUMOPS>>)
799 (<==? .OP SUB!-MIMOP> <SET TV <NTH ,SUBS .NUMOPS>>)
800 (<==? .OP MUL!-MIMOP> <SET TV <NTH ,MULS .NUMOPS>>)
801 (<==? .OP DIV!-MIMOP> <SET TV <NTH ,DIVS .NUMOPS>>)
803 <SET TV <NTH ,FLOAT-OPS .NUMOPS>>)>
804 <COND (<MEMQ .OP ,FLOATS>
805 <COND (<==? .OP ADDF!-MIMOP> <1 .TV>)
806 (<==? .OP SUBF!-MIMOP> <2 .TV>)
807 (<==? .OP MULF!-MIMOP> <3 .TV>)
808 (<==? .OP DIVF!-MIMOP> <4 .TV>)>)
809 (<MEMQ .STYPE '[VECTOR UVECTOR LIST]> <3 .TV>)
810 (<==? .STYPE WORD> <2 .TV>)
813 <DEFINE GET-ADDR (TUP STRUC SAC OFFSET STYPE AINC?
814 "OPTIONAL" (RIDXAC <>) (FULL? <>)
816 #DECL ((TUP) <TUPLE [3 ANY]> (SAC) AC (OFFSET) <OR FIX VARTBL>
818 <COND (<AND <==? .STYPE LIST> <N==? .OFFSET 1>>
819 <COND (<TYPE? .OFFSET FIX>
820 <SET SAC <LIST-REST-CONSTANT-GEN .STRUC <- .OFFSET 1>>>)
821 (<SET SAC <LIST-REST-VAR-GEN .STRUC .OFFSET NTH>>)>
823 <COND (.AINC? <1 .TUP (<MA-AINC .SAC>)>)
826 <COND (<OR <==? .STYPE VECTOR> <==? .STYPE LIST>>
827 <4 .TUP (<MA-REGD .SAC>)>
828 <2 .TUP (<MA-DISP .SAC 2>)>
829 <1 .TUP (<MA-DISP .SAC 4>)>)
830 (<1 .TUP (<MA-REGD .SAC>)>)>)
832 <COND (<==? .STYPE VECTOR>
833 <4 .TUP (<MA-DISP .SAC <* 8 <- .OFFSET 1>>>)>
835 (<MA-DISP .SAC <+ 2 <* 8 <- .OFFSET 1>>>>)>
837 (<MA-DISP .SAC <+ 4 <* 8 <- .OFFSET 1>>>>)>)
838 (<==? .STYPE UVECTOR>
839 <1 .TUP (<MA-DISP .SAC <* 4 <- .OFFSET 1>>>)>)
840 (T <1 .TUP (<MA-DISP .SAC <- .OFFSET 1>>)>)>)>)
842 <COND (<AND <NOT .RIDXAC>
843 <NOT <SET IDXAC <VAR-VALUE-IN-AC? .OFFSET>>>>
844 <COND (<OR <N==? .STYPE VECTOR> .FULL?>
845 <SET IDXAC <LOAD-VAR .OFFSET VALUE <> PREF-VAL>>)
847 <SET IDXAC <GET-AC PREF-VAL>>
850 <VAR-VALUE-ADDRESS .OFFSET>
854 (<AND <NOT .RIDXAC> <NOT .FULL?> <==? .STYPE VECTOR>>
861 <COND (<==? .STYPE VECTOR>
862 <4 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -8>)>
863 <2 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -6>)>
864 <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -4>)>)
865 (<==? .STYPE UVECTOR>
866 <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -4>)>)
867 (T <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -1>)>)>)>>
871 <DEFINE ILDB-LOOKAHEAD (L)
872 #DECL ((L) <LIST [REST <OR ATOM FORM>]>)
876 <FUNCTION (LL "AUX" (FROB <1 .LL>) INS (REST? <>) (PUT? <>) NINS)
877 <COND (<AND <TYPE? .FROB FORM> <NOT <GETPROP .FROB DONE>>>
878 <COND (<==? <SET INS <1 .FROB>> SETLR!-MIMOP>
879 <COND (<AND <NOT <EMPTY? <REST .LL>>>
880 <TYPE? <SET NINS <2 .LL>> FORM>
881 <==? <1 .NINS> PUSH!-MIMOP>
882 <==? <2 .NINS> <2 .FROB>>
883 <WILL-DIE? <2 .FROB> <REST .LL 2>>>
885 <PUTPROP .NINS DONE T>)>)
886 (<AND <OR <SET REST? <MEMQ .INS ,RESTU>>
887 <SET PUT? <MEMQ .INS ,PUTU>>
890 ;"This could be something interesting"
891 <ILDB-LOOKAHEAD-ONE .LL .REST? .PUT?>)>)>>
895 "Find ILDB/IDPB case, put MIMA code for it into list, kill other half of
896 operation. Form of ops is:
897 <ILDB STRUC NTHRES RESTRES (STRUCTURE-TYPE FOO)>
898 <IDPB STRUC NEWVAL RESTRES (STRUCTURE-TYPE FOO)>"
900 <DEFINE ILDB-LOOKAHEAD-ONE (L REST? PUT?
901 "AUX" (OP-INFO ,OP-INFO)
902 (ARGVEC <OP-ARGS .OP-INFO>) STRUC RES OP
904 #DECL ((L) <LIST [REST <OR ATOM FORM>]> (OP-INFO) OP-INFO)
905 <PARSE-OP <1 .L> .OP-INFO>
907 <SET OTHOP <GETPROP .OP PAIR>>
908 <SET PUTOP <GETPROP .OP PUT-PAIR>>
909 <SET STRUC <1 .ARGVEC>>
910 <SET RES <OP-RES .OP-INFO>>
912 <FUNCTION (LL "AUX" (FROB <1 .LL>) INS HINT)
913 <COND (<TYPE? .FROB ATOM> <MAPLEAVE>)>
914 <COND (<AND <OR <==? <1 .FROB> .OTHOP>
915 <AND <OR .PUT? .REST?> <==? <1 .FROB> .PUTOP>>>
916 <==? <2 .FROB> .STRUC>
917 <==? <3 .FROB> 1>> ;"We now have the paired guy"
918 <COND (<MEMQ .OP ,RESTU> <SET HINT <REST <SPNAME .OP> 4>>)
919 (<SET HINT <REST <SPNAME .OP> 3>>)>
920 <COND (<=? .HINT "UV"> <SET HINT '(STRUCTURE-TYPE VECTOR)>)
921 (<=? .HINT "UU"> <SET HINT '(STRUCTURE-TYPE
923 (<=? .HINT "US"> <SET HINT '(STRUCTURE-TYPE STRING)>)
924 (T <SET HINT '(STRUCTURE-TYPE BYTES)>)>
925 <PARSE-OP .FROB .OP-INFO>
926 <COND (<OR .PUT? <MEMQ <1 .FROB> ,PUTU>>
930 <COND (.PUT? <4 <1 .L>>) (<3 .ARGVEC>)>
931 <COND (.PUT? <OP-RES .OP-INFO>) (.RES)>
933 <PUTPROP .FROB DONE T>)
937 <COND (.REST? <OP-RES .OP-INFO>) (.RES)>
938 <COND (.REST? .RES) (<OP-RES .OP-INFO>)>
940 <PUTPROP .FROB DONE T>)>
942 (<OR <MEMQ .STRUC .FROB>
945 <AND <PARSE-OP .FROB .OP-INFO> <OP-BRANCH .OP-INFO>>>
949 "Generate ILDB/IDPB-like stuff. Call with NTH/PUT inst, structure,
950 result of nth/put, result of rest, flag, new value for put"
952 <DEFINE IDPB-GEN (STRUC ELVAL STRES HINT)
953 <ILDB-GEN .STRUC .ELVAL .STRES .HINT T>>
955 <DEFINE ILDB-GEN IG (STRUC ELVAL STRES HINT
957 "AUX" EHINT VINS STRAC ELAC (ELTAC <>) (DOUBLE? <>) LVAR
958 TAC VAC ELADDR (NO-TYPE? <>))
959 #DECL ((STRUC) VARTBL (ELVAL) ANY)
960 <COND (<AND <TYPE? .ELVAL ATOM VARTBL>
961 <NTH-LOOK-AHEAD ILDB!-MIMOP .STRUC .STRES .ELVAL <> .HINT>>
962 <RETURN NORMAL .IG>)>
963 <SET HINT <PARSE-HINT .HINT STRUCTURE-TYPE>>
964 <COND (<==? .HINT VECTOR>
966 <SET VINS ,INST-MOVQ>
968 (<==? .HINT UVECTOR> <SET VINS ,INST-MOVL> <SET EHINT FIX>)
971 <COND (.PUT? <SET VINS ,INST-MOVB>) (<SET VINS ,INST-MOVZBL>)>)
973 <SET EHINT CHARACTER>
974 <COND (.PUT? <SET VINS ,INST-MOVB>) (<SET VINS ,INST-MOVZBL>)>)>
975 <COND (<NOT <SET STRAC <VAR-VALUE-IN-AC? .STRUC>>>
976 <SET STRAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
977 ;"Get structure into AC"
979 <COND (<N==? .STRAC ,AC-0> <PROTECT <PREV-AC .STRAC>>)>
983 (<TYPE? .ELVAL VARTBL>
984 ;"Get the address to use for the thing we're putting"
986 (<SET LVAR <FIND-CACHE-VAR .ELVAL>>
987 <COND (.DOUBLE? <SET TAC <LINKVAR-TYPE-WORD-AC .LVAR>>)
989 <SET VAC <LINKVAR-VALUE-AC .LVAR>>
990 <COND (<OR <NOT .DOUBLE?>
991 <AND .VAC .TAC <==? .VAC <NEXT-AC .TAC>>>
992 <AND <NOT .VAC> <NOT .TAC>>>
993 ;"Case where all in acs or all not in acs"
994 <COND (.DOUBLE? <SET ELADDR <VAR-TYPE-ADDRESS .ELVAL>>)
995 (T <SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
996 (<AND <OR <NOT .TAC> <LINKVAR-TYPE-STORED .LVAR>>
997 <OR <NOT .VAC> <LINKVAR-VALUE-STORED .LVAR>>>
998 ;"Everything safely on stack"
999 <SET ELADDR <ADDR-VAR-TYPE .ELVAL>>)
1000 (T ;"Type and value live in separate places, can't MOVQ"
1002 <NOT <LINKVAR-TYPE-STORED .LVAR>>
1004 <VARTBL-DECL .ELVAL>>
1005 <SET NO-TYPE? <TYPE-WORD <VARTBL-DECL .ELVAL>>>)
1006 (T <SET NO-TYPE? <VAR-TYPE-ADDRESS .ELVAL>>)>
1007 <SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
1008 (.DOUBLE? <SET ELADDR <VAR-TYPE-ADDRESS .ELVAL>>)
1009 (<SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
1010 (.DOUBLE? <SET ELADDR <ADDR-TYPE-MQUOTE .ELVAL>>)
1011 (<SET ELADDR <MA-IMM .ELVAL>>)>)
1012 (<==? .ELVAL STACK> ;"Only happens in NTH case"
1013 <COND (<NOT .DOUBLE?> <EMIT-PUSH <TYPE-WORD .EHINT> LONG>)>
1014 <SET ELAC <MA-AINC ,AC-TP>>)
1015 (<==? .ELVAL .STRUC>
1016 <COND (.DOUBLE? <SET ELAC <GET-AC DOUBLE T>>)
1017 (<SET ELAC <GET-AC PREF-VAL T>>)>)
1018 (<NOT <AND <SET ELAC <VAR-VALUE-IN-AC? .ELVAL>>
1020 <AND <SET ELTAC <VAR-TYPE-WORD-IN-AC? .ELVAL>>
1021 <==? <NEXT-AC .ELTAC> .ELAC>>>>>
1023 <COND (.DOUBLE? <SET ELAC <GET-AC DOUBLE T>>)
1024 (<SET ELAC <GET-AC PREF-VAL T>>)>)
1028 <STORE-AC .ELTAC T <FIND-CACHE-VAR .ELVAL>>
1029 <STORE-AC .ELAC T <FIND-CACHE-VAR .ELVAL>>
1031 (T <STORE-AC .ELAC T <FIND-CACHE-VAR .ELVAL>>)>)>
1032 ;"Get AC[s] for result"
1033 <REST-BLOCK-GEN .STRUC
1039 <COND (.PUT? .ELADDR) (.ELAC)>
1042 <COND (<AND <NOT .PUT?> <N==? .ELVAL STACK>>
1043 <COND (.DOUBLE? <DEST-PAIR <NEXT-AC .ELAC> .ELAC .ELVAL>)
1044 (<LINK-VAR-TO-AC .ELVAL .ELAC VALUE <>>)>
1045 <COND (.EHINT <DEST-DECL .ELAC .ELVAL .EHINT>)>)>
1050 <DEFINE NTH-LENGTH-GEN (CINS STRUC OFF STYPE RES
1051 "AUX" SAC (TUP <ITUPLE 5 <>>) RAC)
1052 <COND (<NOT <SET SAC <VAR-VALUE-IN-AC? .STRUC>>>
1053 <SET SAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
1055 <GET-ADDR .TUP .STRUC .SAC .OFF .STYPE <> <> T>
1056 <COND (<NOT <SET RAC <VAR-VALUE-IN-AC? .RES>>>
1057 <SET RAC <GET-AC PREF-VAL T>>)>
1058 <EMIT ,INST-MOVW !<2 .TUP> <MA-REG .RAC>>
1059 <LINK-VAR-TO-AC .RES .RAC VALUE <>>
1060 <DEST-DECL .RAC .RES FIX>
1063 <DEFINE NTH-LENGTH-COMP-GEN (CINS STRUC OFF STYPE AMT CMPINS OP-INFO
1064 "AUX" SAC (TUP <ITUPLE 5 <>>))
1065 #DECL ((OP-INFO) OP-INFO)
1066 <COND (<NOT <SET SAC <VAR-VALUE-IN-AC? .STRUC>>>
1067 <SET SAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
1069 <GET-ADDR .TUP .STRUC .SAC .OFF .STYPE <> <> T>
1071 <COND (<==? .CMPINS EMPL?!-MIMOP>
1072 <EMIT ,INST-TSTL !<1 .TUP>>)
1073 (<EMIT ,INST-TSTW !<2 .TUP>>)>)
1074 (<TYPE? .AMT FIX> <EMIT ,INST-CMPW !<2 .TUP> <MA-IMM .AMT>>)
1075 (T <EMIT ,INST-CMPW !<2 .TUP> <VAR-VALUE-ADDRESS .AMT>>)>
1077 <COMPUTE-DIRECTION <OP-DIR .OP-INFO>
1078 <COND (<MEMQ .CMPINS ,EMPU> ,CEQ-CODE)
1079 (<==? .CMPINS EMPL?!-MIMOP> ,CEQ-CODE)
1080 (<==? .CMPINS VEQUAL?!-MIMOP> ,CEQ-CODE)
1081 (<==? .CMPINS LESS?!-MIMOP> ,CLT-CODE)
1082 (<==? .CMPINS GRTR?!-MIMOP> ,CGT-CODE)>>
1083 <OP-BRANCH .OP-INFO>
1087 <DEFINE SLOT-COMPARE (STRUC1 STRUC2 CMPINS OP-INFO OFF1 STYPE1 OFF2 STYPE2
1088 "AUX" (SAC1 <>) (SAC2 <>) (ADDR1 <ITUPLE 5 <>>)
1089 (ADDR2 <ITUPLE 5 <>>) (SHORT? <>) TMP FC)
1090 #DECL ((ADDR1 ADDR2) <OR TUPLE EFF-ADDR LADDR>)
1091 <COND (<OR <MEMQ .STYPE1 '[STRING BYTES]>
1092 <MEMQ .STYPE2 '[STRING BYTES]>>
1094 <COND (<AND .OFF2 <NOT .OFF1>>
1097 <SET STYPE1 .STYPE2>
1100 <SET STRUC2 .STRUC1>
1102 <SET CMPINS <COND (<==? .CMPINS GRTR?!-MIMOP>
1104 (<==? .CMPINS LESS?!-MIMOP>
1108 <COND (<NOT <SET SAC1 <VAR-VALUE-IN-AC? .STRUC1>>>
1109 <SET SAC1 <LOAD-VAR .STRUC1 VALUE <> PREF-VAL>>)>
1110 <PROTECT-USE .SAC1>)>
1112 <COND (<N==? .STRUC1 .STRUC2>
1113 <COND (<NOT <SET SAC2 <VAR-VALUE-IN-AC? .STRUC2>>>
1114 <SET SAC2 <LOAD-VAR .STRUC2 VALUE <> PREF-VAL>>)>
1115 <PROTECT-USE .SAC2>)
1116 (T <SET SAC2 .SAC1>)>)>
1117 <COND (.OFF1 <GET-ADDR .ADDR1 .STRUC1 .SAC1 .OFF1 .STYPE1 <>>)
1118 (<TYPE? .STRUC1 VARTBL>
1119 <SET ADDR1 <VAR-VALUE-ADDRESS .STRUC1>>)
1120 (<FIX-CONSTANT? .STRUC1>
1121 <COND (<NOT <TYPE? .STRUC1 FLOAT>>
1122 <SET ADDR1 <MA-IMM .STRUC1>>)
1124 <SET ADDR1 <FLOAT-IMM <FLOATCONVERT .STRUC1>>>)>)
1125 (<AND <==? <PRIMTYPE .STRUC1> LIST>
1128 <SET ADDR1 <MA-IMM 0>>)
1130 <SET ADDR1 <ADDR-VALUE-MQUOTE .STRUC1>>)>
1132 <COND (<TYPE? .STRUC2 VARTBL>
1133 <SET ADDR2 <VAR-VALUE-ADDRESS .STRUC2>>)
1134 (<FIX-CONSTANT? .STRUC2>
1135 <COND (<NOT <TYPE? .STRUC2 FLOAT>>
1136 <SET ADDR2 <MA-IMM .STRUC2>>)
1138 <SET ADDR2 <FLOAT-IMM <FLOATCONVERT .STRUC2>>>)>)
1139 (<AND <==? <PRIMTYPE .STRUC2> LIST>
1142 <SET ADDR2 <MA-IMM 0>>)
1144 <SET ADDR2 <ADDR-VALUE-MQUOTE .STRUC2>>)>)
1145 (<AND <3 .ADDR1> ;"First guy had index register"
1147 <TYPE? .OFF2 VARTBL>
1148 <OR <==? .STYPE1 .STYPE2> .SHORT?>>
1149 <GET-ADDR .ADDR2 .STRUC2 .SAC2 .OFF2 .STYPE2 <> <3 .ADDR1>>)
1150 (T <GET-ADDR .ADDR2 .STRUC2 .SAC2 .OFF2 .STYPE2 <>>)>
1151 <COND (<OR <==? .STRUC1 0> <==? .STRUC2 0>>
1152 <EMIT <COND (.SHORT? ,INST-TSTB) (,INST-TSTL)>
1153 !<COND (<==? .STRUC1 0> <1 .ADDR2>) (<1 .ADDR1>)>>)
1154 (<OR <==? .STRUC1 0.0> <==? .STRUC2 0.0>>
1156 !<COND (<==? .STRUC1 0.0> <1 .ADDR2>) (<1 .ADDR1>)>>)
1157 (<OR <TYPE? .STRUC1 FLOAT> <TYPE? .STRUC2 FLOAT>>
1159 !<COND (<TYPE? .ADDR1 TUPLE> <1 .ADDR1>)((.ADDR1))>
1160 !<COND (<TYPE? .ADDR2 TUPLE> <1 .ADDR2>)((.ADDR2))>>)
1162 <EMIT <COND (.SHORT? ,INST-CMPB) (T ,INST-CMPL)>
1163 !<COND (<TYPE? .ADDR1 TUPLE> <1 .ADDR1>) ((.ADDR1))>
1164 !<COND (<TYPE? .ADDR2 TUPLE> <1 .ADDR2>) ((.ADDR2))>>)>
1166 <COMPUTE-DIRECTION <OP-DIR .OP-INFO>
1167 <COND (<==? .CMPINS VEQUAL?!-MIMOP> ,CEQ-CODE)
1168 (<==? .CMPINS LESS?!-MIMOP> ,CLT-CODE)
1169 (<==? .CMPINS GRTR?!-MIMOP> ,CGT-CODE)>>
1170 <OP-BRANCH .OP-INFO>