1 <COND (<NOT <GASSIGNED? WIDTH-MUNG>>
2 <FLOAD "MIMOC20DEFS.MUD">
3 <FLOAD "MSGLUE-PM.MUD">)>
7 <FUNCTION (FROB "AUX" (LBL <5 .FROB>))
8 #DECL ((FROB) <LIST ATOM LIST FIX LIST LIST>
10 <FIXUP-ONE-GLUE <4 .FROB> .LBL>
11 <FIXUP-CONSTANTS <4 .FROB>>>
14 <DEFINE FIXUP-ONE-GLUE (CODE LBL "AUX" (N 0))
15 #DECL ((CODE LBL) LIST)
17 <FUNCTION (LST "AUX" (INS <1 .LST>) ITM CONST LB FC)
18 #DECL ((LST) LIST (CONST) CONSTANT (FC) CONSTANT-BUCKET
19 (INS) <OR ATOM INST CONSTANT CONST-W-LOCAL> (ITM) ANY)
20 <COND (<NOT <TYPE? .INS ATOM>> <SET N <+ .N 1>>)>
24 (<TYPE? <SET ITM <1 .INS>> GFRM SGFRM SBFRM>
25 <COND (<==? <SET ITM <CHTYPE .ITM ATOM>> COMPERR>
26 <SET CONST <CHTYPE <+ ,SETZ 106> CONSTANT>>)
27 (<OR <==? .ITM UNWCONT> <==? .ITM IOERR>>
28 <SET CONST <CHTYPE <+ ,SETZ-IND <OPCODE .ITM>> CONSTANT>>)
29 (<OR <NOT <SET LB <OR <FIND-LABEL .ITM>
30 <LONG-FIND-LABEL .ITM .LBL>>>>
31 <NOT <SET LB <LAB-IND .LB>>>>
32 <MIMOCERR BAD-FRM-LABEL!-ERRORS .ITM>)
35 <CHTYPE <+ <CHTYPE .LB FIX>
36 <COND (<TYPE? <1 .INS> GFRM> ,SETZ-R)
37 (<TYPE? <1 .INS> SBFRM> ,SETZQ-R)
40 <SET FC <1 ,FREE-CONSTS>>
42 <SETG FREE-CONSTS <REST ,FREE-CONSTS>>
43 <SET ITM <CHTYPE [.FC] REF>>
44 <PUT .LST 1 <COND (<TYPE? <1 .INS> SBFRM> <CHTYPE [MOVE O* .ITM] INST>)
45 (ELSE <CHTYPE [PUSH TP* .ITM] INST>)>>)
48 <PUT .LST 1 <CHTYPE [JRST 0 '(R*)] INST>>
49 <SETG GCALS ((.N <CHTYPE .ITM ATOM> <3 .INS>) !,GCALS)>)
52 <CHTYPE [JRST <GFIND <CHTYPE .ITM ATOM> <3 .INS>> '(R*)]
56 <DEFINE FIND-CALL (ATM LIST)
57 #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM]>)
59 <COND (<EMPTY? .LIST> <RETURN <>>)>
60 <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN .LIST>)>
61 <SET LIST <REST .LIST>>>>
63 <DEFINE FIND-OPT (ATM LIST)
64 #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM <PRIMTYPE LIST>]>)
66 <COND (<EMPTY? .LIST> <RETURN <>>)>
67 <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN <REST .LIST>>)>
68 <SET LIST <REST .LIST 2>>>>
70 <DEFINE SAME-NAME? (X Y "AUX" S1 S2)
71 #DECL ((X Y) ATOM (S1 S2) STRING)
72 <COND (<NOT ,INT-MODE>
78 <AND <G? <LENGTH .S1> 2>
81 <=? <REST .S1 2> .S2>>
82 <AND <G? <LENGTH .S2> 2>
85 <=? <REST .S2 2> .S1>>>)>>
87 <DEFINE GFIND (NAM LBL?)
88 #DECL ((NAM) ATOM (LBL?) <OR ATOM FALSE>)
91 #DECL ((L) <LIST ATOM LIST FIX>)
92 <COND (<SAME-NAME? <1 .L> .NAM>
99 <MIMOCERR BAD-OPT-LABEL!-ERRORS
101 (ELSE <MAPLEAVE <3 .L>>)>)>>
104 <MIMOCERR CANT-FIND-GL-ENTRY!-ERRORS .NAM>)>>
106 <DEFINE CALL-ANA (L "AUX" (ANA-L ()))
107 #DECL ((L ANA-L) LIST)
109 <FUNCTION (ITM "AUX" ONE LBL TEM IT X)
110 #DECL ((ITM) <OR ATOM FORM> (ONE LBL) ATOM)
111 <COND (<AND <TYPE? .ITM FORM>
113 <COND (<OR <==? <SET ONE <1 .ITM>> FRAME>
115 <SET ANA-L (.ITM !.ANA-L)>)
116 (<OR <==? .ONE CALL> <==? .ONE SCALL>>
117 <COND (<AND <TYPE? <SET IT <2 .ITM>> FORM>
120 <PROG () <SET IT <2 .IT>> T>
126 '[GVAL GASSIGNED?]>>>
127 <COND (<NOT <AND <TYPE? <SET TEM
138 BAD-FRAME-CALL-MATCH!-ERRORS
150 <SET ANA-L <REST .ANA-L>>)
152 <SET ANA-L <REST .ANA-L>>)>)>>
155 <DEFINE MIMOC (L "OPT" (WINNER <>)
156 "AUX" NAME (OBLIST .OBLIST) (OUTCHAN .OUTCHAN) PO
158 #DECL ((L) <LIST [REST <OR ATOM FORM>]> (NAME) ATOM
159 (MACT) <SPECIAL ANY> (OUTCHAN OBLIST) <SPECIAL ANY>)
160 <COND (,NO-AC-FUNNYNESS <SETG PASS1 <>>) (ELSE <SETG PASS1 T>)>
161 <SETG NEXT-LOOP <SETG LAST-UNCON <>>>
162 <SETG AC-STAMP <SETG VISIT-COUNT 0>>
165 <PROG ((LSEQ ,LBLSEQ) (OLD-LOCS ()))
169 <COND (.WINNER <SETG WINNING-VICTIM 2>)
170 (ELSE <SETG WINNING-VICTIM <>>)>
172 <FUNCTION (MIML "AUX" (ITM <1 .MIML>) OP ITML M LB DCLIST (OPT? <>))
173 #DECL ((MIML) <SPECIAL LIST> (ITM) <OR ATOM FORM>
174 (M) <OR FALSE <LIST ATOM ATOM>> (DCLIST) LIST)
176 <AC-ITEM ,ACA-AC ,ACA-ITEM>
177 <COND (,ACA-BOTH <AC-ITEM ,ACA-BOTH ,ACA-ITEM>)>
183 (<SET M <MEMQ .ITM ,ICALL-TAGS>>
186 <LABEL <2 .M> <> .MIML>
187 <COND (<0? <SETG ICALL-FLAG <- ,ICALL-FLAG 1>>>
188 <SETG ICALL-FLAG <>>)>
190 <FIXUP-LOCALS <REST <CHTYPE <1 ,ALL-ICALL-TEMPS> LIST>>>)>
191 <PUTREST <1 ,ALL-ICALL-TEMPS> ()>
192 <SETG ALL-ICALL-TEMPS <REST ,ALL-ICALL-TEMPS>>
193 <SETG TEMP-CC <1 ,ALL-TEMP-CC>>
194 <SETG ALL-TEMP-CC <REST ,ALL-TEMP-CC>>)>
195 <COND (,PASS1 <SET LB <LABEL .ITM <> .MIML>> <SAVE-LABEL-STATE .LB>)
196 (,NO-AC-FUNNYNESS <SAVE-ACS> <SET LB <LABEL .ITM <> .MIML>>)
198 <SET LB <FIND-LABEL .ITM>>
199 <ESTABLISH-LABEL-STATE .LB>
200 <SET LB <LABEL .ITM <> .MIML>>)>
202 <SETG LAST-UNCON <>>)
204 <SET ITML <LENGTH .ITM>>
206 (<0? .ITML> <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
207 (<NOT <TYPE? <SET OP <1 .ITM>> ATOM>>
208 <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
209 (<MEMQ .OP '[FCN GFCN]>
210 <AND ,V1 <NOT ,PASS1> <PRINT .ITM>>
212 <COND (<L? .ITML 3> <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
214 <SET DCLIST <REST <CHTYPE <3 .ITM> LIST> 2>>
218 <FUNCTION (ATM "AUX" DC)
220 <COND (<TYPE? <SET DC <1 .DCLIST>>
222 <COND (<=? .DC "OPTIONAL">
226 <SET DCLIST <REST .DCLIST>>
228 <COND (,WINNING-VICTIM
230 <+ ,WINNING-VICTIM 2>>)>
231 <SET DCLIST <REST .DCLIST>>
233 <COND (.OPT? OARG) (ELSE ARG)>
235 <SETG LBLSEQ <+ ,LBLSEQ 1>>
242 <SETG ALL-TEMP-CC ()>
243 <SETG TYPED-LOCALS ()>
244 <SETG NRARGS <- <LENGTH .ITM> 3>>
248 <COND (<NOT ,GLUE-MODE>
249 <SETG CONSTANT-VECTOR ()>
250 <SETG FREE-CONSTS ()>
252 <FUNCTION (B:<VECTOR LIST>)
253 <PUT .B 1 ()>> ,CONSTANT-TABLE>
254 <SETG MVECTOR (T .NAME <3 .ITM>)>
256 <FUNCTION (B:<VECTOR LIST>)
257 <PUT .B 1 ()>> ,MV-TABLE>
259 <SETG FINAL-LOCALS ()>
260 <SETG MV <REST ,MVECTOR 2>>)
262 <SETG GLUE-NAME .NAME>
263 <SETG GLUE-DECL <3 .ITM>>
264 <SETG GCALS <SETG GREFS ()>>)>
269 <SETG OPT-LIST <>>)>)
271 <AND ,V1 <NOT ,PASS1> <PRINT .ITM> <CRLF>>
272 <SET ITM <SORT-TEMPS .ITM>>
273 <TEMP-INIT <REST .ITM> <> .OLD-LOCS>
274 <COND (,WINNING-VICTIM
275 <SETG WINNING-VICTIM <+ ,WINNING-VICTIM
276 <* <LENGTH .ITM> 2> -2>>)>)
277 (<==? .OP OPT-DISPATCH> <OPT-INIT <REST .ITM>>)
279 <AND ,V1 <NOT ,PASS1> <PRINT .ITM> <CRLF>>
280 <SET ITM <SORT-TEMPS .ITM>>
281 <TEMP-INIT <REST .ITM> T .OLD-LOCS>)
283 <COND (<AND ,V1 <NOT ,PASS1>> <PRINT .ITM>)>
284 <COND (<N==? .OP DEAD> <SETG NEXT-FLUSH <- ,NEXT-FLUSH 1>>)>)
286 <COND (<N==? .OP DEAD> <SETG NEXT-LOOP <>> <SETG LAST-UNCON <>>)>
288 <AC-TIME <GET-AC T*> <CHTYPE <MIN> FIX>>)>)>>
292 <SET OLD-LOCS ,LOCALS>
294 <COND (<NOT ,CHANGED> <SETG PASS1 <>>)
295 (<GASSIGNED? LOOP-DEBUG>
296 <COND (<==? ,LOOP-DEBUG 1>
300 (ELSE <ERROR ,CHANGED>)>)>
302 <FIXUP-LOCALS <REST ,LOCALS>>
303 <COND (,PEEP-ENABLED <SETG CODE <PPOLE ,CODE !<REST ,CODE>>>)>
306 <COND (<AND ,GLUE-MODE <SET PO <FIND-OPT .NAME ,PRE-OPTS>> <1 .PO>>
307 <MAPF <> <FUNCTION (A1 A2) #DECL ((A1 A2) ATOM)
309 <REST <1 .PO> 3> <REST ,OPT-LIST 2>>)>
311 <FUNCTION (C L "AUX" (X <1 .C>) LI)
312 #DECL ((C L) LIST (X) <OR INST ATOM>)
313 <COND (<AND <TYPE? .X INST>
315 <==? <1 .X> DISPATCH>>
319 <SET LI <LAB-IND <FIND-LABEL <2 .X>>>>
324 <REST ,CODE <+ ,OPT-OFFSET 2>> <REST ,OPT-LIST 2>>)>>
326 <DEFINE DECL-HACK (TYP)
328 <COND (<TYPE? .TYP FORM SEGMENT>
329 <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
330 <SET TYP <TYPE <2 .TYP>>>)
332 <SET TYP <DECL-HACK <2 <SET TY .TYP>>>>
335 <COND (<N==? .TYP <DECL-HACK .Z>>
336 <MAPLEAVE <SET TYP <>>>)>>
338 (ELSE <SET TYP <1 <SET TY .TYP>>>)>)>
339 <COND (<TYPE? .TYP ATOM>
340 <COND (<OR <AND <VALID-TYPE? .TYP>
341 <MEMQ <TYPEPRIM .TYP> '[WORD FIX LIST]>>
342 <MEMQ .TYP ,TYPE-LENGTHS>> .TYP)
343 (<AND <SET TYP <GETPROP .TYP DECL>>
348 <DEFINE SORT-TEMPS (TEMPL "AUX" (ALIST '())(NON-ALIST '()))
349 #DECL ((TEMPL) <PRIMTYPE LIST> (ALIST NON-ALIST) LIST)
351 <FUNCTION (L "AUX" (TEMP <1 .L>))
353 <COND (<EMPTY? .ALIST> <SET ALIST .L>)
355 <PUTREST <REST .ALIST <- <LENGTH .ALIST> 1>>
359 <SET ALIST (.TEMP !.ALIST)>)
360 (ELSE <SET NON-ALIST (.TEMP !.NON-ALIST)>)>>
362 <COND (<NOT <EMPTY? .NON-ALIST>>
363 <PUTREST <REST .NON-ALIST <- <LENGTH .NON-ALIST> 1>>
365 (ELSE <SET NON-ALIST .ALIST>)>
366 <CHTYPE (<1 .TEMPL> !.NON-ALIST) FORM>>
368 <DEFINE OPT-INIT (OPT "AUX" (OFF 1) MAX MAGIC)
369 #DECL ((OPT) <LIST FIX <OR FIX FALSE> [REST ATOM]> (OFF MAGIC) FIX
370 (MAX) <OR FALSE FIX>)
371 <COND (<SET MAX <2 .OPT>>
373 <OCEMIT CAILE O2* .MAX>
374 <OCEMIT JRST <XJUMP <NTH .OPT <LENGTH .OPT>>>>
376 <+ <- 5 <1 .OPT>> <COND (,GLUE-MODE ,GLUE-PC) (T 0)>>
379 <OCEMIT JRST @ '(O1*)>)
383 <+ <- 2 <1 .OPT>> <COND (,GLUE-MODE ,GLUE-PC) (T 0)>>
385 <OCEMIT JRST @ '(O2*)>)>
386 <MAPF <> <FUNCTION (X) <OCEMIT DISPATCH .X>> <REST <SETG OPT-LIST .OPT> 2>>
387 <SETG OPT-OFFSET .OFF>>
389 <DEFINE TEMP-INIT (LST
390 "OPTIONAL" (TUP <>) (OLD ())
391 "AUX" (STK TP*) (CNT 0) (TCC ,CC))
392 #DECL ((LST) LIST (CNT) FIX (TUP) <OR FALSE ATOM>)
395 <OCEMIT MOVEI O1* ,NRARGS>
396 <OCEMIT MOVEI O2* <- <LENGTH .LST> 2>>
397 <PUSHJ MAKTUP <NTH .LST <LENGTH .LST>>>
398 <OCEMIT XMOVEI B1* <+ 1 <* ,NRARGS 2>> '(F*)>
401 <SETG ALL-TEMP-CC (,TEMP-CC !,ALL-TEMP-CC)>
402 <SETG ALL-ICALL-TEMPS
403 (<REST ,ICALL-TEMPS <- <LENGTH ,ICALL-TEMPS> 1>>
405 (ELSE <SETG ALL-ICALL-TEMPS (<SETG ICALL-TEMPS (T)>)>)>
408 <FUNCTION (TEMP "AUX" VAR TYP FROB (VAL #LOSE *000000000000*) LCL)
412 <LIST <OR ATOM <ADECL ATOM ATOM>> ANY>>
423 <COND (<==? .TEMP => <MAPLEAVE T>)>
424 <COND (<TYPE? .TEMP ADECL>
428 <COND (<TYPE? <SET FROB <1 .TEMP>> ADECL>
434 <SET LCL <LMEMQ .VAR .OLD>>
437 <COND (.LCL <LUPD .LCL>)>
438 <CHTYPE <SETG LBLSEQ <+ ,LBLSEQ 1>> LOCAL-NAME>
439 <COND (<ASSIGNED? TYP> <SET TYP <DECL-HACK .TYP>>)
444 <COND (<NOT <TYPE? .VAL LOSE>> <LUPD .LCL TEMP>)>
446 <PUTREST <REST ,ICALL-TEMPS
447 <- <LENGTH ,ICALL-TEMPS> 1>>
450 <PUTREST <REST ,LOCALS <- <LENGTH ,LOCALS> 1>>
452 <COND (<AND <ASSIGNED? TYP> .TYP>
453 <OCEMIT PUSH .STK !<TYPE-WORD .TYP>>
454 <SETG TYPED-LOCALS (.LCL !,TYPED-LOCALS)>
455 <AND <TYPE? .VAL LOSE> <SET VAL 0>>)
457 <OCEMIT PUSH .STK !<OBJ-VAL 0>>
459 (T <OCEMIT PUSH .STK !<OBJ-LOC .VAL 0>>)>
460 <OCEMIT PUSH .STK !<OBJ-VAL .VAL>>>
462 <COND (<==? .STK B1*> <AC-TIME <GET-AC B1*> 0>)>>
464 <DEFINE PRE-HACK (L "AUX" LR)
466 <SETG THE-BIG-LABELS ()>
467 <REPEAT (WIN (FIX-LABS <>) (FIRST T))
468 #DECL ((FIRST WIN) <OR ATOM FALSE>)
472 <FUNCTION (LL "AUX" (FRM <1 .LL>) M N I A LBL)
473 #DECL ((FRM) <OR FORM ATOM> (M) <OR FALSE LIST>
474 (LBL) ATOM (N) <OR FALSE LIST> (I) FORM
476 <COND (<TYPE? .FRM ATOM>
478 <COND (.FIRST <REMOVE-FUNNY-DEADS .FRM>)>
479 <COND (<OR <==? <1 .FRM> OPT-DISPATCH>
480 <==? <1 .FRM> DISPATCH>>
487 <MAPRET !<REST .FRM 3>>)
488 (<OR <SET M <MEMQ + .FRM>>
489 <SET M <MEMQ - .FRM>>
490 <AND <==? <1 .FRM> NTHR>
495 <==? <1 .A> BRANCH-FALSE>
497 <COND (<OR <==? <SET LBL <2 .M>> COMPERR>
502 <PUT .M 2 <FIX-LAB .LBL>>
504 (<SET N <MEMQ .LBL .L>>)
505 (T <MIMOCERR BAD-LABEL!-ERRORS
507 <COND (<==? <1 <SET I <NEXTINS .N>>>
511 (<AND <==? <1 .FRM> JUMP>
517 (<==? <1 .FRM> ICALL>
519 <PUT .FRM 2 <FIX-LAB <2 .FRM>>>)>
524 <REPEAT ((L .L) (OL .L) ITM (NEXT-LOOP <>))
525 #DECL ((L OL) LIST (ITM) ANY)
526 <COND (<EMPTY? .L> <RETURN>)
527 (<TYPE? <SET ITM <1 .L>> ATOM>
529 <PUT .L 1 <SET ITM <FIX-LAB .ITM>>>
530 <MAKE-LABEL .ITM <> .L .NEXT-LOOP>
532 (<NOT <MEMQ .ITM .LR>>
533 <PUTREST .OL <REST .L>>
539 <==? <1 .ITM> ACTIVATION>>
540 <SETG THE-BIG-LABELS (<SET ITM <GENLBL "ACT">>
542 <MAKE-LABEL .ITM <> .L T>
544 (<AND <TYPE? .ITM FORM> <==? <1 .ITM> LOOP>>
546 <SET L <REST <SET OL .L>>>
548 (<AND <TYPE? .ITM FORM>
550 <TYPE? <SET ITM <1 .OL>> FORM>
552 <PUTREST .OL <REST .L>>
554 (<AND <TYPE? <SET ITM <1 .L>> FORM>
557 <==? <2 .L> <3 .ITM>>>
558 <PUTREST .OL <REST .L>>
560 (<AND <TYPE? .ITM FORM>
563 <NOT <TYPE? <2 .L> ATOM>>>
564 <PUTREST .L <REST .L 2>>
566 (<AND <TYPE? .ITM FORM>
567 <OR <==? <1 .ITM> RETURN>
568 <==? <1 .ITM> RTUPLE>
571 <==? <1 .ITM> MRETURN>>>
572 <REPEAT ((LL <REST .L>)) #DECL ((LL) LIST)
573 <COND (<OR <EMPTY? .LL>
574 <TYPE? <SET ITM <1 .LL>>
576 <COND (<N==? <REST .L> .LL>
580 <COND (<==? <1 .ITM> DEAD>
581 <COND (<N==? <REST .L> .LL>
590 <COND (.FIX-LABS <RETURN>)
591 (<NOT .WIN> <SET FIX-LABS T>)>>>
593 <DEFINE REMOVE-FUNNY-DEADS (FRM:FORM "AUX" (N:FIX <LENGTH .FRM>))
595 <COND (<AND <TYPE? <SET L <NTH .FRM .N>> LIST>
597 <OR <==? <SET FOO <1 .L>> DEAD-FALL>
598 <==? .FOO DEAD-JUMP>>>
599 <PUTREST <REST .FRM <- .N 2>> <REST .FRM .N>>
603 <COND (<L=? .N 1> <RETURN>)>>>
605 <DEFINE FIX-LAB (X) <SET X <SPNAME .X>> <OR <LOOKUP .X ,LABEL-OBLIST>
606 <INSERT .X ,LABEL-OBLIST>>>
609 <DEFINE FIXUP-REFS ("AUX" (C <REST ,CODE>) (PC 0) FOO M TG
610 (OFF <COND (,GLUE-MODE ,GLUE-PC) (T 0)>) R
611 (WV ,WINNING-VICTIM))
612 #DECL ((LABELS) LIST (PC OFF) FIX (C) LIST (FOO R) ANY
613 (M) <OR FALSE LAB LIST>)
615 <FUNCTION (C "AUX" R M X)
616 #DECL ((M) <OR FALSE LAB>)
617 <COND (<TYPE? .C INST>
618 <COND (<TYPE? <SET R <NTH .C <LENGTH .C>>> REF>
619 <COND (<AND <TYPE? <SET X <1 .R>> ATOM>
620 <SET M <FIND-LABEL .X>>>
621 <PUT .M ,LAB-IND 0>)>)
622 (<TYPE? .R FORM GVAL>
623 <PUT .C <LENGTH .C> <EVAL .R>>)>)>>
626 <COND (<EMPTY? .C> <RETURN <SETG CODE-LENGTH .PC>>)
627 (<AND <TYPE? <SET FOO <1 .C>> ATOM> <SET M <FIND-LABEL .FOO>>>
628 <PUT .M ,LAB-IND <+ .PC .OFF>>)
629 (ELSE <SET PC <+ .PC 1>>)>
632 <FUNCTION (COD "AUX" (C <1 .COD>) R NPC (FLG <>))
633 #DECL ((COD) LIST (C R) ANY (NPC) FIX (FLG) <OR ATOM FALSE>)
634 <COND (<AND <TYPE? .C INST>
635 <OR <TYPE? <SET R <2 .C>> REF>
636 <AND <G? <LENGTH .C > 2>
637 <TYPE? <SET R <3 .C>> REF>
639 <SET TG <1 <CHTYPE .R REF>>>
641 <COND (<OR <NOT <TYPE? .TG ATOM>>
642 <NOT <SET M <MEMQ .TG <REST ,CODE>>>>>)
643 (T <SET NPC <LAB-IND <FIND-LABEL <1 <CHTYPE .R REF>>>>>)>
645 <COND (<==? .TG COMPERR>
646 <COND (.FLG <PUT .C 3 106>) (T <PUT .C 2 106>)>)
647 (<OR <==? .TG UNWCONT> <==? .TG IOERR>>
651 <CHTYPE [<1 .C> <2 .C> @ <OPCODE .TG>]
656 <CHTYPE [JRST @ <OPCODE .TG>] INST>>)>)
657 (<NOT <TYPE? .TG CONSTANT-BUCKET>>
658 <MIMOCERR UNKNOWN-LABEL!-ERRORS
659 <1 <CHTYPE .R REF>>>)>)
661 <PUT .COD 1 <CHTYPE [<1 .C> <2 .C> .NPC '(R*)] INST>>)
662 (T <PUT .COD 1 <CHTYPE [JRST .NPC '(R*)] INST>>)>)>>
665 <DEFINE WRITE-MSUBR (OC "OPTIONAL" (LOWERSTR <>) (F-OR-G <>)
666 "AUX" NUM (MVECTOR ,MVECTOR) (OUTCHAN .OC)
668 #DECL ((NAME) ATOM (DECL) <PRIMTYPE LIST> (MVECTOR) LIST
669 (NUM) FIX (OUTCHAN) <SPECIAL CHANNEL> (OB) STRING)
670 <AND ,INT-MODE <PRINTTYPE ATOM ,ATOM-PRINT>>
671 <COND (<NOT .LOWERSTR>
674 <FUNCTION (CHR "AUX" (ICHR <ASCII .CHR>))
675 #DECL ((CHR) CHARACTER (ICHR) FIX)
676 <COND (<AND <L=? .ICHR <ASCII !\Z>>
677 <G=? .ICHR <ASCII !\A>>>
678 <ASCII <+ .ICHR 32>>)
680 <SPNAME <2 .MVECTOR>>>>)>
681 <WIDTH-MUNG .OC 100000000>
682 <COND (,GLUE-MODE <SETG GLUE-LIST <LREVERSE ,GLUE-LIST>>)>
684 <COND (<NOT ,BOOT-MODE>
686 <COND (<NOT ,GLUE-MODE> <PRINC <ASCII 26> .OC>)>
687 <PRINC .LOWERSTR .OC>
688 <COND (<NOT ,BOOT-MODE>
689 <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OC>)
690 (ELSE <PRINC "-IMSUBR " .OC>)>)>
692 <PRINC "#IMSUBR [|" .OC>
693 <COND (<AND ,GLUE-MODE <NOT ,MAX-SPACE>>
696 <FUNCTION (L "AUX" C)
697 #DECL ((L) <LIST ATOM LIST FIX <LIST ANY>>
699 <SET C <REST <4 .L>>>
703 <SETG CODE (T !,CODE)>)>
704 <COND (<NOT ,BOOT-MODE>
705 <PRINTBYTE <CHTYPE <LSH <SET NUM
706 <+ <COND (,GLUE-MODE ,GLUE-PC)
708 <LENGTH ,CONSTANT-VECTOR>>>
711 <PRINTBYTE <CHTYPE <LSH .NUM -8> FIX> 7>
713 <COND (<NOT ,MAX-SPACE> <WRITE-CODE .OC .LOWERSTR <REST ,CODE> .OB>)
715 <CHANNEL-OP .OC WRITE-BUFFER ,OUTPUT-BUFFER
716 <- ,OUTPUT-LENGTH <LENGTH .OB>>>)>
717 <COND (<NOT ,GLUE-MODE>
718 <COND (<==? .F-OR-G GFCN>
719 <PRIN1 ,CODE-LENGTH .OC>)
721 <PRIN1 <- ,CODE-LENGTH> .OC>)>
723 <COND (<NOT ,BOOT-MODE>
725 <COND (<NOT ,GLUE-MODE> <PRINC <ASCII 26> .OC>)>
726 <PRIN1 <2 .MVECTOR> .OC>
728 <PRINC "#MSUBR [" .OC>
729 <PRINC .LOWERSTR .OC>
730 <COND (<NOT ,BOOT-MODE>
731 <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OC>)
732 (ELSE <PRINC "-IMSUBR " .OC>)>)>
734 <PRIN1 <2 .MVECTOR> .OC>
736 <PRIN1 <3 .MVECTOR> .OC>
738 <COND (<NOT ,BOOT-MODE> <PRINC ">" .OC>)>
739 <WIDTH-MUNG .OC 80>)>
740 <AND ,INT-MODE <NOT ,MAX-SPACE> <PRINTTYPE ATOM ,PRINT>>
741 <COND (,MAX-SPACE .LOWERSTR)>>
744 <DEFINE WRITE-CODE (OC LOWERSTR CODE OB
746 "AUX" (MVECTOR ,MVECTOR) LCL (OUTCHAN .OC))
747 #DECL ((CODE MVECTOR) LIST (LEN) FIX (OUTCHAN) <SPECIAL CHANNEL>
748 (LCL) <OR FALSE <LIST [REST LOCAL-NAME FIX]>> (OB) STRING)
751 <COND (<SET WRD <ASS-INS .WRD>>
753 <REPEAT ((I 4)) #DECL ((I) FIX)
754 <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
755 <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>)>>
760 <FUNCTION (CB:CONSTANT-BUCKET "AUX" (WRD <CB-VAL .CB>))
761 <COND (<TYPE? .WRD CONSTANT>
762 <REPEAT ((I 4)) #DECL ((I) FIX)
763 <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
764 <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>
765 <SET LEN <+ .LEN 4>>)
766 (<TYPE? .WRD CONST-W-LOCAL>
767 <COND (<SET LCL <MEMQ <1 .WRD> ,FINAL-LOCALS>>
769 <CHTYPE <ORB <ANDB <2 .WRD>
771 <ANDB <+ <CHTYPE <2 .WRD> FIX>
772 <CHTYPE <2 .LCL> FIX>>
775 <PRINC "**** WARNING unknown local: " ,OUTCHAN>
776 <PRIN1 <1 .WRD> ,OUTCHAN>
777 <PRINC " in fcn " ,OUTCHAN>
778 <PRIN1 .NAME ,OUTCHAN>
781 <REPEAT ((I 4)) #DECL ((I) FIX)
782 <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
783 <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>
784 <SET LEN <+ .LEN 4>>)>>
786 <CHANNEL-OP .OC WRITE-BUFFER ,OUTPUT-BUFFER <- ,OUTPUT-LENGTH <LENGTH .OB>>>
789 <COND (<NOT ,BOOT-MODE>
790 <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OUTCHAN>)
791 (ELSE <PRINC "-IMSUBR " .OUTCHAN>)>)>
797 ; "This used to strip off a level of quoting
798 for atoms, but that's already happened in
800 ;<AND <TYPE? .MV FORM>
803 <TYPE? <2 .MV> ATOM>>
805 <COND (<TYPE? .MV CHARACTER>
806 <PRINTTYPE CHARACTER ,CHR-PRINT>
808 <PRINTTYPE CHARACTER ,PRINT>)
809 (<TYPE? .MV CONST-W-LOCAL>
811 <+ <CHTYPE <2 <MEMQ <1 .MV> ,FINAL-LOCALS>>
813 <CHTYPE <2 .MV> FIX>>>
817 <COND (,GLUE-MODE <WIDTH-MUNG .OUTCHAN 80>)>
819 <COND (<NOT ,BOOT-MODE> <PRINC !\>>)>
822 <PROG ((OUTCHAN <COND (,V2) (,V1 .OUTCHAN) (T ,OUTCHAN)>))
823 #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
826 <PRINC " / Vector: ">
827 <PRIN1 <* <- <LENGTH .MVECTOR> 1> 2>>
832 <DEFINE ASS-INS (WRD "AUX" M (AC? <>) (ADR 0) (IDX 0) (INS 0) (IND 0) INAME LCL)
833 #DECL ((WRD) <OR CONST-W-LOCAL CONSTANT FIX WORD INST ATOM>
834 (INS ADR IDX IND) FIX (AC?) <OR FALSE FIX> (INAME) ATOM
835 (M) <OR FALSE VECTOR>)
837 (<TYPE? .WRD ATOM> <>)
841 <COND (<==? .FROB @> <SET IND 16>)
842 (<AND <TYPE? .FROB ATOM> <SET M <MEMQ .FROB ,ACS>>>
843 <COND (<OR .AC? <N==? .IND 0>>
844 <SET ADR <+ .ADR <2 .M>>>)
845 (T <SET AC? <2 .M>>)>)
846 (<TYPE? .FROB LOCAL-NAME>
847 <COND (<SET LCL <MEMQ .FROB ,FINAL-LOCALS>>
848 <SET ADR <+ .ADR <CHTYPE <2 .LCL> FIX>>>)
851 <PRINC "**** WARNING unknown local: " ,OUTCHAN>
852 <PRIN1 .FROB ,OUTCHAN>
853 <PRINC " in fcn " ,OUTCHAN>
854 <PRIN1 .NAME ,OUTCHAN>
858 <SET FROB <COND (<LOOKUP <SPNAME .FROB> ,OPS>)
859 (<LOOKUP <SPNAME .FROB> ,JSYS-OBLIST>)
861 <COND (<AND <GASSIGNED? .FROB>
863 <SET INS <CHTYPE <LSH ,.FROB -27> FIX>>
864 <SET ADR <CHTYPE <ANDB ,.FROB *777777*> FIX>>)
868 <MIMOCERR BAD-OPCODE!-ERRORS .FROB>)>)
871 <SET IDX <2 <SET M <CHTYPE <MEMQ .FROB ,ACS>
873 (<MEMQ <PRIMTYPE .FROB> '[WORD FIX]>
874 <SET ADR <+ .ADR <CHTYPE .FROB FIX>>>)
875 (<MIMOCERR BAD-THING-IN-CODE!-ERRORS .FROB>)>>
877 <COND (<NOT .AC?> <SET AC? 0>)>
878 <CHTYPE <ORB <LSH .INS 27>
879 <LSH <+ <CHTYPE <LSH .AC? 5> FIX>
881 <ANDB .ADR *777777*>> FIX>)>>
883 <DEFINE DUMP-CODE (CODE TC "AUX" (CB ,CODE-BUFFER) (TCB .CB))
884 #DECL ((CODE) LIST (TC) CHANNEL (CB TCB) <UVECTOR [REST FIX]>)
885 <PUT .CB 1 ,CODE-LENGTH>
889 <COND (<SET WRD <ASS-INS .WRD>>
891 <COND (<EMPTY? <SET CB <REST .CB>>>
895 <COND (<N==? .CB .TCB>
896 <PRINTB .TCB .TC <- ,CB-LENGTH <LENGTH .CB>>>)>>
898 <DEFINE READ-CODE (TC "AUX" (FB ,ONE-WD)) #DECL ((FB) <UVECTOR FIX>)
900 <READB <SET FB <IUVECTOR <1 .FB> 0>> .TC>
905 <MIMOCERR CANT-OPEN-COMPILE!-ERRORS .L>>
907 <DEFINE MIMOCERR ("TUPLE" T)
918 <DEFINE DOC ("TUPLE" NAM)
919 <PROG ((OUTCHAN <OPEN "PRINT" <STRING <GET-NM1 <1 .NAM>> ".OC">>))
920 #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
924 <COND (,GLUE-MODE <FILE-GLUE !.NAM>)
925 (ELSE <FILE-MIMOC !.NAM>)>