5 <DEFINE READIN (READ-INFO "OPTIONAL" (NXT <>) "AUX" RES LAST FROB ATM)
6 #DECL ((READ-INFO) TUPLE (RES) <PRIMTYPE LIST>)
7 <SET RES <READ-LIST-INTERNAL .READ-INFO END!- <>>>
10 <NOT <TYPE? <SET LAST <NTH .RES <LENGTH .RES>>> FORM>>
12 <N==? <1 .LAST> END!- >>
16 <SET RES (.NXT !.RES)>)>
17 <REPEAT ((L .RES) (LL .RES) OBJ (IFL ()) (FLUSH? <>))
19 <COND (<EMPTY? .L> <RETURN>)>
20 <COND (<AND <TYPE? <SET OBJ <1 .L>> FORM>
22 <COND (<==? <SET FROB <1 .OBJ>> END!-MIMOP>
24 <COND (<==? .FROB IFSYS!-MIMOP>
25 <COND (<MEMBER <2 .OBJ> '["VAX" "UNIX"]>
26 <SET IFL (<2 .OBJ> !.IFL)>
29 <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
33 (<==? .FROB IFCAN!-MIMOP>
35 <SET ATM <LOOKUP <2 .OBJ>
38 <SET IFL (<2 .OBJ> !.IFL)>
41 <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
45 (<==? .FROB IFCANNOT!-MIMOP>
50 <NOT <GASSIGNED? .ATM>>>
51 <SET IFL (<2 .OBJ> !.IFL)>
54 <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
58 (<==? .FROB ENDIF!-MIMOP>
59 <COND (<OR <EMPTY? .IFL>
60 <N=? <2 .OBJ> <1 .IFL>>>
61 <ERROR UNMATCHED-IFSYS!-ERRORS
63 (<SET IFL <REST .IFL>>
72 <PUTREST .LL <SET L <REST .L>>>)>)
78 <DEFINE FLUSH-TO-ENDIF (FLG L LL "AUX" THING (CT 1))
82 <ERROR MISSING-ENDIF!-ERRORS .FLG>
85 <COND (<AND <TYPE? .THING FORM>
87 <COND (<==? <1 .THING> ENDIF!-MIMOP>
88 <COND (<0? <SET CT <- .CT 1>>>
89 <PUTREST .LL <REST .L>>
91 (<OR <==? <1 .THING> IFSYS!-MIMOP>
92 <==? <1 .THING> IFCAN!-MIMOP>
93 <==? <1 .THING> IFCANNOT!-MIMOP>>
94 <SET CT <+ .CT 1>>)>)>
97 <DEFINE FUDGE-MIMOP (FRM "AUX" NATM)
99 <COND (<SET NATM <LOOKUP <SPNAME <1 .FRM>> ,MIMOP-OBLIST>>
100 <PUT .FRM 1 .NATM>)>>
102 <DEFINE PRE-HACK (L "AUX" LR)
105 #DECL ((WIN) <OR ATOM FALSE>)
109 <FUNCTION (LL "AUX" (FRM <1 .LL>) M N I LBL)
110 #DECL ((FRM) <OR FORM ATOM> (M) <OR FALSE LIST> (LBL) ATOM
111 (N) <OR FALSE LIST> (I) FORM (LL) LIST)
112 <COND (<TYPE? .FRM ATOM> <MAPRET>)
113 (<==? <1 .FRM> OPT-DISPATCH!-MIMOP>
114 <MAPRET !<REST .FRM 3>>)
115 (<OR <SET M <MEMQ + .FRM>> <SET M <MEMQ - .FRM>>>
116 <COND (<SET N <MEMQ <SET LBL <2 .M>> .L>>)
117 (T <MIMOCERR BAD-LABEL!-ERRORS .LBL>)>
118 <COND (<==? <1 <SET I <NEXTINS .N>>> JUMP!-MIMOP>
121 (<AND <==? <1 .FRM> JUMP!-MIMOP>
126 (<==? <1 .FRM> ICALL!-MIMOP> <MAPRET <2 .FRM>>)
129 <REPEAT ((L .L) (OL .L) ITM)
130 #DECL ((L OL) LIST (ITM) ANY)
131 <COND (<EMPTY? .L> <RETURN>)
132 (<AND <TYPE? <1 .L> ATOM> <NOT <MEMQ <1 .L> .LR>>>
133 <PUTREST .OL <REST .L>>
135 (<AND <TYPE? <SET ITM <1 .L>> FORM>
137 <TYPE? <SET ITM <1 .OL>> FORM>
139 <PUTREST .OL <REST .L>>
141 (<AND <TYPE? <SET ITM <1 .L>> FORM>
144 <==? <2 .L> <3 .ITM>>>
145 <PUTREST .OL <REST .L>>
147 (<AND <TYPE? <SET ITM <1 .L>> FORM>
150 <NOT <TYPE? <2 .L> ATOM>>>
151 <PUTREST .L <REST .L 2>>
159 <DEFINE FIXIT (LST "AUX" LABS)
161 <SETG COMPERR-FLAG <>>
162 <SETG UNWCNT-FLAG <>>
163 <AND ,USE-PRE <PRE-HACK .LST>>
164 <REPLACE-LOOP-BRANCHES .LST>
165 <SET LABS <FIND-DUAL-LABELS .LST>>
166 <SET LABS (UNWCONT TUNWCNT COMPERR TCOMPERR !.LABS)>
167 <FLUSH-DUAL-LABELS .LST .LABS>
169 <PUTREST <REST .LST <- <LENGTH .LST> 1>>
170 (TCOMPERR '<COMPERR!-MIMOP>)>)>
172 <PUTREST <REST .LST <- <LENGTH .LST> 1>>
173 (TUNWCNT '<UNWCNT!-MIMOP>)>)>
180 #DECL ((ITM) <OR ATOM FORM>)
181 <COND (<TYPE? .ITM FORM> <MAPLEAVE .ITM>)>>
184 <DEFINE FIND-DUAL-LABELS (LST "AUX" (PPTR .LST) (NPTR <REST .LST>))
188 <COND (<AND <TYPE? <SET L1 <1 .PPTR>> ATOM>
189 <TYPE? <SET L2 <1 .NPTR>> ATOM>>
190 <PUTREST .PPTR <REST .NPTR>>
191 <COND (<EMPTY? <SET NPTR <REST .PPTR>>>
195 <COND (<EMPTY? <SET NPTR <REST .PPTR>>> <MAPSTOP>)>
198 <DEFINE FLUSH-DUAL-LABELS (LST LABS "AUX" PITEM FLAB PLAB)
199 #DECL ((LST) LIST (LABS) <LIST [REST ATOM]>
200 (PITEM) <OR ATOM <PRIMTYPE LIST>>)
203 <COND (<AND <TYPE? .ITEM FORM>
204 <OR <SET PITEM <MEMQ + .ITEM>>
205 <SET PITEM <MEMQ - .ITEM>>
206 <AND <NOT <EMPTY? .ITEM>>
208 <NTH .ITEM <LENGTH .ITEM>>>
210 <OR <SET PITEM <MEMQ + .PITEM>>
211 <SET PITEM <MEMQ - .PITEM>>>>>
212 <SET FLAB <DMEMQ <2 .PITEM> .LABS>>>
214 <COND (<==? .PLAB TCOMPERR> <SETG COMPERR-FLAG T>)>
215 <COND (<==? .PLAB TUNWCNT> <SETG UNWCNT-FLAG T>)>
216 <PUT .PITEM 2 <2 .FLAB>>)>>
219 <DEFINE REPLACE-LOOP-BRANCHES (CODE "AUX" (LOOPS ()))
221 <REPEAT ((PTR .CODE) ITM RBRANCH LAB NLAB RPTR)
222 <COND (<EMPTY? .PTR> <RETURN>)>
223 <COND (<TYPE? <SET ITM <1 .PTR>> FORM>
224 <COND (<AND <==? <1 .ITM> LOOP!-MIMOP>
225 <G? <LENGTH .ITM> 1>>
226 <SET LOOPS (<2 .PTR> !.LOOPS)>
227 <SET PTR <REST .PTR 2>>)
228 (<==? <1 .ITM> DISPATCH!-MIMOP>
229 <HACK-DISPATCH-LABELS .PTR .LOOPS>
230 <SET PTR <REST .PTR>>)
231 (<AND <OR <SET RBRANCH <MEMQ + .ITM>>
232 <SET RBRANCH <MEMQ - .ITM>>
233 <AND <TYPE? <SET RBRANCH
237 <OR <SET RBRANCH <MEMQ + .RBRANCH>>
239 <MEMQ - .RBRANCH>>>>>
240 <MEMQ <SET LAB <2 .RBRANCH>> .LOOPS>
241 <N==? <1 .ITM> JUMP!-MIMOP>>
242 <SET NLAB <MAKE-LABEL "UNLOOP">>
243 <PUT .RBRANCH 2 .NLAB>
244 <COND (<==? <1 .RBRANCH> -> <PUT .RBRANCH 1 +>)
245 (<PUT .RBRANCH 1 ->)>
246 <SET RPTR <REST .PTR>>
247 <PUTREST .PTR (<FORM JUMP!-MIMOP + .LAB> .NLAB)>
248 <PUTREST <REST .PTR 2> .RPTR>
249 <SET PTR <REST .PTR 3>>)
250 (<SET PTR <REST .PTR>>)>)
251 (<SET PTR <REST .PTR>>)>>>
253 <DEFINE HACK-DISPATCH-LABELS (PTR LOOPS "AUX" (DEFLBL <>) (ANY? <>))
254 #DECL ((PTR LOOPS) LIST (DEFLBL) <OR ATOM FALSE> (ANY?) <OR LIST FALSE>)
255 <COND (<TYPE? <2 .PTR> ATOM>
256 <SET DEFLBL <2 .PTR>>)>
258 <FUNCTION (NP "AUX" (LBL <1 .NP>) NL)
259 #DECL ((NP) LIST (NL LBL) ATOM)
260 <COND (<MEMQ .LBL .LOOPS>
261 ; "We have to put in funny jumps, so the default case must become
265 ; "Make sure we have a label to jump to"
266 <PUTREST .PTR (<SET DEFLBL <MAKE-LABEL "DEFCASE">>
270 <SET ANY? (<FORM JUMP!-MIMOP + .DEFLBL>
272 <SET NL <MAKE-LABEL "LCASE">>
274 (.NL <FORM JUMP!-MIMOP + .LBL> !<REST .ANY?>)>
276 ; "Find any other frobs to same place"
277 <REPEAT ((L <REST .NP>))
278 <COND (<SET L <MEMQ .LBL .L>>
284 #DECL ((X) ATOM (L) <LIST [REST ATOM]>)
286 <COND (<EMPTY? .L> <RETURN <>>)
287 (<==? .X <1 .L>> <RETURN .L>)
288 (<SET L <REST .L 2>>)>>>
290 <DEFINE PRINT-MIM-CODE (LST
291 "OPTIONAL" (OUTCHAN .OUTCHAN)
292 "AUX" (OBLIST (,MIMOP-OBLIST !.OBLIST)))
293 #DECL ((LST) LIST (OBLIST) <SPECIAL LIST> (OUTCHAN) <SPECIAL CHANNEL>)
298 <COND (<TYPE? .X ATOM> <PRIN1 .X>)
299 (ELSE <PRINC " "> <PRIN1 .X>)>
303 <GDECL (GLUE-FCNS) <LIST [REST ATOM]>>
305 <GDECL (INCHANS) <LIST [REST CHANNEL]>>
307 <DEFINE FINISH-FILE (READ-INFO OUTCHAN EXPFLOAD "AUX" (IND '(1))
308 (EXPSPLICE <AND <ASSIGNED? EXPSPLICE> .EXPSPLICE>) TMP
309 (INCHAN <RI-CHANNEL .READ-INFO>) ST)
310 #DECL ((READ-INFO) TUPLE (OUTCHAN) <SPECIAL <OR CHANNEL FALSE>>
311 (EXPSPLICE EXPFLOAD) <OR ATOM FALSE> (INCHAN) <SPECIAL CHANNEL>)
313 <COND (<==? <SET ITM <READ-INTERNAL .READ-INFO '.IND>> .IND>
314 <COND (<EMPTY? <SETG INCHANS <REST ,INCHANS>>>
317 <CLOSE <SET-RI-CHANNEL .READ-INFO <SET INCHAN <1 ,INCHANS>>>>
319 <COND (<NOT <OR <TYPE? .ITM STRING CHARACTER FIX>
320 <AND <TYPE? .ITM ATOM>
321 <=? <SPNAME .ITM> "
\f">>>>
322 <COND (<AND <TYPE? .ITM FORM>
323 <NOT <LENGTH? .ITM 2>>
324 <MEMBER <SPNAME <1 .ITM>> '["FCN" "GFCN"]>>
326 <COND (<TYPE? .ITM WORD>
327 ; "Copy the new hash code over to the msubr file."
329 <SETG LAST-HASH .ITM>
330 <COND (<NOT ,INT-MODE>
331 <SET ST <UNPARSE .ITM>>
332 <PRINC "#WORD
\1a*" .OUTCHAN>
333 <PRINTSTRING <REST .ST 7> .OUTCHAN
340 <COND (<==? <1 .ITM> FLOAD>
341 <SET NCH <OPEN "READ" !<REST .ITM>>>)
342 (<==? <1 .ITM> L-FLOAD>
343 <SET NCH <L-OPEN <2 .ITM>>>)>>
345 <SET-RI-CHANNEL .READ-INFO <SET INCHAN .NCH>>
346 <SETG INCHANS (.NCH !,INCHANS)>)
348 <COND (<AND <TYPE? .ITM FORM>
350 <COND (<==? <1 .ITM> NEW-CHANNEL-TYPE>
351 <SET TMP <EVAL <FORM NCT-NEW !<REST .ITM>>>>)
352 (<AND <MEMQ <1 .ITM> '[INCLUDE-WHEN USE-WHEN]>
353 <NOT <LENGTH? .ITM 1>>
354 <TYPE? <2 .ITM> FORM>
355 <NOT <EMPTY? <2 .ITM>>>
356 <==? <1 <2 .ITM>> COMPILING?>>
357 <SET TMP <EVAL .ITM>>
358 <1 <2 .ITM> DEBUGGING?>)
360 <SET TMP <EVAL .ITM>>)>)
362 <SET TMP <EVAL .ITM>>)>
365 <PRINTTYPE ATOM ,ATOM-PRINT>
366 <PRINTTYPE LVAL ,ATOM-PRINT>
367 <PRINTTYPE GVAL ,ATOM-PRINT>)>
368 <COND (<AND .EXPSPLICE <TYPE? .TMP SPLICE>>
378 <PRINTTYPE ATOM ,PRINT>
379 <PRINTTYPE LVAL ,PRINT>
380 <PRINTTYPE GVAL ,PRINT>)>)>)>)>>>
382 <GDECL (LAST-HASH) <OR FALSE WORD>>
384 <DEFINE FILE-PASS1 (NAMES READ-INFO OCH PMCH AMCH AACH EXPFLOAD
385 "AUX" LST NOFF ITM (STARCPU 0.0000000) (NM2 "MIMA")
386 (PRE-CH <>) (INDEX ()) (RREDO ()))
387 #DECL ((OCH) CHANNEL (PMCH AMCH AACH) <OR FALSE CHANNEL>
388 (LST) <LIST [REST <OR ATOM FORM>]> (NM2) <SPECIAL STRING>
389 (NAMES) <<PRIMTYPE VECTOR> [REST STRING]> (READ-INFO) TUPLE
394 <COND (<AND <NOT ,GLUE>
395 <ASSIGNED? PRECOMPILED>
400 <PRINT-MANY .OUTCHAN PRINC "Precompilation from "
401 <CHANNEL-OP .PRE-CH NAME>>
402 <SET INDEX <BUILD-INDEX .PRE-CH ,FCN-OBL>>
403 <COND (<AND <ASSIGNED? REDO>
407 <FUNCTION (X) <SPNAME .X>>
409 <REPEAT READIT (NAME ITM (CH <>) COMPILER-INPUT OLD-FCN)
410 #DECL ((COMPILER-INPUT) <SPECIAL CHANNEL>
411 (OLD-FCN) <OR FALSE LIST>)
414 <AND .CH <CLOSE .CH>>
415 <COND (<EMPTY? .NAMES> <RETURN>)>
416 <COND (<NOT <SET CH <OPEN "READ" <1 .NAMES>>>>
420 <SET COMPILER-INPUT .CH>
421 <SET-RI-CHANNEL .READ-INFO .CH>
422 <SET NAMES <REST .NAMES>>
426 <FINISH-FILE .READ-INFO
427 <COND (<NOT ,GLUE> .OCH)>
432 <SET CH <1 ,INCHANS>>
433 <SETG FCN-COUNT <+ ,FCN-COUNT 1>>
434 <COND (<=? <SPNAME <1 .ITM>> "FCN">
435 <PUT .ITM 1 FCN!-MIMOP>)
436 (<PUT .ITM 1 GFCN!-MIMOP>)>
439 <IO-TIMER <SKIP .READ-INFO>>
440 <COND (<==? <1 .ITM> GFCN!-MIMOP>
441 <SETG GLUE-FCNS (.NAME !,GLUE-FCNS)>)>)
445 <NOT <MEMBER <SPNAME .NAME> .RREDO>>
447 <FIND-OLD-FCN .NAME .INDEX>>
448 <OR <L? <LENGTH .OLD-FCN> 4>
449 <==? <4 .OLD-FCN> ,LAST-HASH>>>
450 ; "Skip if have precompiled, fcn is not
451 in redo list, is in index (--> in precompiled),
452 and either doesn't have hash or has right
456 <PRINC "Skipping function " .OUTCHAN>
457 <PRIN1 .NAME .OUTCHAN>)>
460 <COPY-OLD-FCN .OLD-FCN .PRE-CH .OCH>
461 <SET-RI-CHANNEL .READ-INFO <>>
462 <SKIP-MIMA .CH .NAME>
463 <SET-RI-CHANNEL .READ-INFO .CH>>>)
465 <COND (<AND ,WARN-PRINT ,VERBOSE?>
467 <PRINC "Compiling: ">
469 <IO-TIMER <SET LST <READIN .READ-INFO .ITM>>>
472 <AND .PMCH <PRINT-MIM-CODE .LST .PMCH>>
474 <AND .AMCH <PRINT-GEN-INST .AMCH>>
475 <SET NAME ,FUNCTION-NAME>
476 <ASSEMBLE-CODE 0 .NAME>
484 <PRINT-FINAL-INST .AACH>)>>
485 <SETG INTERNAL-MSUBR-NAME
486 <GEN-NAME ,FUNCTION-NAME>>
488 <PRINTTYPE ATOM ,ATOM-PRINT>
489 <PRINTTYPE LVAL ,ATOM-PRINT>
490 <PRINTTYPE GVAL ,ATOM-PRINT>)>
493 <PRINT-MSUBR 0 .OCH>>>
496 <PRINT-RSUBR-STATS .STARCPU 0>>
498 <PRINTTYPE ATOM ,PRINT>
499 <PRINTTYPE LVAL ,PRINT>
500 <PRINTTYPE GVAL ,PRINT>)>)>)>)>>>
502 <DEFMAC IO-TIMER ('THING)
503 <FORM BIND ((STARCPU '<TIME>) VAL)
504 <FORM SET VAL .THING>
505 '<SETG IO-TIME <+ ,IO-TIME <- <TIME> .STARCPU>>>
509 <DEFINE FILE-PASS2 (NAMES READ-INFO OCH PMCH AMCH AACH EXPFLOAD
510 "AUX" LST NOFF ITM (STARCPU 0.0000000) (NM2 "MIMA")
511 (REDEFINE T) (PASS2? T))
512 #DECL ((OCH) CHANNEL (PMCH AMCH AACH) <OR FALSE CHANNEL>
513 (LST) <LIST [REST <OR ATOM FORM>]> (READ-INFO) TUPLE
514 (NM2) <SPECIAL STRING> (NAMES) <<PRIMTYPE VECTOR> [REST STRING]>
515 (PASS2? REDEFINE) <SPECIAL ATOM>)
517 <SETG FIRST-FCN-ACCESS <>>
518 <SETG FIRST-FCN-OBLIST ()>
519 <REPEAT READIT (NAME (FIRST T) (OFF 0) (CH <>) (END T) ARES
521 #DECL ((ARES) <LIST [2 FIX]> (COMPILER-INPUT) <SPECIAL CHANNEL>)
522 <COND (<0? ,FCN-COUNT>
523 <COND (<SET CH2 <OPEN "PRINT" ""
524 <CHANNEL-OP .OCH NM1>
525 <IFSYS ("TOPS20" "VSUBR")
527 <CHANNEL-OP .OCH DEV>
528 <CHANNEL-OP .OCH SNM>>>
529 <PROG ((OBLIST ,FIRST-FCN-OBLIST))
530 #DECL ((OBLIST) <SPECIAL OBLIST>)
533 <COND (,FIRST-FCN-ACCESS
535 <DO-FILE-COPY .OCH .CH2 ,FIRST-FCN-ACCESS>>)>
537 <PRINTTYPE ATOM ,ATOM-PRINT>
538 <PRINTTYPE LVAL ,ATOM-PRINT>
539 <PRINTTYPE GVAL ,ATOM-PRINT>)>
540 <IO-TIMER <PRINT-IMSUBR .CH2>>
541 <COND (.AACH <IO-TIMER <PRINT-FINAL-INST .AACH>>)>
543 <PRINTTYPE ATOM ,PRINT>
544 <PRINTTYPE LVAL ,PRINT>
545 <PRINTTYPE GVAL ,PRINT>)>
546 <IO-TIMER <DO-FILE-COPY .OCH .CH2 -1>>>
549 (<ERROR CANT-OPEN-MSUBR-FILE .CH2 FILE-PASS2>)>)>
551 <AND .CH <CLOSE .CH>>
552 <COND (<EMPTY? .NAMES>
555 <COND (<NOT <SET CH <OPEN "READ" <1 .NAMES>>>>
559 <SET COMPILER-INPUT .CH>
560 <SET-RI-CHANNEL .READ-INFO .CH>
561 <SET NAMES <REST .NAMES>>
563 <COND (<NOT <SET ITM <IO-TIMER <FINISH-FILE .READ-INFO .OCH .EXPFLOAD>>>>
567 <SET CH <1 ,INCHANS>>
568 <SETG FCN-COUNT <- ,FCN-COUNT 1>>
570 <SETG FIRST-FCN-ACCESS <ACCESS .OCH>>
571 <SETG FIRST-FCN-OBLIST .OBLIST>)>
572 <COND (<=? <SPNAME <1 .ITM>> "FCN">
573 <PUT .ITM 1 FCN!-MIMOP>)
574 (<PUT .ITM 1 GFCN!-MIMOP>)>
575 <COND (<AND ,VERBOSE? ,WARN-PRINT>
577 <PRINC "Compiling: ">
579 <IO-TIMER <SET LST <READIN .READ-INFO .ITM>>>
583 <AND .AMCH <PRINT-GEN-INST .AMCH>>
584 <SET NAME ,FUNCTION-NAME>
586 <SETG INTERNAL-MSUBR-NAME <GEN-NAME .NAME>>>
587 <SET ARES <ASSEMBLE-CODE .OFF .NAME>>
591 <PRINTTYPE ATOM ,ATOM-PRINT>
592 <PRINTTYPE LVAL ,ATOM-PRINT>
593 <PRINTTYPE GVAL ,ATOM-PRINT>)>
594 <IO-TIMER <PRINT-MSUBR .OFF .OCH>>
596 <PRINTTYPE ATOM ,PRINT>
597 <PRINTTYPE LVAL ,PRINT>
598 <PRINTTYPE GVAL ,PRINT>)>
600 <AND ,WARN-PRINT ,VERBOSE?
601 <PRINT-RSUBR-STATS .STARCPU .OFF>>
604 <DEFINE PRINT-RSUBR-STATS (STARCPU OFF "AUX" (OUTCHAN .OUTCHAN))
605 #DECL ((STARCPU) FLOAT (OFF) FIX)
606 <PRINT-MANY .OUTCHAN PRINC " " <- <TIME> .STARCPU>
607 " / " <- <* ,FBYTE-OFFSET 4> .OFF>>>
609 <DEFINE GEN-NAME (NAME "AUX" ISTR)
613 <FCN (X "AUX" (VAL <ASCII .X>))
614 <COND (<AND <G=? .VAL <ASCII !\A>>
615 <L=? .VAL <ASCII !\Z>>>
616 <ASCII <+ .VAL <- <ASCII !\a> <ASCII !\A>>>>)
619 <PARSE <STRING .ISTR "-IMSUBR">>>
621 <DEFINE ATOM-PRINT (ATM "AUX" (SPN <SPNAME <CHTYPE .ATM ATOM>>)
623 #DECL ((ATM) <OR ATOM LVAL GVAL> (SPN) STRING)
624 <COND (<AND <NOT <LENGTH? .SPN 2>>
627 <IPRINC <REST .SPN 2> .OUTCHAN <NOT ,BOOT-MODE> <TYPE .ATM>>)
628 (<AND <OR <==? <OBLIST? .ATM> <ROOT>>
629 <MEMBER .SPN ,ROOT-ATOMS>
630 <AND <==? <OBLIST? .ATM> ,MIMOP-OBLIST>
631 <LOOKUP .SPN <ROOT>>>>
633 <IPRINC .SPN .OUTCHAN T <TYPE .ATM>>)
634 (T <IPRINC .SPN .OUTCHAN <> <TYPE .ATM>>)>
639 <GDECL (FOOSTR) STRING>
641 <GDECL (GC-COUNT) FIX (IO-TIME) FLOAT>
643 <DEFINE FILE-MIMOC (OUTNAME PML AML AAL
645 "AUX" CH OCH (PMCH <>) (AMCH <>) (AACH <>)
647 (READ-INFO <ITUPLE 9 <>>)
649 #DECL ((NAME) STRING)
652 <INIT-RI .READ-INFO <> 2560 ,MIMOC-READ-TABLE>
654 #DECL ((NM2) <SPECIAL STRING>)
655 <COND (<AND <ASSIGNED? PRECOMPILED>
661 <COND (<NOT <TYPE? .PRECOMPILED STRING>>
662 <SETG PRE-CH <OPEN "READ" .OUTNAME>>)
664 <SETG PRE-CH <OPEN "READ" .PRECOMPILED>>)>)>
665 <COND (<AND <ASSIGNED? AUTO-PRECOMP>
668 ; "Have precompiled, and don't necessarily want to
671 <COND (<AND <SET OCH <OPEN "READ" .OUTNAME>>
672 <L=? <CHANNEL-OP .OCH WRITE-DATE>
673 <CHANNEL-OP ,PRE-CH WRITE-DATE>>>
674 ; "Have existing msubr, and it's later"
675 <PRINT-MANY ,OUTCHAN PRINC
677 <CHANNEL-OP .OCH NAME>
691 <SET NM2 "MSUBR">)>)>
692 <OR <SET OCH <OPEN "PRINT" .OUTNAME>>
693 <ERROR .OCH OUTPUT FILE-MIMOC>>
696 <OR <SET PMCH <OPEN "PRINT" .OUTNAME>>
697 <ERROR .PMCH PRINT-MIM FILE-MIMOC>>>
700 <OR <SET AMCH <OPEN "PRINT" .OUTNAME>>
701 <ERROR .AMCH PRINT-MIM FILE-MIMOC>>>
704 <OR <SET AACH <OPEN "PRINT" .OUTNAME>>
705 <ERROR .AACH PRINT-MIM FILE-MIMOC>>>>
707 <UNWIND <PROG ((STARCPU <FIX <+ <TIME> 0.5>>) (GCTIME 0.0000000)
708 (EXPFLOAD <AND <ASSIGNED? EXPFLOAD> .EXPFLOAD>))
709 #DECL ((STARCPU) <SPECIAL FIX> (GCTIME) <SPECIAL FLOAT>)
712 <ON <HANDLER "GC" ,COUNT-GCS 10>>>)>
715 <SET SAVED-OBLIST <LIST !.OBLIST>>
716 <FILE-PASS1 .NAMES .READ-INFO
717 .OCH .PMCH .AMCH .AACH .EXPFLOAD>
718 <BLOCK .SAVED-OBLIST>
719 <AND ,GLUE <FILE-PASS2 .NAMES .READ-INFO
720 .OCH .PMCH .AMCH .AACH
727 <AND .PMCH <CLOSE .PMCH>>
728 <AND .AMCH <CLOSE .AMCH>>
729 <AND .AACH <CLOSE .AACH>>
731 <AND .GC-HANDLER <OFF .GC-HANDLER>>
732 <COND (,WARN-PRINT <PRINTSTATS>)>
737 (<AND <RI-CHANNEL .READ-INFO>
738 <CHANNEL-OPEN? <RI-CHANNEL .READ-INFO>>>
739 <CLOSE <RI-CHANNEL .READ-INFO>>)>
741 (<GASSIGNED? INCHANS>
745 <COND (<CHANNEL-OPEN? .X>
749 <AND .PMCH <CLOSE .PMCH>>
750 <AND .AMCH <CLOSE .AMCH>>
751 <AND .AACH <CLOSE .AACH>>)>
752 <AND .GC-HANDLER <OFF .GC-HANDLER>>>>>
754 <DEFINE PRINFILE (CH "AUX" (OUTCHAN ,OUTCHAN))
759 <PRINT-MANY .OUTCHAN PRINC <COND (<NOT ,GLUE>
761 (<AND <ASSIGNED? PASS2?> .PASS2?>
765 <CHANNEL-OP .CH NAME>>)>>
767 <DEFINE PRINTSTATS ("AUX" (ECPU <FIX <+ <TIME> 0.5>>) (OUTCHAN .OUTCHAN))
768 #DECL ((STARCPU) FIX (GCTIME) FLOAT)
770 <PRINT-MANY .OUTCHAN PRINC "Total time Used: " <- .ECPU .STARCPU>
771 " Gc Time Used: " <FIX .GCTIME> "
772 IO time: " <FIX <+ ,IO-TIME 0.5>>
774 " Total Glue Code Length: ")
782 <SETG ROOT-ATOMS ["M$$BINDID" "M$$INT-LEVEL"]>
784 <GDECL (ROOT-ATOMS) <VECTOR [REST STRING]>>
786 <DEFINE SKIP (READ-INFO)
787 #DECL ((N) FIX (READ-INFO) TUPLE)
790 <READ-INTERNAL .READ-INFO '<PROG ()
793 <COND (<AND <TYPE? .E FORM>
795 <==? <1 .E> END!-MIMOP>>
798 <SETG IP-BUFSTR <ISTRING 100>>
800 <GDECL (IP-BUFSTR) STRING>
802 <DEFINE IPRINC (X OUTCHAN
803 "OPTIONAL" (PRINT-TRAIL <>) (TYPE ATOM)
804 "AUX" (CNT 1) (STR ,IP-BUFSTR))
805 #DECL ((X) STRING (OUTCHAN) <SPECIAL CHANNEL>)
806 <COND (<==? .TYPE GVAL>
815 <COND (<NOT ,INT-MODE>
816 <PUT .STR .CNT <ASCII 92>>
817 <PUT .STR <+ .CNT 1> !\ >
818 <SET CNT <+ .CNT 2>>)>)
819 (ELSE <PUT .STR .CNT .CH> <SET CNT <+ .CNT 1>>)>>
823 <PUT .STR <+ .CNT 1> !\->
824 <SET CNT <+ .CNT 2>>)>
825 <SET STR <SUBSTRUC .STR 0 <- .CNT 1> <REST .STR <- 101 .CNT>>>>
828 <DEFINE COUNT-GCS (IGN TI "TUPLE" X)
829 #DECL ((TI GCTIME) FLOAT)
830 <SETG GC-COUNT <+ ,GC-COUNT 1>>
831 <AND <ASSIGNED? GCTIME> <SET GCTIME <+ .GCTIME .TI>>>>
833 <DEFINE DO-FILE-COPY (INCH OUCH AMT "AUX" (BUF <ISTRING 512>))
834 #DECL ((INCH OUCH) <CHANNEL 'DISK> (AMT) FIX (BUF) STRING)
835 <COND (<==? .AMT -1> <SET AMT <MIN>>)>
837 <COND (<SET CT <CHANNEL-OP .INCH READ-BUFFER .BUF <MIN 512 .AMT>>>
838 <CHANNEL-OP .OUCH WRITE-BUFFER .BUF .CT>
839 <COND (<OR <L? .CT 512>
840 <L=? <SET AMT <- .AMT .CT>> 0>>
842 (<ERROR READ-FAILED <SYS-ERR <CHANNEL-OP .INCH NAME> .CT <>>
845 <SETG CTLZ+1 <+ <SETG CTLZ 26> 1>>
847 <COND (<==? <PRIMTYPE FIX> FIX>
848 <SETG PKG-OBL <CHTYPE PACKAGE OBLIST>>)
850 <SETG PKG-OBL <GETPROP PACKAGE OBLIST>>)>
852 <DEFINE SETUP-READ-TABLE ("AUX" RT)
854 <SETG FCN-OBL <MOBLIST FOO>>
855 <SETG FCN-OBL-L (,FCN-OBL)>
856 <COND (<GASSIGNED? MIMOC-READ-TABLE>
857 <SET RT ,MIMOC-READ-TABLE>)
859 <SETG MIMOC-READ-TABLE <SET RT <IVECTOR ,CTLZ+1 <>>>>)>
860 <PUT .RT ,CTLZ+1 [<ASCII ,CTLZ> ,CTLZ T ,CTLZ-RD <>]>>
862 <SETG FIRST-PASS-SURVIVOR-GLUE <>>
864 <DEFINE CTLZ-RD (X "OPT" Y "AUX" (O .OBLIST) (OBLIST ,FCN-OBL-L))
865 #DECL ((OBLIST) <SPECIAL ANY>)
866 <COND (<NOT ,FIRST-PASS-SURVIVOR-GLUE>
868 <COND (<NOT <TYPE? <SET X <READ .X>> ATOM>>
870 #DECL ((OBLIST) <SPECIAL ANY>)
871 <ERROR BAD-CTRL-Z-USAGE-BY-MIMC .X>>)
872 (<==? .OBLIST .O> .X)
874 <SET X (.X <LIST !.O>)>
875 <COND (<NOT <MEMBER .X ,LIST-OF-FCNS>>
876 <SETG LIST-OF-FCNS (.X !,LIST-OF-FCNS)>)>
879 <DEFINE FIND-OLD-FCN (NAME INDEX "AUX" (SPN <SPNAME .NAME>))
880 #DECL ((NAME) ATOM (INDEX) <LIST [REST LIST]>)
883 <COND (<=? .SPN <SPNAME <1 .L>>>
887 <DEFINE COPY-OLD-FCN (LIST INCH OUCH)
888 #DECL ((LIST) <LIST ATOM FIX FIX> (INCH OUCH) <CHANNEL 'DISK>)
889 <COND (<NOT <GASSIGNED? COPY-BUF>>
890 <SETG COPY-BUF <ISTRING 1024>>)>
891 <ACCESS .INCH <2 .LIST>>
893 <REPEAT ((LEN <- <3 .LIST> <2 .LIST>>) CT)
895 <SET CT <CHANNEL-OP .INCH READ-BUFFER ,COPY-BUF <MIN .LEN 1024>>>
896 <CHANNEL-OP .OUCH WRITE-BUFFER ,COPY-BUF .CT>
897 <COND (<L=? <SET LEN <- .LEN .CT>> 0>