MDL 105 and 106 executables.
[pdp10-muddle.git] / <mdl.comp> / comfil.mud.3
1
2 <SETG OSETG ,SETG>
3
4 <USE "DATIME">
5
6 <USE "NOW">
7
8 <COND (<L? ,MUDDLE 100>
9        <SETG COMPILER-DIR "NCOMPI">)
10       (<SETG COMPILER-DIR "MDL.COMP">)>
11
12 <FLOAD "GETORD" "FBIN" "DSK" ,COMPILER-DIR>
13
14 <COND (<L? ,MUDDLE 100>
15        <FLOAD "NCOMPI;SNMSET FBIN">)>
16
17 <SETG WDCNTLC ![1623294726!]>
18
19 <SETG WDSPACE ![17315143744!]>
20
21
22 <SETG GC-COUNT 0>
23
24 <DEFINE FCOMP (CH "TUPLE" TUP "EXTRA" (ACC <17 .CH>) VAL)
25 ;"Called by PLANs & PCOMPs to do File Compile.
26   Tastefully Closes & Resets Channel during Compilation.
27   Calling sequence is <FCOMP %.INCHAN \"IN\" \"OUT\">"
28         #DECL ((CH) CHANNEL (TUP) TUPLE (ACC) FIX)
29         <CLOSE .CH>             ;"Flush PLAN Channel"
30         <COND  (<NOT <SET VAL <FILE-COMPILE !.TUP>>>    ;"Do It"
31                 <ERROR .VAL>)>
32         <AND <RESET .CH> <ACCESS .CH .ACC>>
33                                 ;"Restore PLAN Channel to Former Glory"
34         <MODES-INIT>            ;"Reset the Various Compiler Flags"
35         .VAL>
36
37 <DEFINE FILE-COMPILE FCEX (INFILE
38                            "OPTIONAL" OUTFILE
39                            "AUX" (INCH <OPEN "READ" .INFILE>) OUTCH TEMPCH
40                                  (STARCPU <FIX <+ <TIME> 0.5>>) (GFLG T)
41                                  (PREV ()) (STARR <RTIME:SEC>) R (TW? <G? ,MUDDLE 100>)
42                                  (SRC-CHAN #FALSE ()) (IC <>) ATOM-LIST OC SOURCE-STR
43                                  FILE-DATA GC-HANDLER OREDEFINE REDONE LOSS ATL
44                                  (GCTIME 0.0000000) (OUTCHAN .OUTCHAN) VERS)
45    #DECL ((FCEX) <SPECIAL ACTIVATION> (SOURCE-STR INFILE OUTFILE VERS) STRING
46           (TW?) <OR ATOM FALSE>
47           (OUTCHAN) <SPECIAL CHANNEL> (INCH OC IC) <OR FALSE CHANNEL>
48           (TEMPCH SRC-CHAN) <SPECIAL <OR CHANNEL FALSE>> (PREV) LIST
49           (OUTCH) <OR FALSE CHANNEL> (STARCPU STARR ATNUM) <SPECIAL FIX>
50           (ATOM-LIST ATL) <SPECIAL <LIST [REST <OR LIST ATOM>]>>
51           (FILE-DATA) <LIST <LIST [REST ATOM]> ATOM> (REDONE) <LIST [REST
52                                                                      LIST]>
53           (GCTIME) <SPECIAL FLOAT>)
54    <COND (<NOT .INCH> <RETURN #FALSE ("INPUT FILE NOT FOUND") .FCEX>)>
55    <PRINSPEC "Input from " .INCH>
56    <COND (.TW?
57           <SET VERS <REST <MEMQ !\. <8 .INCH>>>>
58           <SET VERS
59                <SUBSTRUC .VERS 0 <- <LENGTH .VERS> <LENGTH <MEMQ !\; <8 .INCH>>>>>>)>
60    <CLOSE .INCH>
61    <SET OUTCH
62         <COND (<ASSIGNED? OUTFILE> <CHANNEL "PRINT" .OUTFILE>)
63               (ELSE
64                <CHANNEL "PRINT"
65                         <SET OUTFILE
66                              <COND (.TW?
67                                     <STRING !\< <10 .INCH> !\> <7 .INCH>
68                                             ".NBIN." .VERS>)
69                                    (<STRING <10 .INCH> !\; <7 .INCH> " NBIN">)>>>)>>
70    <PRINSPEC "Output to " .OUTCH>
71    <SET SOURCE-STR <COND (.TW? <STRING "SOURCE." .VERS>)
72                          ("SOURCE")>>
73    <AND <==? .SOURCE T>
74         <SET SOURCE <OPEN "PRINT" <3 .INCH>
75                           .SOURCE-STR
76                           "DSK" <COND (.TW? <SNAME>)(ELSE "HUDINI")>>>>
77    <SET SRC-CHAN
78         <DO-AND-CHECK "Source listing generated "
79                       .SOURCE-STR
80                       SOURCE
81                       .INCH
82                       .OUTCH
83                       #FALSE ()>>
84    <COND (<AND <ASSIGNED? PRECOMPILED> <TYPE? .PRECOMPILED STRING>>
85           <COND (<SET IC <OPEN "READ" .PRECOMPILED>>
86                  <PRINSPEC "Will load precompilation from " .IC>
87                  <CLOSE .IC>)>)>
88    <COND (<NOT .CAREFUL>
89           <PRINCTHEM "Bounds checking off." ,CRET>)>
90    <COND (.SPECIAL
91           <PRINCTHEM "Default declaration is SPECIAL." ,CRET>)>
92    <COND (<NOT <EMPTY? .REDO>> <PRINC "Recompiling: "> <PRINT .REDO> <TERPRI>)>
93    <COND (.GROUP-MODE
94           <PRINC "Making a GROUP named ">
95           <PRIN1 .GROUP-MODE>
96           <TERPRI>)>
97    <COND (<NOT <ASSIGNED? TEMPNAME>>
98           <SET TEMPNAME <STRING "_" <7 .INCH> <COND (.TW? ".TEMP")
99                                                     (ELSE " >")>>>)>
100    <PRINCTHEM "Temporary output going to:  " .TEMPNAME ,CRET>
101    <COND (<SET OC
102                <DO-AND-CHECK <COND (.TW? "Writing record ")
103                                    ("Running disowned, with record ")>
104                              "RECORD"
105                              DISOWN
106                              .INCH
107                              .OUTCH
108                              .SRC-CHAN>>
109           <AND .ERROR-LOGOUT <ON "ERROR" ,ERROR-HANDLER 100>>
110           <PRINCTHEM "Toodle-oo." ,CRET>
111           <COND (<AND <NOT .TW?> <NOT <DEMON?>>> <VALRET ":PROCED
112 ">)>
113           <SETG COMPCHAN <SET OUTCHAN .OC>>
114           <PRINSPEC "Compilation record for: " .INCH>
115           <PRINSPEC "Output file:  " .OUTCH>
116           <COND (<NOT .TW?> <PRINCTHEM ,CRET "It is now " <NOW> ,CRET ,CRET>)>)>
117    <SETG GC-COUNT 0>
118    <SET GC-HANDLER <ON "GC" ,COUNT-GCS 10>>
119    <SET KEEP-FIXUPS T>
120    <SET FILE-DATA <FIND-DEFINE-LOAD .INFILE>>
121    <PRINCTHEM "File loaded." ,CRET>
122    <COND (<SET TEMPCH <OPEN "PRINTB" .TEMPNAME>>)
123          (ELSE <ERROR CANT-OPEN-TEMPORARY-FILE!-ERRORS FILE-COMPILE>)>
124    <COND
125     (.IC
126      <COND (<ASSIGNED? REDEFINE> <SET OREDEFINE .REDEFINE>)>
127      <SET REDEFINE T>
128      <RESET .IC>
129      <SET REDONE
130           <MAPR ,LIST
131                 <FUNCTION (L "AUX" (ATM <1 .L>)) 
132                         #DECL ((ATM) ATOM (L) <LIST ATOM>)
133                         <COND (.PACKAGE-MODE
134                                <SET ATM <PACK-FIX .PACKAGE-MODE .ATM>>)>
135                         <PUT .L 1 .ATM>
136                         <COND (<GASSIGNED? .ATM> (.ATM ,.ATM)) (ELSE <MAPRET>)>>
137                 .REDO>>
138      <REPEAT (F V)
139        <PRINT <SET F <READ .IC '<RETURN>>> .TEMPCH>
140        <COND (<AND <TYPE? .F FORM>
141                    <NOT <EMPTY? .F>>
142                    <OR <MEMQ <1 .F>
143                              '![PACKAGE ENDPACKAGE ENTRY USE USE-DEFER
144                                 USE-TOTAL BLOCK ENDBLOCK!]>
145                        <AND <==? <1 .F> SETG>
146                             <==? <LENGTH .F> 3>
147                             <OR <TYPE? <3 .F> RSUBR RSUBR-ENTRY>
148                                 <AND <TYPE? <SET V <3 .F>> FORM>
149                                      <G=? <LENGTH .V> 2>
150                                      <OR <==? <1 .V> RSUBR>
151                                          <==? <1 .V> RSUBR-ENTRY>
152                                          <AND <==? <1 .V> QUOTE>
153                                               <TYPE? <2 .V>
154                                                      RSUBR
155                                                      RSUBR-ENTRY>>>>>>
156                        <AND <==? <1 .F> AND>
157                             <==? <LENGTH .F> 4>
158                             <=? <2 .F> '<ASSIGNED? GLUE>>
159                             <=? <3 .F> '.GLUE>>>>
160               <SET V <EVAL .F>>
161               <COND (<AND .MAX-SPACE
162                           <TYPE? .V RSUBR RSUBR-ENTRY>
163                           <==? <LENGTH .F> 3>
164                           <TYPE? <2 .F> ATOM>
165                           <==? <2 .F> <2 .V>>>
166                      <PUT .V GLUE>
167                      <PUT .V RSUBR>
168                      <SETG <2 .F> <RSUBR [#CODE ![!] <2 .V> <3 .V>]>>)>)>>
169      <CLOSE .IC>
170      <BUFOUT .TEMPCH>
171      <MAPF <>
172            <FUNCTION (L) #DECL ((L) <LIST ATOM ANY>) <SETG <1 .L> <2 .L>>>
173            .REDONE>
174      <SET REDONE ()>
175      <PRINCTHEM "Precompilation loaded." ,CRET>
176      <COND (<ASSIGNED? OREDEFINE> <SET REDEFINE .OREDEFINE>)
177            (ELSE <UNASSIGN REDEFINE>)>)
178     (<NOT <EMPTY? .IC>>
179      <PRINCTHEM ,CRET "Precompilation file not found." ,CRET>)>
180    <PRINTB ,WDCNTLC .TEMPCH>
181    <CLOSE .TEMPCH>
182    <PUT .TEMPCH 2 "PRINTO">
183    <SET ATOM-LIST
184         <MAPF ,LIST
185               <FUNCTION (ATM) 
186                       <COND (<OR <TYPE? ,.ATM FUNCTION>
187                                  <AND <TYPE? ,.ATM MACRO>
188                                       <NOT <EMPTY? ,.ATM>>
189                                       <TYPE? <1 ,.ATM> FUNCTION>>>
190                              .ATM)
191                             (ELSE
192                              <COND (<AND .MAX-SPACE
193                                          <TYPE? ,.ATM RSUBR RSUBR-ENTRY>>
194                                     <SETG .ATM
195                                           <RSUBR [#CODE ![!] .ATM <3 ,.ATM>]>>)>
196                              <MAPRET>)>>
197               <1 .FILE-DATA>>>
198    <FLUSH-COMMENTS>
199    <COND (<EMPTY? .ATOM-LIST>
200           <PRINCTHEM "No DEFINEd functions in this file." ,CRET>
201           <SET ATOM-LIST ()>)
202          (ELSE <SET ATOM-LIST <GETORDER !<SET ATL .ATOM-LIST>>>)>
203    <PRINCTHEM "Functions ordered." ,CRET>
204    <MAPF <>
205          <FUNCTION (A) 
206                  <COND (<NOT <GASSIGNED? .A>>
207                         <PRIN1 .A>
208                         <PRINCTHEM " not REdone." ,CRET>)>>
209          .REDO>
210    <COND
211     (.GROUP-MODE
212      <AND .PACKAGE-MODE <SET GROUP-MODE <PACK-FIX .PACKAGE-MODE .GROUP-MODE>>>
213      <COND (<AND .PACKAGE-MODE <NOT .SURVIVORS>>
214             <PROG ((OBLIST .OBLIST))
215                   #DECL ((OBLIST) <SPECIAL ANY>)
216                   <PACKAGE .PACKAGE-MODE>
217                   <SET SURVIVORS
218                        <MAPF ,LIST <FUNCTION (L) <MAPRET !.L>> <2 .OBLIST>>>
219                   <ENDPACKAGE>>)
220            (<AND .PACKAGE-MODE <TYPE? .SURVIVORS LIST>>
221             <SET SURVIVORS
222                  <MAPF ,LIST
223                        <FUNCTION (A) <PACK-FIX .PACKAGE-MODE .A>>
224                        .SURVIVORS>>)>
225      <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>
226      <SET ATL <LINEARIZE .ATL>>
227      <REPEAT ((AL (START)) (AL1 <SET ATOM-LIST (START !.ATOM-LIST)>)
228               (AL2 <REST .AL1>) (AL4 .AL) AL5)
229              #DECL ((AL AL1 AL2 AL4 AL5) <LIST [REST ATOM]>)
230              <COND (<EMPTY? .AL2>
231                     <SET ATL <REST .AL4>>
232                     <SET ATOM-LIST <REST .ATOM-LIST>>
233                     <RETURN>)
234                    (<MEMQ <1 .AL2> .ATL> <SET AL2 <REST <SET AL1 .AL2>>>)
235                    (ELSE
236                     <SET AL <REST <PUTREST .AL .AL2>>>
237                     <SET AL5 <REST .AL2>>
238                     <PUTREST .AL2 ()>
239                     <PUTREST .AL1 <SET AL2 .AL5>>)>>
240      <MAPF <>
241            <FUNCTION (AL) 
242                    <APPLY ,COMPILE
243                           .AL
244                           .SRC-CHAN
245                           T
246                           .CAREFUL
247                           .SPECIAL
248                           .REASONABLE
249                           .GLUE
250                           .HAIRY-ANALYSIS
251                           .DEBUG-COMPILE>>
252            .ATL>
253      <COND (<SET LOSS
254                  <APPLY ,COMPILE-GROUP
255                         .ATOM-LIST
256                         <COND (<TYPE? .SURVIVORS LIST> .SURVIVORS)
257                               (ELSE .ATOM-LIST)>
258                         .GROUP-MODE
259                         .SRC-CHAN
260                         T
261                         .CAREFUL
262                         .SPECIAL
263                         .REASONABLE
264                         .GLUE
265                         .TEMPCH
266                         .HAIRY-ANALYSIS
267                         .DEBUG-COMPILE>>
268             <PRINC .LOSS>
269             <KILL-COMP>
270             <CLOSE .TEMPCH>
271             <PUT .TEMPCH 2 "READ">
272             <OR <RESET .TEMPCH> <ERROR WHERE-HAS-TEMP-FILE-GONE!-ERRORS>>
273             <BEGIN-HACK!-ICC!-CC!-PACKAGE "BTB">
274             <BEGIN-MHACK!-ICC!-CC!-PACKAGE>
275             <APPLY ,ASSEMBLE!-CODING!-PACKAGE .TEMPCH .OBLIST <> .SRC-CHAN>
276             <GUNASSIGN READ-TABLE>
277             <UNASSIGN READ-TABLE>)
278            (<RETURN .LOSS .FCEX>)>
279      <COND
280       (<GASSIGNED? .GROUP-MODE>
281        <MAPR <>
282         <FUNCTION (OBP "AUX" (OBJ <1 .OBP>) IT) 
283                 #DECL ((OBP) <LIST ANY>)
284                 <COND (<AND <TYPE? .OBJ FORM>
285                             <G=? <LENGTH .OBJ> 2>
286                             <OR <==? <1 .OBJ> DEFINE> <==? <1 .OBJ> DEFMAC>>>
287                        <AND .GFLG
288                             <PUT .OBP 1 <FORM SETG .GROUP-MODE ,.GROUP-MODE>>
289                             <PUTREST .OBP (.OBJ !<REST .OBP>)>>
290                        <OR <TYPE? .SURVIVORS LIST> <MAPLEAVE>>
291                        <SET OBJ <1 .OBP>>
292                        <OR .GFLG
293                            <MEMQ <SET IT <GET <2 .OBJ> VALUE '<2 .OBJ>>>
294                                  .SURVIVORS>
295                            <AND <GASSIGNED? .IT> <TYPE? ,.IT RSUBR RSUBR-ENTRY>>
296                            <COND (<EMPTY? .PREV>
297                                   <SET <2 .FILE-DATA> <REST .OBP>>)
298                                  (ELSE <SET OBP <PUTREST .PREV <REST .OBP>>>)>>
299                        <SET GFLG <>>)>
300                 <SET PREV .OBP>>
301         .<2 .FILE-DATA>>)>)
302     (ELSE
303      <AND .REASONABLE <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>>
304      <MAPF <>
305       #FUNCTION ((AL) 
306         #DECL ((AL) <SPECIAL <OR LIST ATOM>> (TEMPCH) <SPECIAL CHANNEL>)
307         <COND (<NOT .TW?> <SNAME-SETTER <COND (<TYPE? .AL LIST> <1 .AL>) (ELSE .AL)>>)>
308         <APPLY ,COMPILE
309                .AL
310                .SRC-CHAN
311                T
312                .CAREFUL
313                .SPECIAL
314                .REASONABLE
315                .GLUE
316                .HAIRY-ANALYSIS
317                .DEBUG-COMPILE>
318         <AND .SRC-CHAN
319              <PRINC ,CRET .SRC-CHAN>
320              <PRINC <ASCII 12> .SRC-CHAN>
321              <BUFOUT .SRC-CHAN>>
322         <BUFOUT .OUTCHAN>
323         <MAPF <>
324          #FUNCTION ((AT "AUX" ACC ACC2) 
325                     #DECL ((AT) ATOM (LN ACC ACC2) FIX)
326                     <BLOCK ()>
327                     <SET ACC <17 .TEMPCH>>
328                     <RESET .TEMPCH>
329                     <ACCESS .TEMPCH .ACC>
330                     <PRINT <FORM SETG .AT ,.AT> .TEMPCH>
331                     <AND .GLUE
332                          <PRINT
333                           <FORM AND
334                                 '<ASSIGNED? GLUE>
335                                 '.GLUE
336                                 <FORM PUT
337                                       <COND (<TYPE? ,.AT MACRO>
338                                              <FORM 1 <FORM GVAL .AT>>)
339                                             (<FORM GVAL .AT>)>
340                                       GLUE
341                                       <GET ,.AT GLUE>>>
342                           .TEMPCH>>
343                     <BUFOUT .TEMPCH>
344                     <PRINTB ,WDCNTLC .TEMPCH>
345                     <SET ACC2 <17 .TEMPCH>>
346                     <ACCESS .TEMPCH <- .ACC 1>>
347                     <PRINTB ,WDSPACE .TEMPCH>
348                     <ACCESS .TEMPCH .ACC2>
349                     <CLOSE .TEMPCH>
350                     <ENDBLOCK>
351                     <COND (<AND .MAX-SPACE <TYPE? ,.AT RSUBR RSUBR-ENTRY>>
352                            <PUT ,.AT RSUBR>
353                            <PUT ,.AT GLUE>
354                            <SETG .AT <RSUBR [#CODE ![!] .AT <3 ,.AT>]>>)>)
355          <COND (<TYPE? .AL ATOM> (.AL)) (ELSE .AL)>>)
356       .ATOM-LIST>)>
357    <COND (.MAX-SPACE
358           <PROG ((REDEFINE T))
359             #DECL ((REDEFINE) <SPECIAL ATOM>)
360             <FLOAD <7 .TEMPCH> <8 .TEMPCH> <9 .TEMPCH> <10 .TEMPCH>>>)>
361    <COND (.NILOBL <BLOCK ()>)>
362    <AND .GLUE <DOGLUE .<2 .FILE-DATA>>>
363    <OR <SET R <GROUP-DUMP .OUTFILE <2 .FILE-DATA> ,PRINT>>
364        <ERROR GROUP-DUMP .R>>
365    <COND (.NILOBL <ENDBLOCK>)>
366    <CLOSE .OUTCH>
367    <CLOSE .TEMPCH>
368    <COND (.DESTROY
369           <RENAME <FILENAME .TEMPCH>>)>
370    <PRINTSTATS>
371    <OFF .GC-HANDLER>
372    <OFF ,ERROR-HANDLER>
373    <AND .SRC-CHAN <CLOSE .SRC-CHAN>>
374    <SETG COMPCHAN ,OUTCHAN>
375    <COND (<AND <NOT .TW?> <ASSIGNED? DISOWN> .DISOWN>
376           <APPLY ,LOGOUT>
377           "So you re-owned me, eh?  I'm done anyway.")
378          (ELSE "Compilation completed. Your patience is godlike.")>>
379
380 <DEFINE DOGLUE (GRP "AUX" OBJ)
381         #DECL ((GRP) LIST)
382         <REPEAT (RSBR NXT MCR)
383                 <SET MCR <>>
384                 <COND (<EMPTY? .GRP> <RETURN>)
385                       (<AND <TYPE? <SET OBJ <1 .GRP>> FORM>
386                             <G=? <LENGTH .OBJ> 2>
387                             <MEMQ <1 .OBJ> '![DEFINE SETG DEFMAC]>
388                             <GASSIGNED? <SET OBJ <GET <2 .OBJ> VALUE '<2 .OBJ>>>>
389                             <OR <TYPE? <SET RSBR ,.OBJ> RSUBR>
390                                 <AND <TYPE? .RSBR MACRO>
391                                      <NOT <EMPTY? .RSBR>>
392                                      <TYPE? <SET RSBR <1 .RSBR>> RSUBR>
393                                      <SET MCR T>>>
394                             <GET .RSBR GLUE>>
395                             <COND (<AND <NOT <EMPTY? <REST .GRP>>>
396                                       <TYPE? <SET NXT <2 .GRP>> FORM>
397                                       <==? <LENGTH .NXT> 4>
398                                       <==? <1 .NXT> AND>
399                                       <=? <2 .NXT> '<ASSIGNED? GLUE>>
400                                       <=? <3 .NXT> '.GLUE>
401                                       <=? <2 <2 <4 .NXT>>> .OBJ>>)
402                                  (ELSE
403                                   <SET GRP <PUTREST .GRP (0 !<REST .GRP>)>>)>
404                        <COND (<==? <2 .RSBR> .OBJ>
405                               <PUT <SET GRP <REST .GRP>> 1 <FORM AND '<ASSIGNED? GLUE> 
406                                         '.GLUE
407                                         <FORM PUT <COND (.MCR <FORM 1 <FORM GVAL .OBJ>>)
408                                                         (ELSE <FORM GVAL .OBJ>)> GLUE
409                                         <GET .RSBR GLUE>>>>)
410                               (ELSE <PUTREST .GRP <REST .GRP 2>>)>)>
411                 <SET GRP <REST .GRP>>>>
412
413 <DEFINE PACK-FIX (PCK ATM
414                   "AUX" (S <PNAME .ATM>) (WIN <>)
415                         (PO <LOOKUP .PCK <GET PACKAGE OBLIST>>))
416         <AND .PO <SET PO ,.PO>>
417         <MAPF <>
418               <FUNCTION (O) 
419                       #DECL ((O) OBLIST)
420                       <AND <SET WIN <LOOKUP .S .O>> <MAPLEAVE>>>
421               .PO>
422         <COND (.WIN) (.PO <INSERT .S <1 .PO>>) (ELSE .ATM)>>
423
424 <DEFINE LINEARIZE (ATOM-LIST) #DECL ((ATOM-LIST) LIST)
425      <REPEAT ((L <SET ATOM-LIST (START !.ATOM-LIST)>) (LL <REST .L>))
426              #DECL ((L LL) LIST)
427              <COND (<EMPTY? .LL> <RETURN <REST .ATOM-LIST>>)
428                    (<TYPE? <1 .LL> LIST>
429                     <PUTREST .L <1 .LL>>
430                     <PUTREST <SET L <REST .L <- <LENGTH .L> 1>>>
431                              <SET LL <REST .LL>>>)
432                    (ELSE <SET LL <REST <SET L .LL>>>)>>>
433
434 <DEFINE NSETG (ATM VAL)
435         <COND (<NOT <MEMQ .ATM .REDO>> <OSETG .ATM .VAL>)>>
436
437
438 <DEFINE KILL-COMP ("AUX" (ENTS <LOOKUP "CC" <GET PACKAGE OBLIST>>)
439                          INTS ENTO INTO)
440         <GUNASSIGN COMPILE>
441         <GUNASSIGN COMPILE-GROUP>
442         <COND (<NOT <TYPE? ,GDECL FSUBR>>
443                <GUNASSIGN GDECL>)>
444         <COND (<NOT <TYPE? ,MANIFEST SUBR>>
445                <GUNASSIGN MANIFEST>)>
446         <COND (.ENTS <SET ENTO <PUT .ENTS OBLIST>>)>
447         <COND (<AND .ENTO <SET INTS <LOOKUP "ICC" .ENTO>>>
448                <SET INTO <PUT .INTS OBLIST>>)>
449         <COND (.ENTO <MUNGOB .ENTO>)>
450         <COND (.INTO <MUNGOB .INTO>)>
451         <COND (.ENTS <REMOVE .ENTS>)>
452         <COND (.INTS <REMOVE .INTS>)>>
453
454 <DEFINE MUNGOB (OB) #DECL ((OB) OBLIST)
455         <MAPF <>
456               <FUNCTION (L) #DECL ((L) LIST)
457                 <MAPF <>
458                       <FUNCTION (ATM)
459                         <GUNASSIGN <SET ATM <CHTYPE .ATM ATOM>>>        ; "LINKS?"
460                         <UNASSIGN .ATM>
461                         <REMOVE .ATM>> .L>> .OB>>
462
463
464 <DEFINE PRINTSTATS ("AUX" (TSTARCPU <- <FIX <+ 0.5 <TIME>>> .STARCPU>)
465                           (TSTARR <- <RTIME:SEC> .STARR>))
466         #DECL((STARCPU STARR TSTARCPU TSTARR) FIX)
467         <COND (<L? .TSTARR 0>           ;"Went over midnight."
468                 <SET TSTARR <+ .TSTARR %<* 24 60 60>>>)>
469         <PRINCTHEM ,CRET ,CRET "Total time used is" ,CRET ,TAB>
470         <PRINTIME .TSTARCPU "CPU time,">
471         <PRINCTHEM ,CRET ,TAB>
472         <PRINTIME <FIX .GCTIME> "garbage collector CPU time,">
473         <PRINCTHEM ,CRET ,TAB>
474         <PRINTIME .TSTARR "real time.">
475         <PRINCTHEM ,CRET
476                 "CPU utilization is " <* 100.0 </ .TSTARCPU <FLOAT .TSTARR>>>
477                 "%." ,CRET
478                 "Number of garbage collects = " ,GC-COUNT ,CRET>>
479
480 <DEFINE PRINTIME (AMT STR) #DECL((AMT) FIX)
481         <COND (<G? .AMT %<* 60 60>>
482                 <PRINCTHEM </ .AMT %<* 60 60>> " hours ">
483                 <SET AMT <MOD .AMT %<* 60 60>>>)>
484         <COND (<G? .AMT 60>
485                 <PRINCTHEM </ .AMT 60> " min. ">
486                 <SET AMT <MOD .AMT 60>>)>
487         <PRINCTHEM .AMT " sec. " .STR>>
488
489
490 <DEFINE STATUS ("AUX" FL PL)
491         <COND (<AND <ASSIGNED? ATOM-LIST> .GROUP-MODE <GASSIGNED? COMPILE>>
492                <PRINCTHEM ,CRET "Running group " <LENGTH .ATOM-LIST> " long.">
493                <PRINTSTATS>)
494               (<AND <ASSIGNED? ATOM-LIST> <ASSIGNED? AL>>
495                 <SET FL <LENGTH .ATOM-LIST>>
496                 <SET PL <- .FL <LENGTH <MEMQ .AL .ATOM-LIST>>>>
497                 <PRINCTHEM ,CRET "Running: " .PL " finished, working on ">
498                 <PRIN1 .AL>
499                 <PRINCTHEM ", and " <- .FL .PL 1> " to go.">
500                 <PRINTSTATS>)
501               (<AND <ASSIGNED? STARCPU> <ASSIGNED? STARR>>
502                 <COND (<NOT <ASSIGNED? FILE-DATA>>
503                         <PRINC "
504 Files not yet loaded.">
505                         <PRINTSTATS>)
506                       (<NOT <ASSIGNED? ATOM-LIST>>
507                         <PRINC"
508 Files loaded, but functions not yet ordered for compilation.">
509                         <PRINTSTATS>)
510                       (ELSE <PRINC "
511 Almost done, just cleaning up and writing out final file.">
512                         <PRINTSTATS>)>)
513               (ELSE <PRINCTHEM ,CRET "I'm not running." ,CRET>)>>
514
515 <DEFINE COUNT-GCS (TI RS SU) <SETG GC-COUNT <+ ,GC-COUNT 1>>
516         <AND <ASSIGNED? GCTIME> <SET GCTIME <+ .GCTIME .TI>>>>
517
518 <GDECL (GC-COUNT) FIX>
519
520 <SETG NOT-COMPILE-TIME
521       '![PREV
522          SPLOUTEM
523          REVERSE
524          ORDEREM
525          REMEMIT
526          FINDREC
527          FINDEM
528          FINDEMALL
529          GETORDER
530          PRINSPEC
531          DO-AND-CHECK
532          FIND-DEFINE-LOAD
533          FDREAD-LP
534          NEW-DEFINE
535          NEW-FLOAD
536          HELP
537          NOT-COMPILE-TIME!]>
538
539 <MANIFEST CRET NOT-COMPILE-TIME>
540
541 <SETG CRET "
542 ">
543
544 <SETG TAB <ASCII 9> ;"Char Tab">
545
546 <MANIFEST CRET TAB>
547
548 <DEFMAC PRINCTHEM ("ARGS" A) #DECL ((A) LIST)
549         <FORM PROG ()
550               !<MAPF ,LIST <FUNCTION (X)
551                                      <FORM PRINC .X>>
552                      .A>>>
553
554 <DEFINE FIND-DEFINE-LOAD (FNM "AUX" GRP (OLD-FLOAD ,FLOAD))
555         <SET GRP <GROUP-LOAD .FNM>>
556         (<1 <GET-ATOMS ..GRP>> .GRP)>
557
558 <DEFINE GET-ATOMS (L "AUX" (L1 .L) (AL ()) (LL ()) TEM TT MCR ATM VAL) 
559         #DECL ((L AL L1 LL) LIST (TT) FORM)
560         <REPEAT ()
561                 <SET MCR <>>
562                 <COND (<EMPTY? .L1> <RETURN (.AL .L)>)
563                       (<AND <TYPE? <1 .L1> FORM>
564                             <NOT <EMPTY? <SET TT <1 .L1>>>>>
565                        <COND (<OR <==? <1 .TT> DEFINE>
566                                   <SET MCR <==? <1 .TT> DEFMAC>>>
567                               <COND (<AND .MCR .MACRO-FLUSH>
568                                      <PUT .L1 1 <FORM DEFINE <ATOM "A"> ()>>)
569                                     (ELSE
570                                      <PUT .L1 1 <FORM <1 .TT> <2 .TT> <>>>)>
571                               <SET ATM <GET <2 .TT> VALUE '<2 .TT>>>
572                               <OR <AND .MCR <NOT .MACRO-COMPILE>>
573                                   <SET AL (.ATM !.AL)>>)>)>
574                 <SET L1 <REST .L1>>>>
575
576 <DEFINE NEW-ERROR (FRM "TUPLE" TUP "EXTRA" (OUTCHAN ,COMPCHAN))
577         #DECL ((TUP) TUPLE (OUTCHAN) <SPECIAL ANY>)
578         <COND (<AND <NOT <EMPTY? .TUP>> <==? <1 .TUP> CONTROL-G?!-ERRORS>>
579                 <INT-LEVEL 0>
580                 <OFF ,ERROR-HANDLER>    ;"HAVE TO NEST TO TURN HANDLER ON AND OFF"
581                 <ERROR !.TUP>
582                 <ON "ERROR" ,ERROR-HANDLER 100>
583                 <ERRET T .FRM>)
584               (ELSE <PRINC"
585 ***********************************************************
586 *        ERROR ERROR ERROR ERROR ERROR ERROR ERROR        *
587 ***********************************************************
588
589 to wit,">
590                 <MAPF <> ,PRINT .TUP>
591                 <PRINC "
592 Compilation totally aborted.
593 Status at death was:
594
595 ">
596                 <STATUS> <FRATM>
597                 <APPLY ,LOGOUT> <OFF ,ERROR-HANDLER>)>>
598
599 <SETG COMPCHAN ,OUTCHAN>
600
601 <OFF <SETG ERROR-HANDLER <ON "ERROR" ,NEW-ERROR 100>>>
602
603 <DEFINE PRINSPEC (STR CHAN) #DECL((STR) STRING (CHAN) CHANNEL)
604         <PRINCTHEM .STR <FILENAME .CHAN> ,CRET>>
605         
606
607 <DEFINE FILENAME (CHAN) #DECL ((CHAN) CHANNEL)
608   <COND (<G? ,MUDDLE 100>
609          <STRING <9 .CHAN> ":<" <10 .CHAN> !\> <7 .CHAN> !\. <8 .CHAN>>)
610         (<STRING <9 .CHAN> !\: <10 .CHAN> !\; <7 .CHAN> !\  <8 .CHAN>>)>>
611
612 <DEFINE DO-AND-CHECK (STR1 STR2 ATM INCH OUTCH FOOCH "AUX" NEW-CHAN)
613         <COND (<AND <ASSIGNED? .ATM> ..ATM>                     ;"Do it?"
614                 <PRINC .STR1>
615                <COND                                    ;"Yes. Get the channel."
616                 (<TYPE? ..ATM CHANNEL>          ;"Output channel already open."
617                  <COND (<OR <0? <1 ..ATM>> <NOT <=? "PRINT" <2 ..ATM>>>>
618                                                         ;"But is it good?"
619                         <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
620                         <RETURN #FALSE("CLOSED special channel??") .FCEX>)
621                        (ELSE <SET NEW-CHAN ..ATM>)>)
622                 (<TYPE? ..ATM STRING>                   ;"Name of output file given."
623                  <COND (<SET NEW-CHAN <OPEN "PRINT" ..ATM>>)    ;"So try opening it."
624                        (ELSE                            ;"Bad name."
625                         <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
626                         <RETURN #FALSE("Can't open channel.") .FCEX>)>)
627                 (<SET NEW-CHAN
628                         <OPEN "PRINT" <7 .INCH> .STR2 "DSK" <10 .INCH>>>)
629                 (ELSE <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
630                         <RETURN #FALSE("Can't open channel.") .FCEX>)>
631                 <PRINSPEC "on " .NEW-CHAN>
632                 .NEW-CHAN)>>
633
634 <DEFINE FLUSH-COMMENTS ("AUX" (A <ASSOCIATIONS>) B)
635         <REPEAT ()
636                 <SET B <NEXT .A>>
637                 <COND (<==? <INDICATOR .A> COMMENT>
638                        <PUT <ITEM .A> COMMENT>)>
639                 <OR <SET A .B> <RETURN>>>>
640
641 <SETG DEMON?
642       %<FIXUP!-RSUBRS '[
643 #CODE ![4793303048 28063301637 17859346449 17330864128 23085680158 17859346471 
644 17200316423 23085680158 13893633 5768480256 0 2!]
645                         DEMON?
646                         #DECL ("VALUE" <OR FALSE ATOM>)
647                         T]
648                       '(54 FINIS!-MUDDLE 230942 (8 5))>>
649
650