3 <ENTRY FILE-COMPILE STATUS REDO PRECOMPILED DISOWN MACRO-COMPILE
4 REHASH-ALL MACRO-FLUSH NO-TEMP-FILE INS-LIST INS-FIX ACCESS-LIST
7 <USE "FILE-INDEX" "HASH" "CDRIVE" "COMPDEC" "ITIME" "MIMC-GRDUMP" "TTY">
9 <NEWTYPE ACCESS-LIST LIST '<<PRIMTYPE LIST> ANY FIX FIX>>
11 <NEWTYPE INS-LIST LIST>
13 <GDECL (ALL-OUT) LIST>
17 <SETG PACKAGE-OBLIST <MOBLIST PACKAGE>>
31 <SET HAIRY-ANALYSIS T>
43 "Stuff for status line"
45 <SETG STATE-TITLE "State ">
47 <MSETG H-STATE <LENGTH ,STATE-TITLE>>
51 <SETG STATE-FCN " Fcn ">
53 <MSETG H-FCN <+ <LENGTH ,STATE-FCN> ,H-STATE-LN ,H-STATE>>
57 <SETG STATE-PHASE " Phase ">
59 <MSETG H-PHASE <+ ,H-FCN ,H-FCN-LN <LENGTH ,STATE-PHASE>>>
63 <SETG STATE-CPU " Cpu ">
65 <MSETG H-CPU <+ ,H-PHASE ,H-PHASE-LN <LENGTH ,STATE-CPU>>>
69 <SETG STATE-REAL " Real ">
71 <MSETG H-REAL <+ ,H-CPU ,H-CPU-LN <LENGTH ,STATE-REAL>>>
75 <MSETG H-RATIO <+ ,H-REAL ,H-REAL-LN 1>>
79 <MSETG H-RE-ANA <+ ,H-RATIO ,H-RATIO-LN 1>>
99 <DEFINE FILE-COMPILE FCEX (INFILE
100 "OPTIONAL" (OUTFILE "") (NM2 "MUD")
101 "AUX" (STARCPU <FIX <+ <TIME> 0.5>>)
103 INCH OUTCH (TEMPCH <>) TEM (NEW-INDEX ())
106 (NO-TEMP-FILE .NO-TEMP-FILE)
107 ATOM-LIST OC FILE-DATA GC-HANDLER
108 (OBLIST .OBLIST) TMP ATL PRECH
109 (OUTCHAN .OUTCHAN) (NO-BQ <>)
110 (REDO .REDO) NM1 SNM DEV (GCTIME 0.0)
111 (I/O-TIME 0.0) (ANY-MIMAS? <>)
113 #DECL ((FCEX) <SPECIAL FRAME> (INFILE OUTFILE) STRING (REDO) LIST
114 (OUTCHAN) <SPECIAL CHANNEL> (INCH OC) <OR FALSE CHANNEL>
115 (TIXCH TEMPCH SRC-CHAN) <SPECIAL <OR CHANNEL FALSE>>
116 (OUTCH) <OR FALSE CHANNEL> (STARCPU STARR ATNUM) <SPECIAL FIX>
117 (ATOM-LIST ATL) <SPECIAL <LIST [REST <OR LIST ATOM>]>>
118 (FILE-DATA) <LIST <LIST [REST ATOM]> ATOM> (X) FLOAT
119 (REDONE) <LIST [REST LIST]> (GCTIME I/O-TIME) <SPECIAL FLOAT>
120 (NO-BQ) <SPECIAL ANY> (NM1 NM2 DEV SNM) <SPECIAL STRING>
121 (PRE-INDEX NEW-INDEX) <LIST [REST ACCESS-LIST]>
122 (OBLIST) <SPECIAL ANY>)
123 <SETG ERRORS-OCCURED <>>
125 <COND (<NOT <SET TEM <FILE-EXISTS? .INFILE>>>
126 <RETURN .TEM .FCEX>)>
127 <SET INCH <CHANNEL-OPEN PARSE .INFILE>>
128 <PRINSPEC "Input from " .INCH>
129 <SET NM1 <CHANNEL-OP .INCH NM1>>
130 ;<SET SNM <CHANNEL-OP .INCH SNM>>
131 ;<SET DEV <CHANNEL-OP .INCH DEV>>
134 <SET OUTCH <CHANNEL-OPEN PARSE .OUTFILE>>
135 <PRINSPEC "Output to " .OUTCH>
136 <COND (<NOT .NO-TEMP-FILE>
137 <REPEAT ((NM2 "TEMP")) #DECL ((NM2) <SPECIAL STRING>)
138 <COND (<SET TEMPCH <OPEN "PRINT" "">>
140 <ERROR .TEMPCH "ERRET ANYTHING TO RETRY">>
141 <PRINSPEC "Temporary output to " .TEMPCH>)>
142 <COND (<AND <ASSIGNED? PRECOMPILED>
145 <COND (<OR <AND <ASSIGNED? PRECH> .PRECH>
146 <AND <SET PRECH <OPEN "READ" .PRECOMPILED>>
147 <PRINSPEC "Will load precompile from "
150 (<=? <UNAME> "OPERATOR">
151 ; "Don't call error if running in batch mode"
152 <PRINCTHEM "Can't load precompilation from "
157 (<SET X <ERROR "Cant load precompilation"
159 "ERRET non-false to retry, false to ignore precompilation">>
160 <COND (<TYPE? .X STRING>
161 <SET PRECOMPILED .X>)>)
163 <COND (<NOT .CAREFUL> <PRINCTHEM "Bounds checking disabled." ,CRET>)>
173 <PRINCTHEM "Toodle-oo!" ,CRET>
174 <SETG COMPCHAN <SET OUTCHAN .OC>>
175 <PRINSPEC "Compilation record for: " .INCH>
176 <PRINSPEC "Output file: " .OUTCH>)>
179 <SET GC-HANDLER <ON <HANDLER "GC" ,COUNT-GCS 10>>>
181 <COND (,STATUS-LINE <UPDATE-STATUS "Load" <> <> <>>)>
182 <SET FILE-DATA <FIND-DEFINE-LOAD .INFILE .REAL-NM2>>
183 <SET I/O-TIME <- <TIME> .X>>
184 <COND (,STATUS-LINE <UPDATE-STATUS "Ordr" <> <> <>>)>
185 <PRINCTHEM "File loaded." ,CRET>
189 <COND (<OR <TYPE? ,.ATM FUNCTION>
190 <AND <TYPE? ,.ATM MACRO>
192 <TYPE? <1 ,.ATM> FUNCTION>>>
196 <COND (<NOT <EMPTY? <CHTYPE .REDO LIST>>>
200 #DECL ((L) <LIST [REST ATOM]>)
201 <PUT .L 1 <PACK-FIX .PACKAGE-MODE <1 .L>>>>
202 <CHTYPE .REDO LIST>>)>
203 <PRINCTHEM "Explicitly Recompiling " .REDO ,CRET>)>
205 (<AND <ASSIGNED? PRECOMPILED> .PRECOMPILED .PRECH>
208 <COND (,STATUS-LINE <UPDATE-STATUS "PCld" <> <> <>>)>
209 <REPEAT (THING OP ACC NM (HASH-CODE <>))
210 <SET ACC <ACCESS .PRECH>>
211 <SET THING <READ .PRECH '<RETURN>>>
213 (<AND <TYPE? .THING FORM>
214 <NOT <EMPTY? .THING>>
215 <TYPE? <SET OP <1 .THING>> ATOM>
216 <OR <=? <SPNAME .OP> "FCN"> <=? <SPNAME .OP> "GFCN">>>
217 <SKIP-MIMA .PRECH <SET NM <2 .THING>>>
218 <COND (<AND <NOT <GASSIGNED? .NM>>
219 <NOT <MEMBER "ANONF" <SPNAME .NM>>>>
221 <COND (<AND <NOT <EMPTY? .ATOM-LIST>>
222 <NOT <MEMQ .NM .REDO>>
223 <NOT <AND <GASSIGNED? .NM>
225 <N==? .HASH-CODE <HASH ,.NM>>>>>
227 (<CHTYPE (.NM .ACC <ACCESS .PRECH>
233 <PUTPROP .NM RSUB-DEC <3 .THING>>
234 <COND (<==? .NM <1 .ATOM-LIST>>
235 <SET ATOM-LIST <REST .ATOM-LIST>>
238 <REPEAT ((X .ATOM-LIST))
240 <COND (<EMPTY? <REST .X>> <RETURN>)>
241 <COND (<==? <2 .X> .NM>
242 <PUTREST .X <REST .X 2>>
245 <SET X <REST .X>>>)>)>
246 <COND (<AND .HASH-CODE <NOT <GASSIGNED? .NM>>>
248 (<AND <TYPE? .THING WORD> <NOT ,REHASH-ALL>>
249 <SET HASH-CODE <CHTYPE .THING FIX>>
251 (<NOT <AND <TYPE? .THING FORM>
252 <NOT <EMPTY? .THING>>
253 <NOT <MEMQ <1 .THING>
254 '[PACKAGE RPACKAGE ENDPACKAGE ENTRY
255 USE-WHEN USE-DEBUG INCLUDE
256 DEFINITIONS END-DEFINITIONS
258 RENTRY USE USE-DEFER USE-TOTAL
259 IMPORT-PM!- DEFINITION-MODULE!-
260 PROGRAM-MODULE!- END-MODULE!-
261 INCLUDE-DEFINITIONS!- PMEXPORT!-
262 INCLUDE-WHEN!- IMPORT-WHEN!-
264 ZSECTION!- ZZSECTION!- ZPACKAGE!-
265 ZZPACKAGE!- ZENDPACKAGE!-
266 ZENDSECTION!- ENDSECTION!- ]>>>>
267 ; "Don't eval most things in precompiled, since
268 they only screw things up."
271 <PRINCTHEM "Precompilation loaded" ,CRET>
272 <COND (<NOT .ANY-MIMAS?>
274 "No compiled functions from PRECOMPILATION used?" ,CRET>)>
276 <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>)>
277 <COND (<EMPTY? .ATOM-LIST>
278 <PRINCTHEM "No DEFINEd functions in this file." ,CRET>
280 (ELSE <SET ATOM-LIST <GETORDER !<SET ATL .ATOM-LIST>>>)>
281 <PRINCTHEM "Functions ordered." ,CRET>
282 <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>
287 <COND (<MEMQ .A .ATL> .A)
291 <FUNCTION (AL "AUX" OUTL ACC)
292 #DECL ((AL) <SPECIAL ATOM> (OUTL) <OR FALSE LIST>)
293 <SET OBLIST <FIND-OBL .AL <2 .FILE-DATA>>>
302 <COND (<NOT .NO-TEMP-FILE>
304 <SET ACC <ACCESS .TEMPCH>>
305 <DUMP-CODE .OUTL .TEMPCH .OBLIST>
307 (<CHTYPE (.AL .ACC <ACCESS .TEMPCH>
309 ACCESS-LIST> !.NEW-INDEX)>
310 <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>)
312 <SETG ALL-OUT ((.AL .OUTL <HASH ,.AL>)
315 <SETG ERRORS-OCCURED T>
318 <COND (,STATUS-LINE <UPDATE-STATUS "Writ" "None" <> <>>)>
319 <COND (<NOT .NO-TEMP-FILE>
320 <SET TMP <CHANNEL-OP .TEMPCH NAME>>
322 <SET TEMPCH <OPEN "READ" .TMP>>
325 <SETG <1 .L> .L> <PUT .L 1 .TEMPCH>> .NEW-INDEX>)
328 <MAPF <> <FUNCTION (A) #DECL ((A) LIST)
330 <CHTYPE (<3 .A> !<CHTYPE <2 .A> LIST>)
331 INS-LIST>>> ,ALL-OUT>)>
332 <COND (<AND <ASSIGNED? PRECOMPILED>
334 <PROG ((PREV <>) PN) #DECL ((PREV) <OR FALSE ACCESS-LIST>)
336 <FUNCTION (L "AUX" (ATM <1 .L>))
337 #DECL ((L) ACCESS-LIST)
338 <COND (<AND <NOT <GASSIGNED? .ATM>>
341 <PUTREST <REST .L 3> (.PREV)>
342 <COND (<AND <NOT <4 .L>> <4 .PREV>>
353 <MIMC-GROUP-DUMP .OUTFILE <2 .FILE-DATA> .TEMPCH>
354 <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>
358 <SETG COMPCHAN ,OUTCHAN>
359 <COND (<AND <ASSIGNED? TEMPCH> <TYPE? .TEMPCH CHANNEL>>
362 <COND (<AND <ASSIGNED? DISOWN> .DISOWN>
363 "Compilation completed. Your patience is godlike.")
364 (ELSE "Compilation completed. Your patience is godlike.")>>
366 <DEFINE PACK-FIX (PCK ATM
367 "AUX" (S <PNAME .ATM>) (WIN <>)
368 (PO <LOOKUP .PCK ,PACKAGE-OBLIST>))
369 <AND .PO <SET PO ,.PO>>
373 <AND <SET WIN <LOOKUP .S .O>> <MAPLEAVE>>>
375 <COND (.WIN) (.PO <INSERT .S <1 .PO>>) (ELSE .ATM)>>
377 <DEFINE LINEARIZE (ATOM-LIST) #DECL ((ATOM-LIST) LIST)
378 <REPEAT ((L <SET ATOM-LIST (START !.ATOM-LIST)>) (LL <REST .L>))
380 <COND (<EMPTY? .LL> <RETURN <REST .ATOM-LIST>>)
381 (<TYPE? <1 .LL> LIST>
383 <PUTREST <SET L <REST .L <- <LENGTH .L> 1>>>
384 <SET LL <REST .LL>>>)
385 (ELSE <SET LL <REST <SET L .LL>>>)>>>
388 <DEFINE PRINTSTATS ("AUX" (TSTARCPU <- <FIX <+ 0.5 <TIME>>>
389 <CHTYPE .STARCPU FIX>>)
390 (TSTARR <- <RTIME> <CHTYPE .STARR FIX>>))
391 #DECL ((STARCPU STARR TSTARCPU TSTARR) FIX)
392 <COND (<GASSIGNED? REFERENCED>
393 <PRINCTHEM ,CRET "Called unknown atoms:" ,CRET>
394 <REPEAT ((L:LIST ,REFERENCED))
395 <COND (<EMPTY? .L> <RETURN>)>
396 <PRINCTHEM <1 .L> ": "
397 <COND (<==? <2 .L> 1> "once")
399 <COND (<==? <2 .L> 1> "")
402 <SET L <REST .L 2>>>)>
403 <COND (<L? .TSTARR 0> ;"Went over midnight."
404 <SET TSTARR <+ .TSTARR %<* 24 60 60>>>)>
405 <PRINCTHEM ,CRET ,CRET "Total time used is" ,CRET ,TAB>
406 <PRINTIME .TSTARCPU "CPU time,">
407 <PRINCTHEM ,CRET ,TAB>
408 <PRINTIME <FIX .GCTIME> "garbage collector CPU time,">
409 <PRINCTHEM ,CRET ,TAB>
410 <PRINTIME <FIX .I/O-TIME> "I/O time.">
411 <PRINCTHEM ,CRET ,TAB>
412 <PRINTIME .TSTARR "real time.">
414 "CPU utilization is " <* 100.0 </ .TSTARCPU <FLOAT .TSTARR>>>
416 "Number of garbage collects = " ,GC-COUNT ,CRET>>
418 <DEFINE PRINTIME (AMT STR) #DECL((AMT) FIX)
419 <COND (<G? .AMT %<* 60 60>>
420 <PRINCTHEM </ .AMT %<* 60 60>> " hours ">
421 <SET AMT <MOD .AMT %<* 60 60>>>)>
423 <PRINCTHEM </ .AMT 60> " min. ">
424 <SET AMT <MOD .AMT 60>>)>
425 <PRINCTHEM .AMT " sec. " .STR>>
427 <DEFINE RTIME () <QTIME <ITIME>>>
429 <DEFINE STATUS ("AUX" FL PL ATOM-LIST-L AL-L (OUTCHAN .OUTCHAN))
430 #DECL ((ATOM-LIST-L) LIST (FL PL) FIX (OUTCHAN) <SPECIAL CHANNEL>)
431 <COND (<AND <ASSIGNED? ATOM-LIST> <ASSIGNED? AL>>
432 <SET FL <LENGTH <SET ATOM-LIST-L <CHTYPE .ATOM-LIST LIST>>>>
433 <SET PL <- .FL <LENGTH <MEMQ <SET AL-L .AL> .ATOM-LIST>>>>
434 <PRINCTHEM ,CRET "Running: " .PL " finished, working on ">
436 <PRINCTHEM ", and " <- .FL .PL 1> " to go.">
438 (<AND <ASSIGNED? STARCPU> <ASSIGNED? STARR>>
439 <COND (<NOT <ASSIGNED? FILE-DATA>>
441 Files not yet loaded.">
443 (<NOT <ASSIGNED? ATOM-LIST>>
445 Files loaded, but functions not yet ordered for compilation.">
448 Almost done, just cleaning up and writing out final file.">
450 (ELSE <PRINCTHEM ,CRET "I'm not running." ,CRET>)>>
452 <DEFINE COUNT-GCS (IGN TI WHICH)
453 <SETG GC-COUNT <+ <CHTYPE ,GC-COUNT FIX> 1>>
454 <AND <ASSIGNED? GCTIME>
455 <SET GCTIME <+ <CHTYPE .GCTIME FLOAT> <CHTYPE .TI FLOAT>>>>>
457 <GDECL (GC-COUNT) FIX>
464 <MANIFEST NOT-COMPILE-TIME>
471 <DEFMAC PRINCTHEM ("ARGS" A) #DECL ((A) LIST)
473 !<MAPF ,LIST <FUNCTION (X)
477 <DEFINE FIND-DEFINE-LOAD (FNM NM2 "AUX" GRP (OLD-FLOAD ,FLOAD))
478 #DECL ((NM2) <SPECIAL STRING>)
479 <SET GRP <GROUP-LOAD .FNM>>
480 (<1 <GET-ATOMS ..GRP>> .GRP)>
482 <DEFINE GET-ATOMS (L "AUX" (L1 .L) (AL ()) (LL ()) TEM TT MCR ATM VAL)
483 #DECL ((L AL L1 LL) LIST (TT) FORM)
486 <COND (<EMPTY? .L1> <RETURN (.AL .L)>)
487 (<AND <TYPE? <1 .L1> FORM>
488 <NOT <EMPTY? <SET TT <1 .L1>>>>>
489 <COND (<OR <==? <1 .TT> DEFINE>
490 <SET MCR <==? <1 .TT> DEFMAC>>>
491 <COND (<AND .MCR .MACRO-FLUSH>
492 <PUT .L1 1 <FORM DEFINE <ATOM "A"> ()>>)
494 <PUT .L1 1 <FORM <1 .TT> <2 .TT> <>>>)>
495 <SET ATM <GETPROP <2 .TT> VALUE '<2 .TT>>>
496 <OR <AND .MCR <NOT .MACRO-COMPILE>>
497 <SET AL (.ATM !.AL)>>)>)>
498 <SET L1 <REST .L1>>>>
500 <DEFINE NEW-ERROR (IGN FRM "TUPLE" TUP "EXTRA" (OUTCHAN ,COMPCHAN))
501 #DECL ((TUP) TUPLE (OUTCHAN) <SPECIAL ANY>)
502 <COND (<AND <NOT <EMPTY? .TUP>> <==? <1 .TUP> CONTROL-G!-ERRORS>>
505 ;"HAVE TO NEST TO TURN HANDLER ON AND OFF"
510 ***********************************************************
511 * ERROR ERROR ERROR ERROR ERROR ERROR ERROR *
512 ***********************************************************
515 <MAPF <> ,PRINT .TUP>
517 Compilation totally aborted.
523 <SETG COMPCHAN ,OUTCHAN>
525 <COND (<GASSIGNED? NEW-ERROR>
526 <SETG ERROR-HANDLER <HANDLER "ERROR" ,NEW-ERROR 100>>)>
528 <DEFINE PRINSPEC (STR CHAN) #DECL((STR) STRING (CHAN) CHANNEL)
529 <PRINCTHEM .STR <CHANNEL-OP .CHAN NAME> ,CRET>>
532 <DEFINE DO-AND-CHECK (STR1 STR2 ATM INCH OUTCH FOOCH "AUX" NEW-CHAN TSTR)
533 <COND (<AND <ASSIGNED? .ATM> ..ATM> ;"Do it?"
535 <COND ;"Yes. Get the channel."
536 (<TYPE? ..ATM CHANNEL> ;"Output channel already open."
537 <SET NEW-CHAN ..ATM>)
538 (<TYPE? ..ATM STRING> ;"Name of output file given."
539 <COND (<FILE-EXISTS? ..ATM> <DELFILE ..ATM>)>
540 <COND (<SET NEW-CHAN <OPEN "PRINT" ..ATM>>)
541 ;"So try opening it."
545 <AND .FOOCH <CLOSE .FOOCH>>
546 <RETURN .NEW-CHAN .FCEX>)>)
548 <PROG ((NM1 <CHANNEL-OP .INCH NM1>) (NM2 .STR2))
549 #DECL ((NM1 NM2) <SPECIAL STRING>)
550 <COND (<FILE-EXISTS? ""> <DELFILE "">)>
551 <COND (<SET NEW-CHAN <OPEN "PRINT" "">>)
555 <AND .FOOCH <CLOSE .FOOCH>>
556 <RETURN .NEW-CHAN .FCEX>)>>
557 <PRINSPEC "on " .NEW-CHAN>
560 <DEFINE FLUSH-COMMENTS ("AUX" (A <ASSOCIATIONS>) B)
563 <COND (<==? <INDICATOR .A> COMMENT>
564 <PUTPROP <ITEM .A> COMMENT>)>
565 <COND (<NOT <SET A .B>> <RETURN>)>>>
571 #DECL ((ATM) <UNSPECIAL ATOM>)
572 <AND <TYPE? .ATM ATOM>
574 <OR <TYPE? ,.ATM FUNCTION>
575 <TYPE? ,.ATM MACRO>>>>
577 <DEFINE PREV (LS SUBLS)
578 #DECL ((LS SUBLS) <UNSPECIAL LIST> (VALUE) LIST)
579 <REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
581 <DEFINE SPLOUTEM (FL OU)
582 #DECL ((FL) <UNSPECIAL LIST> (OU) <UNSPECIAL ATOM>)
584 #DECL ((TEM) <UNSPECIAL <PRIMTYPE LIST>>)
585 <COND (<EMPTY? .FL> <RETURN T>)
586 (<SET TEM <MEMQ .OU <1 .FL>>>
587 <COND (<==? <1 .FL> .TEM> <PUT .FL 1 <REST .TEM>>)
588 (ELSE <PUTREST <PREV <1 .FL> .TEM> <REST .TEM>>)>)>
589 <SET FL <REST .FL 2>>>>
592 #DECL ((LS) <UNSPECIAL LIST>)
593 <REPEAT ((RES ()) (TEM ()))
594 #DECL ((RES TEM) LIST)
595 <COND (<EMPTY? .LS> <RETURN .RES>)>
597 <SET RES <PUTREST .LS .RES>>
600 <DEFINE ORDEREM (FLIST)
601 #DECL ((FLIST) <UNSPECIAL LIST>)
602 <REPEAT (TEM (RES ()))
603 #DECL ((RES) <UNSPECIAL <LIST [REST <OR ATOM LIST>]>>
604 (VALUE) <LIST [REST <OR ATOM LIST>]>
605 (TEM) <UNSPECIAL <PRIMTYPE LIST>>)
607 (<EMPTY? .FLIST> <RETURN <REVERSE .RES>>)
608 (<SET TEM <MEMQ () .FLIST>>
609 <SET RES (<2 .TEM> !.RES)>
610 <COND (<==? .TEM .FLIST> <SET FLIST <REST .FLIST 2>>)
611 (ELSE <PUTREST <PREV .FLIST .TEM> <REST .TEM 2>>)>
612 <SPLOUTEM .FLIST <1 .RES>>)
614 <PROG ((RES2 ()) GOTONE)
617 <REPEAT ((RES1 .FLIST))
619 <COND (<NOT <CALLME <2 .RES1> .FLIST>>
621 <SET RES2 (<2 .RES1> !.RES2)>
622 <COND (<==? .FLIST .RES1>
623 <SET FLIST <REST .FLIST 2>>)
625 <PUTREST <PREV .FLIST .RES1>
627 <AND <EMPTY? <SET RES1 <REST .RES1 2>>> <RETURN>>>
628 <COND (.GOTONE <AGAIN>)
629 (<NOT <EMPTY? .FLIST>> <SET FLIST <CORDER .FLIST>>)>
630 <SET TEM <REVERSE .RES>>
631 <COND (<NOT <EMPTY? .FLIST>>
634 <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
637 <REST <PUTREST .RES .FLIST>
638 <LENGTH .FLIST>>>)>)>
639 <COND (<EMPTY? .RES> <SET RES .RES2>)
640 (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
643 <DEFINE CALLME (ATM LST)
644 #DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
646 <AND <EMPTY? .LST> <RETURN <>>>
647 <AND <MEMQ .ATM <1 .LST>> <RETURN>>
648 <SET LST <REST .LST 2>>>>
650 <DEFINE CORDER (LST "AUX" (RES ()))
651 #DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
653 #DECL ((LS) <LIST [REST LIST ATOM]>)
654 <AND <EMPTY? .LS> <RETURN>>
655 <PUT .LS 1 <ALLREACH (<2 .LS>) <1 .LS> .LST>>
656 <SET LS <REST .LS 2>>>
658 #DECL ((PNT) <LIST [REST LIST ATOM]>)
659 <REPEAT ((SHORT <CHTYPE <MIN> FIX>) (TL 0) (LST .LST))
660 #DECL ((SHORT TL) FIX (LST) <LIST [REST LIST ATOM]>)
661 <AND <EMPTY? .LST> <RETURN>>
662 <COND (<L? <SET TL <LENGTH <1 .LST>>> .SHORT>
665 <SET LST <REST .LST 2>>>
667 (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
670 <MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
672 <COND (<SET TEM <MEMQ () .LST>>
673 <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
675 <PUTREST <PREV .LST .TEM>
678 <AND <EMPTY? .LST> <RETURN>>>
681 <DEFINE ALLREACH (LATM LST MLST)
682 #DECL ((LATM LST) <LIST [REST ATOM]>
683 (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
687 <COND (<MEMQ .ATM .LATM>)
690 <ALLREACH (.ATM !.LATM)
692 #DECL ((L) <LIST [REST LIST ATOM]>)
693 <AND <==? <2 .L> .ATM>
700 <DEFINE REMEMIT (ATM)
701 #DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
702 (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
705 <SET FUNCL (.ATM !.FUNCL)>>>
707 <DEFINE FINDREC (OBJ "AUX" (FM '<>))
709 <COND (<MONAD? .OBJ>)
710 (<AND <TYPE? .OBJ FORM SEGMENT>
711 <NOT <EMPTY? <SET FM <CHTYPE .OBJ FORM>>>>>
712 <COND (<AND <TYPE? <1 .FM> ATOM> <GASSIGNED? <1 .FM>>>
713 <AND <TYPE? ,<1 .FM> FUNCTION> <REMEMIT <1 .FM>>>
714 <AND <TYPE? ,<1 .FM> MACRO>
715 <NOT <EMPTY? ,<1 .FM>>>
716 <FINDREC <EMACRO .FM>>>
717 ;"Analyze expansion of MACRO call"
718 <AND <OR <==? ,<1 .FM> ,MAPF> <==? ,<1 .FM> ,MAPR>>
719 <NOT <LENGTH? .FM 3>>
721 <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
724 <AND <TYPE? <3 .FM> FORM>
725 <CHK-GVAL <3 .FM>>>>>)
726 (<STRUCTURED? <1 .OBJ>> <MAPF <> ,FINDREC <1 .OBJ>>)>
727 <COND (<EMPTY? <REST .OBJ>>)
728 (ELSE <MAPF <> ,FINDREC <REST .OBJ>>)>)
729 (ELSE <MAPF <> ,FINDREC .OBJ>)>>
731 <DEFINE EMACRO (OBJ "AUX" EH TEM)
734 <FUNCTION (OBJ FRM "TUPLE" T)
735 <COND (<AND <GASSIGNED? MACACT>
737 <DISMISS [.OBJ !.T] ,MACACT>)
738 (ELSE <LISTEN !.T>)>>
741 <COND (<TYPE? <SET TEM
742 <PROG MACACT () #DECL ((MACACT) <SPECIAL ANY>)
743 <SETG MACACT .MACACT>
747 <ERROR MACRO-EXPANSION-LOSSAGE!-ERRORS !.TEM>)
748 (ELSE <OFF .EH> <1 .TEM>)>>
750 <DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
751 <AND <==? <LENGTH .FM> 2>
756 <OR <TYPE? ,<2 .FM> FUNCTION>
757 <AND <TYPE? ,<2 .FM> MACRO>
758 <NOT <EMPTY? ,<2 .FM>>>
759 <TYPE? <1 ,<2 .FM>> FUNCTION>>>
762 <DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
763 #DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
764 (VALUE) <LIST [REST ATOM]>)
768 <DEFINE FINDEMALL (ATM
773 <LIST <LIST [REST ATOM]> ATOM>)
774 <AND <EMPTY? .ATM> <RETURN .TD>>
775 <SET TD (<FINDEM <1 .ATM>> <1 .ATM> !.TD)>
776 <SET ATM <REST .ATM>>>))
777 #DECL ((ATM) <UNSPECIAL <<PRIMTYPE VECTOR> [REST ATOM]>>
778 (TOPDO) <UNSPECIAL <LIST <LIST [REST ATOM]> ATOM>>)
779 <REPEAT ((TODO .TOPDO) (CURDO <1 .TOPDO>))
780 #DECL ((TODO) <UNSPECIAL LIST>
781 (CURDO) <UNSPECIAL <LIST [REST ATOM]>>)
782 <COND (<EMPTY? .CURDO>
783 <COND (<EMPTY? <SET TODO <REST .TODO 2>>>
785 (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
786 (<MEMQ <1 .CURDO> .TOPDO>)
788 <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
789 (<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
790 <SET CURDO <REST .CURDO>>>>
792 <DEFINE GETORDER ("TUPLE" ATMS)
793 #DECL ((ATMS) <UNSPECIAL <<PRIMTYPE VECTOR> [REST ATOM]>>)
794 <COND (<NOT <MEMQ #FALSE () <MAPF ,LIST ,CHECK .ATMS>>>
795 <ORDEREM <FINDEMALL .ATMS>>)
796 (ELSE <ERROR BAD-ARG GETORDER>)>>
799 <DEFINE FIND-OBL (NM GRP "AUX" (RGRP ..GRP) (OB .OBLIST))
800 #DECL ((NM) ATOM (RGRP) LIST)
802 <FUNCTION (PTR "AUX" (IT <1 .PTR>) TMP)
803 <SET OB <GETPROP .PTR BLOCK '.OB>>
804 <COND (<AND <TYPE? .IT FORM>
806 <OR <==? <SET TMP <1 .IT>> DEFINE>
809 <GETPROP <2 .IT> VALUE '<2
817 <DEFINE UPDATE-STATUS (STATE FCN PHASE REANA
818 "OPT" (CPU <FIX <+ <TIME> 0.5>>) (REAL <RTIME>)
819 "AUX" (OUTCHAN ,OUTCHAN))
820 <COND (<NOT ,GC-USER-MON> <GC-MON ,GC-STATUS>)>
821 <COND (<NOT <GASSIGNED? STATUS-CPU>> <SETG STATUS-CPU .CPU>)>
822 <COND (<NOT <GASSIGNED? STATUS-REAL>> <SETG STATUS-REAL .REAL>)>
823 <COND (.FCN <SETG STATUS-FCN .FCN>) (ELSE <SET FCN ,STATUS-FCN>)>
824 <CHANNEL-OP .OUTCHAN HOR-POS-CURSOR 0>
825 <PRINT-MANY .OUTCHAN PRINC
827 !<STRING-FIT .STATE ,H-STATE-LN>
829 !<STRING-FIT .FCN ,H-FCN-LN>
831 !<STRING-FIT <OR .PHASE ""> ,H-PHASE-LN>
833 !<CPU-STRING <- .CPU ,STATUS-CPU>>
835 !<REAL-STRING <- .REAL ,STATUS-REAL>>
839 <COND (.REANA .REANA) (ELSE " ")>
840 <COND (,ERRORS-OCCURED "E ") (ELSE " ")>>>
842 <DEFINE GC-STATUS ("OPT" (OUT <>))
843 <COND (.OUT <CHANNEL-OP ,OUTCHAN ERASE-CHAR>)
844 (ELSE <PRINC "G" ,OUTCHAN>)>>
846 <MSETG LENGTH-BLANK 100>
848 <SETG STR-BLANK <ISTRING ,LENGTH-BLANK !\ >>
850 <DEFINE STRING-FIT SF (STR:STRING FIELD:FIX "AUX" (LN <LENGTH .STR>))
851 <COND (<==? .LN .FIELD> <MULTI-RETURN .SF .STR>)
853 <MULTI-RETURN .SF <SUBSTRUC .STR 0 .FIELD>>)
855 <MULTI-RETURN .SF .STR <REST ,STR-BLANK <- ,LENGTH-BLANK
858 <DEFINE CPU-STRING CS (CPU:FIX
859 "AUX" (COLON <>) (H:FIX </ .CPU 3600>)
860 (R:FIX <MOD .CPU 3600>) (M:FIX </ .R 60>)
863 <COND (<G? .H 10> "*:")
864 (<G? .H 0> <SET COLON T> .H)
866 <COND (.COLON ":")(ELSE "")>
869 <COND (<L? .S 10> "0") (ELSE "")>
871 <COND (<==? .H 0> " ") (ELSE "")>
872 <COND (<L? .M 10> " ") (ELSE "")>>>
874 <DEFINE REAL-STRING RS (REAL:FIX
875 "AUX" (COLON T) (H:FIX </ .REAL 3600>)
876 (R:FIX <MOD .REAL 3600>) (M:FIX </ .R 60>)
879 <COND (<G? .H 100> "**")
881 (ELSE <SET COLON <>> "")>
882 <COND (<AND <L? .H 100> <G? .H 0>> .H) (ELSE "")>
883 <COND (.COLON ":")(ELSE "")>
886 <COND (<L? .S 10> "0") (ELSE "")>
888 <COND (<G? .H 10> "")
891 <COND (<L? .M 10> " ") (ELSE "")>>>
893 <DEFINE FUNCTION-RATIO FR ("AUX" ATL:LIST LN1:FIX LN2:FIX)
894 <COND (<OR <NOT <ASSIGNED? ATOM-LIST>> <NOT <ASSIGNED? AL>>>
895 <MULTI-RETURN .FR <REST ,STR-BLANK <- ,LENGTH-BLANK
898 <SET LN1 <LENGTH <SET ATL .ATOM-LIST>>>
899 <SET LN2 <- .LN1 <LENGTH <MEMQ .AL .ATL>> -1>>
901 <COND (<G=? .LN2 100> "")
906 <COND (<G=? .LN1 100> "")