<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