mim/development/mim/mimc/comfil.mud

   1 <PACKAGE "COMFIL">
   2
   3 <ENTRY FILE-COMPILE STATUS REDO PRECOMPILED DISOWN MACRO-COMPILE
   4        REHASH-ALL MACRO-FLUSH NO-TEMP-FILE INS-LIST INS-FIX ACCESS-LIST
   5        ERRORS-OCCURED>
   6
   7 <USE "FILE-INDEX" "HASH" "CDRIVE" "COMPDEC" "ITIME" "MIMC-GRDUMP" "TTY">
   8
   9 <NEWTYPE ACCESS-LIST LIST '<<PRIMTYPE LIST> ANY FIX FIX>>
  10
  11 <NEWTYPE INS-LIST LIST>
  12
  13 <GDECL (ALL-OUT) LIST>
  14
  15 <SETG STATUS-LINE <>>
  16
  17 <SETG PACKAGE-OBLIST <MOBLIST PACKAGE>>
  18
  19 <SET NO-TEMP-FILE <>>
  20
  21 <SET PACKAGE-MODE <>>
  22
  23 <SET REDO ()>
  24
  25 <SET CAREFUL T>
  26
  27 <SET REASONABLE T>
  28
  29 <SET DEBUG-COMPILE T>
  30
  31 <SET HAIRY-ANALYSIS T>
  32
  33 <SETG FF <ASCII 12>>
  34
  35 <SETG GC-COUNT 0>
  36
  37 <SET MACRO-FLUSH <>>
  38
  39 <SET MACRO-COMPILE T>
  40
  41 <SETG REHASH-ALL <>>
  42
  43 "Stuff for status line"
  44
  45 <SETG STATE-TITLE "State ">
  46
  47 <MSETG H-STATE <LENGTH ,STATE-TITLE>>
  48
  49 <MSETG H-STATE-LN 5>
  50
  51 <SETG STATE-FCN " Fcn ">
  52
  53 <MSETG H-FCN <+ <LENGTH ,STATE-FCN> ,H-STATE-LN ,H-STATE>>
  54
  55 <MSETG H-FCN-LN 10>
  56
  57 <SETG STATE-PHASE " Phase ">
  58
  59 <MSETG H-PHASE <+ ,H-FCN ,H-FCN-LN <LENGTH ,STATE-PHASE>>>
  60
  61 <MSETG H-PHASE-LN 4>
  62
  63 <SETG STATE-CPU " Cpu ">
  64
  65 <MSETG H-CPU <+ ,H-PHASE ,H-PHASE-LN <LENGTH ,STATE-CPU>>>
  66
  67 <MSETG H-CPU-LN 6>
  68
  69 <SETG STATE-REAL " Real ">
  70
  71 <MSETG H-REAL <+ ,H-CPU ,H-CPU-LN <LENGTH ,STATE-REAL>>>
  72
  73 <MSETG H-REAL-LN 5>
  74
  75 <MSETG H-RATIO <+ ,H-REAL ,H-REAL-LN 1>>
  76
  77 <MSETG H-RATIO-LN 7>
  78
  79 <MSETG H-RE-ANA <+ ,H-RATIO ,H-RATIO-LN 1>>
  80
  81 <BLOCK (<ROOT>)>
  82 IMPORT-PM!-
  83 DEFINITION-MODULE!-
  84 PROGRAM-MODULE!-
  85 END-MODULE!-
  86 INCLUDE-DEFINITIONS!-
  87 PMEXPORT!-
  88 INCLUDE-WHEN!-
  89 IMPORT-WHEN!-
  90 ZSECTION!-
  91 ZZSECTION!-
  92 ZPACKAGE!-
  93 ZZPACKAGE!-
  94 ZENDPACKAGE!-
  95 ZENDSECTION!-
  96 ENDSECTION!-
  97 <ENDBLOCK>
  98
  99 <DEFINE FILE-COMPILE FCEX (INFILE
 100                            "OPTIONAL" (OUTFILE "") (NM2 "MUD")
 101                            "AUX" (STARCPU <FIX <+ <TIME> 0.5>>)
 102                                  (STARR <RTIME>)
 103                                  INCH OUTCH (TEMPCH <>) TEM (NEW-INDEX ())
 104                                  X (PRE-INDEX ())
 105                                  (SRC-CHAN #FALSE ())
 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? <>)
 112                                  (REAL-NM2 .NM2))
 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 <>>
 124         <SETG ALL-OUT ()>
 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>>
 132         <CLOSE .INCH>
 133         <SET NM2 "MIMA">
 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" "">>
 139                        <RETURN>)>
 140                 <ERROR .TEMPCH "ERRET ANYTHING TO RETRY">>
 141                <PRINSPEC "Temporary output to " .TEMPCH>)>
 142         <COND (<AND <ASSIGNED? PRECOMPILED>
 143                     .PRECOMPILED>
 144                <REPEAT (X)
 145                        <COND (<OR <AND <ASSIGNED? PRECH> .PRECH>
 146                                   <AND <SET PRECH <OPEN "READ" .PRECOMPILED>>
 147                                        <PRINSPEC "Will load precompile from "
 148                                                  .PRECH>>>
 149                               <RETURN>)
 150                              (<=? <UNAME> "OPERATOR">
 151                               ; "Don't call error if running in batch mode"
 152                               <PRINCTHEM "Can't load precompilation from "
 153                                          <2 .PRECH> ":  "
 154                                          <1 .PRECH>
 155                                          ,CRET>
 156                               <RETURN>)
 157                              (<SET X <ERROR "Cant load precompilation"
 158                                             .PRECH
 159                 "ERRET non-false to retry, false to ignore precompilation">>
 160                               <COND (<TYPE? .X STRING>
 161                                      <SET PRECOMPILED .X>)>)
 162                              (ELSE <RETURN>)>>)>
 163         <COND (<NOT .CAREFUL> <PRINCTHEM "Bounds checking disabled." ,CRET>)>
 164         <COND
 165          (<SET OC
 166                <DO-AND-CHECK
 167                 "Writing record "
 168                 "RECORD"
 169                 DISOWN
 170                 .INCH
 171                 .OUTCH
 172                 .SRC-CHAN>>
 173           <PRINCTHEM "Toodle-oo!" ,CRET>
 174           <SETG COMPCHAN <SET OUTCHAN .OC>>
 175           <PRINSPEC "Compilation record for: " .INCH>
 176           <PRINSPEC "Output file:  " .OUTCH>)>
 177         <CLOSE .OUTCH>
 178         <SETG GC-COUNT 0>
 179         <SET GC-HANDLER <ON <HANDLER "GC" ,COUNT-GCS 10>>>
 180         <SET X <TIME>>
 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>
 186         <SET ATOM-LIST
 187              <MAPF ,LIST
 188                    <FUNCTION (ATM)
 189                            <COND (<OR <TYPE? ,.ATM FUNCTION>
 190                                       <AND <TYPE? ,.ATM MACRO>
 191                                            <NOT <EMPTY? ,.ATM>>
 192                                            <TYPE? <1 ,.ATM> FUNCTION>>>
 193                                   .ATM)
 194                                  (ELSE <MAPRET>)>>
 195                    <1 .FILE-DATA>>>
 196         <COND (<NOT <EMPTY? <CHTYPE .REDO LIST>>>
 197                <COND (.PACKAGE-MODE
 198                       <MAPR <>
 199                             <FUNCTION (L)
 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>)>
 204         <COND
 205          (<AND <ASSIGNED? PRECOMPILED> .PRECOMPILED .PRECH>
 206           <SET X <TIME>>
 207           <SET PRE-INDEX ()>
 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>>>
 212                   <COND
 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>>>>
 220                            <AGAIN>)>
 221                     <COND (<AND <NOT <EMPTY? .ATOM-LIST>>
 222                                 <NOT <MEMQ .NM .REDO>>
 223                                 <NOT <AND <GASSIGNED? .NM>
 224                                           .HASH-CODE
 225                                           <N==? .HASH-CODE <HASH ,.NM>>>>>
 226                            <SET PRE-INDEX
 227                                 (<CHTYPE (.NM .ACC <ACCESS .PRECH>
 228                                           <COND (.HASH-CODE)
 229                                                 (<GASSIGNED? .NM>
 230                                                  <HASH ,.NM>)>)
 231                                           ACCESS-LIST>
 232                                  !.PRE-INDEX)>
 233                            <PUTPROP .NM RSUB-DEC <3 .THING>>
 234                            <COND (<==? .NM <1 .ATOM-LIST>>
 235                                   <SET ATOM-LIST <REST .ATOM-LIST>>
 236                                   <SET ANY-MIMAS? T>)
 237                                  (ELSE
 238                                   <REPEAT ((X .ATOM-LIST))
 239                                           #DECL ((X) LIST)
 240                                           <COND (<EMPTY? <REST .X>> <RETURN>)>
 241                                           <COND (<==? <2 .X> .NM>
 242                                                  <PUTREST .X <REST .X 2>>
 243                                                  <SET ANY-MIMAS? T>
 244                                                  <RETURN>)>
 245                                           <SET X <REST .X>>>)>)>
 246                     <COND (<AND .HASH-CODE <NOT <GASSIGNED? .NM>>>
 247                            <AGAIN>)>)
 248                    (<AND <TYPE? .THING WORD> <NOT ,REHASH-ALL>>
 249                     <SET HASH-CODE <CHTYPE .THING FIX>>
 250                     <AGAIN>)
 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
 257                                            DROP L-UNUSE
 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!-
 263                                            BLOCK ENDBLOCK
 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."
 269                     <EVAL .THING>)>
 270                   <SET HASH-CODE <>>>
 271           <PRINCTHEM "Precompilation loaded" ,CRET>
 272           <COND (<NOT .ANY-MIMAS?>
 273                  <PRINCTHEM
 274                   "No compiled functions from PRECOMPILATION used?" ,CRET>)>
 275           <RESET .PRECH>
 276           <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>)>
 277         <COND (<EMPTY? .ATOM-LIST>
 278                <PRINCTHEM "No DEFINEd functions in this file." ,CRET>
 279                <SET ATOM-LIST ()>)
 280               (ELSE <SET ATOM-LIST <GETORDER !<SET ATL .ATOM-LIST>>>)>
 281         <PRINCTHEM "Functions ordered." ,CRET>
 282         <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>
 283         <COND (.REASONABLE
 284                <SET ATOM-LIST
 285                     <MAPF ,LIST
 286                           <FUNCTION (A)
 287                                <COND (<MEMQ .A .ATL> .A)
 288                                      (ELSE <MAPRET>)>>
 289                           .ATOM-LIST>>)>
 290         <MAPF <>
 291               <FUNCTION (AL "AUX" OUTL ACC)
 292                       #DECL ((AL) <SPECIAL ATOM> (OUTL) <OR FALSE LIST>)
 293                       <SET OBLIST <FIND-OBL .AL <2 .FILE-DATA>>>
 294                       <COND (<SET OUTL
 295                                   <COMPILE
 296                                          .AL
 297                                          .CAREFUL
 298                                          .REASONABLE
 299                                          .HAIRY-ANALYSIS
 300                                          .DEBUG-COMPILE>>
 301                              <BUFOUT .OUTCHAN>
 302                              <COND (<NOT .NO-TEMP-FILE>
 303                                     <SET X <TIME>>
 304                                     <SET ACC <ACCESS .TEMPCH>>
 305                                     <DUMP-CODE .OUTL .TEMPCH .OBLIST>
 306                                     <SET NEW-INDEX
 307                                          (<CHTYPE (.AL .ACC <ACCESS .TEMPCH>
 308                                                    <HASH ,.AL>)
 309                                                   ACCESS-LIST> !.NEW-INDEX)>
 310                                     <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>)
 311                                    (ELSE
 312                                     <SETG ALL-OUT ((.AL .OUTL <HASH ,.AL>)
 313                                                    !,ALL-OUT)>)>)
 314                             (ELSE
 315                              <SETG ERRORS-OCCURED T>
 316                              <BUFOUT .OUTCHAN>)>>
 317               .ATOM-LIST>
 318         <COND (,STATUS-LINE <UPDATE-STATUS "Writ" "None" <> <>>)>
 319         <COND (<NOT .NO-TEMP-FILE>
 320                <SET TMP <CHANNEL-OP .TEMPCH NAME>>
 321                <CLOSE .TEMPCH>
 322                <SET TEMPCH <OPEN "READ" .TMP>>
 323                <MAPF <>
 324                      <FUNCTION (L)
 325                           <SETG <1 .L> .L> <PUT .L 1 .TEMPCH>> .NEW-INDEX>)
 326
 327               (ELSE
 328                <MAPF <> <FUNCTION (A) #DECL ((A) LIST)
 329                              <SETG <1 .A>
 330                                    <CHTYPE (<3 .A> !<CHTYPE <2 .A> LIST>)
 331                                            INS-LIST>>> ,ALL-OUT>)>
 332         <COND (<AND <ASSIGNED? PRECOMPILED>
 333                     .PRECOMPILED>
 334                <PROG ((PREV <>) PN) #DECL ((PREV) <OR FALSE ACCESS-LIST>)
 335                      <MAPF <>
 336                            <FUNCTION (L "AUX" (ATM <1 .L>))
 337                                 #DECL ((L) ACCESS-LIST)
 338                                 <COND (<AND <NOT <GASSIGNED? .ATM>>
 339                                             <MEMBER <SPNAME .PN>
 340                                                     <SPNAME .ATM>>>
 341                                        <PUTREST <REST .L 3> (.PREV)>
 342                                        <COND (<AND <NOT <4 .L>> <4 .PREV>>
 343                                               <PUT .L 4 <4 .PREV>>
 344                                               <PUT .PREV 4 <>>)>
 345                                        <SETG .PN .L>)>
 346                                 <SETG .ATM .L>
 347                                 <SET PN .ATM>
 348                                 <PUT .L 1 .PRECH>
 349                                 <SET PREV .L>>
 350                            .PRE-INDEX>>)>
 351         <SET NO-BQ T>
 352         <SET X <TIME>>
 353         <MIMC-GROUP-DUMP .OUTFILE <2 .FILE-DATA> .TEMPCH>
 354         <SET I/O-TIME <+ .I/O-TIME <- <TIME> .X>>>
 355         <SET NO-BQ <>>
 356         <PRINTSTATS>
 357         <OFF .GC-HANDLER>
 358         <SETG COMPCHAN ,OUTCHAN>
 359         <COND (<AND <ASSIGNED? TEMPCH> <TYPE? .TEMPCH CHANNEL>>
 360                <CLOSE .TEMPCH>
 361                <DELFILE .TMP>)>
 362         <COND (<AND <ASSIGNED? DISOWN> .DISOWN>
 363                "Compilation completed. Your patience is godlike.")
 364               (ELSE "Compilation completed. Your patience is godlike.")>>
 365
 366 <DEFINE PACK-FIX (PCK ATM
 367                   "AUX" (S <PNAME .ATM>) (WIN <>)
 368                         (PO <LOOKUP .PCK ,PACKAGE-OBLIST>))
 369         <AND .PO <SET PO ,.PO>>
 370         <MAPF <>
 371               <FUNCTION (O)
 372                       #DECL ((O) OBLIST)
 373                       <AND <SET WIN <LOOKUP .S .O>> <MAPLEAVE>>>
 374               <CHTYPE .PO LIST>>
 375         <COND (.WIN) (.PO <INSERT .S <1 .PO>>) (ELSE .ATM)>>
 376
 377 <DEFINE LINEARIZE (ATOM-LIST) #DECL ((ATOM-LIST) LIST)
 378      <REPEAT ((L <SET ATOM-LIST (START !.ATOM-LIST)>) (LL <REST .L>))
 379              #DECL ((L LL) LIST)
 380              <COND (<EMPTY? .LL> <RETURN <REST .ATOM-LIST>>)
 381                    (<TYPE? <1 .LL> LIST>
 382                     <PUTREST .L <1 .LL>>
 383                     <PUTREST <SET L <REST .L <- <LENGTH .L> 1>>>
 384                              <SET LL <REST .LL>>>)
 385                    (ELSE <SET LL <REST <SET L .LL>>>)>>>
 386
 387
 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")
 398                                   (T <2 .L>)>
 399                             <COND (<==? <2 .L> 1> "")
 400                                   (T " times")>
 401                             ,CRET>
 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.">
 413         <PRINCTHEM ,CRET
 414                 "CPU utilization is " <* 100.0 </ .TSTARCPU <FLOAT .TSTARR>>>
 415                 "%." ,CRET
 416                 "Number of garbage collects = " ,GC-COUNT ,CRET>>
 417
 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>>>)>
 422         <COND (<G? .AMT 60>
 423                 <PRINCTHEM </ .AMT 60> " min. ">
 424                 <SET AMT <MOD .AMT 60>>)>
 425         <PRINCTHEM .AMT " sec. " .STR>>
 426
 427 <DEFINE RTIME () <QTIME <ITIME>>>
 428
 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 ">
 435                 <PRIN1 .AL-L>
 436                 <PRINCTHEM ", and " <- .FL .PL 1> " to go.">
 437                 <PRINTSTATS>)
 438               (<AND <ASSIGNED? STARCPU> <ASSIGNED? STARR>>
 439                 <COND (<NOT <ASSIGNED? FILE-DATA>>
 440                         <PRINC "
 441 Files not yet loaded.">
 442                         <PRINTSTATS>)
 443                       (<NOT <ASSIGNED? ATOM-LIST>>
 444                         <PRINC"
 445 Files loaded, but functions not yet ordered for compilation.">
 446                         <PRINTSTATS>)
 447                       (ELSE <PRINC "
 448 Almost done, just cleaning up and writing out final file.">
 449                         <PRINTSTATS>)>)
 450               (ELSE <PRINCTHEM ,CRET "I'm not running." ,CRET>)>>
 451
 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>>>>>
 456
 457 <GDECL (GC-COUNT) FIX>
 458
 459
 460
 461 <SETG CRET "
 462 ">
 463
 464 <MANIFEST NOT-COMPILE-TIME>
 465
 466
 467 <SETG TAB <ASCII 9>>
 468
 469 <MANIFEST TAB>
 470
 471 <DEFMAC PRINCTHEM ("ARGS" A) #DECL ((A) LIST)
 472         <FORM PROG ()
 473               !<MAPF ,LIST <FUNCTION (X)
 474                                      <FORM PRINC .X>>
 475                      .A>>>
 476
 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)>
 481
 482 <DEFINE GET-ATOMS (L "AUX" (L1 .L) (AL ()) (LL ()) TEM TT MCR ATM VAL)
 483         #DECL ((L AL L1 LL) LIST (TT) FORM)
 484         <REPEAT ()
 485                 <SET MCR <>>
 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"> ()>>)
 493                                     (ELSE
 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>>>>
 499
 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>>
 503                 <INT-LEVEL 0>
 504                 <OFF ,ERROR-HANDLER>
 505                 ;"HAVE TO NEST TO TURN HANDLER ON AND OFF"
 506                 <ERROR !.TUP>
 507                 <ON ,ERROR-HANDLER>
 508                 <ERRET T .FRM>)
 509               (ELSE <PRINC"
 510 ***********************************************************
 511 *        ERROR ERROR ERROR ERROR ERROR ERROR ERROR        *
 512 ***********************************************************
 513
 514 to wit,">
 515                 <MAPF <> ,PRINT .TUP>
 516                 <PRINC "
 517 Compilation totally aborted.
 518 Status at death was:
 519
 520 ">
 521                 <STATUS>)>>
 522
 523 <SETG COMPCHAN ,OUTCHAN>
 524
 525 <COND (<GASSIGNED? NEW-ERROR>
 526        <SETG ERROR-HANDLER <HANDLER "ERROR" ,NEW-ERROR 100>>)>
 527
 528 <DEFINE PRINSPEC (STR CHAN) #DECL((STR) STRING (CHAN) CHANNEL)
 529         <PRINCTHEM .STR <CHANNEL-OP .CHAN NAME> ,CRET>>
 530
 531
 532 <DEFINE DO-AND-CHECK (STR1 STR2 ATM INCH OUTCH FOOCH "AUX" NEW-CHAN TSTR)
 533         <COND (<AND <ASSIGNED? .ATM> ..ATM>                     ;"Do it?"
 534                <PRINC .STR1>
 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."
 542                        (ELSE                            ;"Bad name."
 543                         <CLOSE .INCH>
 544                         <CLOSE .OUTCH>
 545                         <AND .FOOCH <CLOSE .FOOCH>>
 546                         <RETURN .NEW-CHAN .FCEX>)>)
 547                 (ELSE
 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" "">>)
 552                              (ELSE
 553                               <CLOSE .INCH>
 554                               <CLOSE .OUTCH>
 555                               <AND .FOOCH <CLOSE .FOOCH>>
 556                               <RETURN .NEW-CHAN .FCEX>)>>
 557                  <PRINSPEC "on " .NEW-CHAN>
 558                  .NEW-CHAN)>)>>
 559
 560 <DEFINE FLUSH-COMMENTS ("AUX" (A <ASSOCIATIONS>) B)
 561         <REPEAT ()
 562                 <SET B <NEXT .A>>
 563                 <COND (<==? <INDICATOR .A> COMMENT>
 564                        <PUTPROP <ITEM .A> COMMENT>)>
 565                 <COND (<NOT <SET A .B>> <RETURN>)>>>
 566
 567
 568 "GETORDER FUNCTIONS"
 569
 570 <DEFINE CHECK (ATM)
 571         #DECL ((ATM) <UNSPECIAL ATOM>)
 572         <AND <TYPE? .ATM ATOM>
 573              <GASSIGNED? .ATM>
 574              <OR <TYPE? ,.ATM FUNCTION>
 575                  <TYPE? ,.ATM MACRO>>>>
 576
 577 <DEFINE PREV (LS SUBLS)
 578         #DECL ((LS SUBLS) <UNSPECIAL LIST> (VALUE) LIST)
 579         <REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
 580
 581 <DEFINE SPLOUTEM (FL OU)
 582         #DECL ((FL) <UNSPECIAL LIST> (OU) <UNSPECIAL ATOM>)
 583         <REPEAT (TEM)
 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>>>>
 590
 591 <DEFINE REVERSE (LS)
 592         #DECL ((LS) <UNSPECIAL LIST>)
 593         <REPEAT ((RES ()) (TEM ()))
 594                 #DECL ((RES TEM) LIST)
 595                 <COND (<EMPTY? .LS> <RETURN .RES>)>
 596                 <SET TEM <REST .LS>>
 597                 <SET RES <PUTREST .LS .RES>>
 598                 <SET LS .TEM>>>
 599
 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>>)
 606      <COND
 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>>)
 613       (ELSE
 614        <PROG ((RES2 ()) GOTONE)
 615              #DECL ((RES2) LIST)
 616              <SET GOTONE <>>
 617              <REPEAT ((RES1 .FLIST))
 618                      #DECL ((RES1) LIST)
 619                      <COND (<NOT <CALLME <2 .RES1> .FLIST>>
 620                             <SET GOTONE T>
 621                             <SET RES2 (<2 .RES1> !.RES2)>
 622                             <COND (<==? .FLIST .RES1>
 623                                    <SET FLIST <REST .FLIST 2>>)
 624                                   (ELSE
 625                                    <PUTREST <PREV .FLIST .RES1>
 626                                             <REST .RES1 2>>)>)>
 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>>
 632                     <COND (<EMPTY? .RES>
 633                            <SET TEM .FLIST>
 634                            <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
 635                           (ELSE
 636                            <SET RES
 637                                 <REST <PUTREST .RES .FLIST>
 638                                       <LENGTH .FLIST>>>)>)>
 639              <COND (<EMPTY? .RES> <SET RES .RES2>)
 640                    (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
 641        <RETURN .RES>)>>>
 642
 643 <DEFINE CALLME (ATM LST)
 644         #DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
 645         <REPEAT ()
 646                 <AND <EMPTY? .LST> <RETURN <>>>
 647                 <AND <MEMQ .ATM <1 .LST>> <RETURN>>
 648                 <SET LST <REST .LST 2>>>>
 649
 650 <DEFINE CORDER (LST "AUX" (RES ()))
 651         #DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
 652         <REPEAT ((LS .LST))
 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>>>
 657         <REPEAT ((PNT ()))
 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>
 663                                <SET SHORT .TL>
 664                                <SET PNT .LST>)>
 665                         <SET LST <REST .LST 2>>>
 666                 <SET RES
 667                      (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
 668                             (ELSE <1 .PNT>)>
 669                       !.RES)>
 670                 <MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
 671                 <REPEAT (TEM)
 672                         <COND (<SET TEM <MEMQ () .LST>>
 673                                <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
 674                                      (ELSE
 675                                       <PUTREST <PREV .LST .TEM>
 676                                                <REST .TEM 2>>)>)
 677                               (ELSE <RETURN>)>>
 678                 <AND <EMPTY? .LST> <RETURN>>>
 679         <REVERSE .RES>>
 680
 681 <DEFINE ALLREACH (LATM LST MLST)
 682    #DECL ((LATM LST) <LIST [REST ATOM]>
 683           (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
 684    <MAPF <>
 685     <FUNCTION (ATM)
 686             #DECL ((ATM) ATOM)
 687             <COND (<MEMQ .ATM .LATM>)
 688                   (ELSE
 689                    <SET LATM
 690                         <ALLREACH (.ATM !.LATM)
 691                                   <REPEAT ((L .MLST))
 692                                           #DECL ((L) <LIST [REST LIST ATOM]>)
 693                                           <AND <==? <2 .L> .ATM>
 694                                                <RETURN <1 .L>>>
 695                                           <SET L <REST .L 2>>>
 696                                   .MLST>>)>>
 697     .LST>
 698    .LATM>
 699
 700 <DEFINE REMEMIT (ATM)
 701         #DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
 702                (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
 703         <OR <==? .ATM .FUNC>
 704             <MEMQ .ATM .FUNCL>
 705             <SET FUNCL (.ATM !.FUNCL)>>>
 706
 707 <DEFINE FINDREC (OBJ "AUX" (FM '<>))
 708         #DECL ((FM) FORM)
 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>>
 720                            <PROG ()
 721                                  <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
 722                                  T>
 723                            <PROG ()
 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>)>>
 730
 731 <DEFINE EMACRO (OBJ "AUX" EH  TEM)
 732         <ON <SET EH
 733                  <HANDLER "ERROR"
 734                           <FUNCTION (OBJ FRM "TUPLE" T)
 735                                <COND (<AND <GASSIGNED? MACACT>
 736                                            <LEGAL? ,MACACT>>
 737                                       <DISMISS [.OBJ !.T] ,MACACT>)
 738                                      (ELSE <LISTEN !.T>)>>
 739                           100
 740                           .OBJ>>>
 741         <COND (<TYPE? <SET TEM
 742                            <PROG MACACT () #DECL ((MACACT) <SPECIAL ANY>)
 743                                  <SETG MACACT .MACACT>
 744                                  (<EXPAND .OBJ>)>>
 745                       VECTOR>
 746                <OFF .EH>
 747                <ERROR MACRO-EXPANSION-LOSSAGE!-ERRORS !.TEM>)
 748               (ELSE <OFF .EH> <1 .TEM>)>>
 749
 750 <DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
 751         <AND    <==? <LENGTH .FM> 2>
 752                 <TYPE? <1 .FM> ATOM>
 753                 <==? ,<1 .FM> ,GVAL>
 754                 <TYPE? <2 .FM> ATOM>
 755                 <GASSIGNED? <2 .FM>>
 756                 <OR <TYPE? ,<2 .FM> FUNCTION>
 757                         <AND <TYPE? ,<2 .FM> MACRO>
 758                                 <NOT <EMPTY? ,<2 .FM>>>
 759                                 <TYPE? <1 ,<2 .FM>> FUNCTION>>>
 760                 <REMEMIT <2 .FM>>>>
 761
 762 <DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
 763         #DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
 764                (VALUE) <LIST [REST ATOM]>)
 765         <FINDREC ,.FUNC>
 766         .FUNCL>
 767
 768 <DEFINE FINDEMALL (ATM
 769                    "AUX" (TOPDO
 770                           <REPEAT ((TD ()))
 771                                   #DECL ((TD) LIST
 772                                          (VALUE)
 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>>>
 784                               <RETURN .TOPDO>)
 785                              (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
 786                       (<MEMQ <1 .CURDO> .TOPDO>)
 787                       (ELSE
 788                        <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
 789                                 (<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
 790                 <SET CURDO <REST .CURDO>>>>
 791
 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>)>>
 797
 798
 799 <DEFINE FIND-OBL (NM GRP "AUX" (RGRP ..GRP) (OB .OBLIST))
 800         #DECL ((NM) ATOM (RGRP) LIST)
 801         <MAPR <>
 802               <FUNCTION (PTR "AUX" (IT <1 .PTR>) TMP)
 803                       <SET OB <GETPROP .PTR BLOCK '.OB>>
 804                       <COND (<AND <TYPE? .IT FORM>
 805                                   <NOT <EMPTY? .IT>>
 806                                   <OR <==? <SET TMP <1 .IT>> DEFINE>
 807                                       <==? .TMP DEFMAC>>
 808                                   <TYPE? <SET TMP
 809                                               <GETPROP <2 .IT> VALUE '<2
 810                                                                        .IT>>>
 811                                          ATOM>
 812                                   <==? .TMP .NM>>
 813                              <MAPLEAVE>)>>
 814               .RGRP>
 815         .OB>
 816
 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
 826                     ,STATE-TITLE
 827                     !<STRING-FIT .STATE ,H-STATE-LN>
 828                     ,STATE-FCN
 829                     !<STRING-FIT .FCN ,H-FCN-LN>
 830                     ,STATE-PHASE
 831                     !<STRING-FIT <OR .PHASE ""> ,H-PHASE-LN>
 832                     ,STATE-CPU
 833                     !<CPU-STRING <- .CPU ,STATUS-CPU>>
 834                     ,STATE-REAL
 835                     !<REAL-STRING <- .REAL ,STATUS-REAL>>
 836                     " "
 837                     !<FUNCTION-RATIO>
 838                     " "
 839                     <COND (.REANA .REANA) (ELSE "  ")>
 840                     <COND (,ERRORS-OCCURED "E ") (ELSE "  ")>>>
 841
 842 <DEFINE GC-STATUS ("OPT" (OUT <>))
 843         <COND (.OUT <CHANNEL-OP ,OUTCHAN ERASE-CHAR>)
 844               (ELSE <PRINC "G" ,OUTCHAN>)>>
 845
 846 <MSETG LENGTH-BLANK 100>
 847
 848 <SETG STR-BLANK <ISTRING ,LENGTH-BLANK !\ >>
 849
 850 <DEFINE STRING-FIT SF (STR:STRING FIELD:FIX "AUX" (LN <LENGTH .STR>))
 851         <COND (<==? .LN .FIELD> <MULTI-RETURN .SF .STR>)
 852               (<G? .LN .FIELD>
 853                <MULTI-RETURN .SF <SUBSTRUC .STR 0 .FIELD>>)
 854               (ELSE
 855                <MULTI-RETURN .SF .STR <REST ,STR-BLANK <- ,LENGTH-BLANK
 856                                                           <- .FIELD .LN>>>>)>>
 857
 858 <DEFINE CPU-STRING CS (CPU:FIX
 859                        "AUX" (COLON <>) (H:FIX </ .CPU 3600>)
 860                              (R:FIX <MOD .CPU 3600>) (M:FIX </ .R 60>)
 861                              (S:FIX <MOD .R 60>))
 862         <MULTI-RETURN .CS
 863                       <COND (<G? .H 10> "*:")
 864                             (<G? .H 0> <SET COLON T> .H)
 865                             (ELSE "")>
 866                       <COND (.COLON ":")(ELSE "")>
 867                       .M
 868                       ":"
 869                       <COND (<L? .S 10> "0") (ELSE "")>
 870                       .S
 871                       <COND (<==? .H 0> "  ") (ELSE "")>
 872                       <COND (<L? .M 10> " ") (ELSE "")>>>
 873
 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>)
 877                               (S:FIX <MOD .R 60>))
 878         <MULTI-RETURN .RS
 879                       <COND (<G? .H 100> "**")
 880                             (<G? .H 0> "")
 881                             (ELSE <SET COLON <>> "")>
 882                       <COND (<AND <L? .H 100> <G? .H 0>> .H) (ELSE "")>
 883                       <COND (.COLON ":")(ELSE "")>
 884                       .M
 885                       ":"
 886                       <COND (<L? .S 10> "0") (ELSE "")>
 887                       .S
 888                       <COND (<G? .H 10> "")
 889                             (<G? .H 0> " ")
 890                             (ELSE "   ")>
 891                       <COND (<L? .M 10> " ") (ELSE "")>>>
 892
 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
 896                                                      ,H-RATIO-LN>>>)
 897               (ELSE
 898                <SET LN1 <LENGTH <SET ATL .ATOM-LIST>>>
 899                <SET LN2 <- .LN1 <LENGTH <MEMQ .AL .ATL>> -1>>
 900                <MULTI-RETURN .FR
 901                              <COND (<G=? .LN2 100> "")
 902                                    (<G=? .LN2 10> " ")
 903                                    (ELSE "  ")>
 904                              .LN2
 905                              "/"
 906                              <COND (<G=? .LN1 100> "")
 907                                    (<G=? .LN1 10> " ")
 908                                    (ELSE "  ")>
 909                              .LN1>)>>
 910
 911 <ENDPACKAGE>