mim/development/mim/20c/file.mud

   1
   2
   3 <BLOCK (<ROOT>)>
   4
   5 ;"GETS names"
   6
   7 <NEWTYPE LOSE FIX>
   8
   9 COMPILER-INPUT
  10
  11 <COND (<NOT <GASSIGNED? GVAL-CAREFUL>> <SETG GVAL-CAREFUL <>>)>
  12 <COND (<NOT <GASSIGNED? ADJBP-HACK>> <SETG ADJBP-HACK <>>)>
  13
  14 ACTIVATION
  15
  16 MRETURN
  17
  18 LOOP
  19
  20 TBIND
  21
  22 BINDID
  23
  24 DISPATCH
  25
  26 ARGS
  27
  28 OBLIST
  29
  30 INGC
  31
  32 UBLOCK
  33
  34 UUBLOCK
  35
  36 USBLOCK
  37
  38 SBLOCK
  39
  40 BIND
  41
  42 PAGPTR
  43
  44 MINF
  45
  46 ICALL
  47
  48 ECALL
  49
  50 NCALL
  51
  52 UWATM
  53
  54 MAPPER
  55
  56 ENVIR
  57
  58 RUNINT
  59
  60 PURVEC
  61
  62 DBVEC
  63
  64 M$$BINDID
  65
  66 FRAME
  67
  68 SFRAME
  69
  70 ADJ
  71
  72 SCALL
  73
  74 CALL
  75
  76 NTHR
  77
  78 =
  79
  80 FCN
  81
  82 GFCN
  83
  84 IFSYS
  85
  86 IFCANNOT
  87
  88 IFCAN
  89
  90 ENDIF
  91
  92 TEMP
  93
  94 MAKTUP
  95
  96 END
  97
  98 COMPERR
  99
 100 UNWCONT
 101
 102 IOERR
 103
 104 JUMP
 105
 106 OPT-DISPATCH
 107
 108 ICALL
 109
 110 ACALL
 111
 112 BRANCH-FALSE
 113
 114 DEAD-FALL
 115
 116 DEAD-JUMP
 117
 118 STACK
 119
 120 TYPE-CODE
 121
 122 TYPE-WORD
 123
 124 RECORD-TYPE
 125
 126 DEAD
 127
 128 ALL
 129
 130 <SETG TYPE-LENGTHS
 131       [T$LBIND
 132        16
 133        LBIND
 134        16
 135        T$GBIND
 136        10
 137        GBIND
 138        10
 139        T$ATOM
 140        10
 141        ATOM
 142        10
 143        T$OBLIST
 144        10
 145        OBLIST
 146        10
 147        T$LINK
 148        10
 149        LINK
 150        10
 151        T$LVAL
 152        10
 153        LVAL
 154        10
 155        T$GVAL
 156        10
 157        GVAL
 158        10
 159        T$FRAME
 160        12
 161        FRAME
 162        12
 163        T$SFRAME
 164        12
 165        SFRAME
 166        12
 167        T$PAGET
 168        256
 169        T$MINF
 170        10
 171        MSUBR
 172        4
 173        T$MSUBR
 174        4]>
 175
 176 <SETG TYPE-WORDS
 177       [UNBOUND
 178        0
 179        T$UNBOUND
 180        0
 181        FIX
 182        64
 183        CHARACTER
 184        128
 185        FLOAT
 186        192
 187        LIST
 188        257
 189        FALSE
 190        321
 191        DECL
 192        385
 193        STRING
 194        453
 195        MCODE
 196        518
 197        T$MCODE
 198        518
 199        VECTOR
 200        583
 201        MSUBR
 202        647
 203        T$MSUBR
 204        647
 205        IMSUBR
 206        *4007*
 207        T$IMSUBR
 208        *4007*
 209        FRAME
 210        706
 211        T$FRAME
 212        706
 213        LBIND
 214        770
 215        T$LBIND
 216        770
 217        ATOM
 218        834
 219        T$ATOM
 220        834
 221        OBLIST
 222        898
 223        T$OBLIST
 224        898
 225        GBIND
 226        962
 227        T$GBIND
 228        962
 229        FORM
 230        1025
 231        T$TYPE-C
 232        1088
 233        TYPE-C
 234        1088
 235        I$TERMIN
 236        1152
 237        SEGMENT
 238        1217
 239        T$DEFER
 240        1281
 241        DEFER
 242        1281
 243        T$FUNCTION
 244        1345
 245        FUNCTION
 246        1345
 247        T$MACRO
 248        1409
 249        MACRO
 250        1409
 251        T$CHANNEL
 252        1479
 253        CHANNEL
 254        1479
 255        I$SDTABLE
 256        2247
 257        I$DISK-CHANNEL
 258        2311
 259        T$MUD-CHAN
 260        2375
 261        MUD-CHAN
 262        2375
 263        T$TYPE-ENTRY
 264        1543
 265        ADECL
 266        1607
 267        T$OFFSET
 268        1671
 269        OFFSET
 270        1671
 271        T$LVAL
 272        1730
 273        LVAL
 274        1730
 275        T$GVAL
 276        1794
 277        GVAL
 278        1794
 279        T$LINK
 280        1858
 281        LINK
 282        1858
 283        T$TUPLE
 284        1927
 285        TUPLE
 286        1927
 287        T$UVECTOR
 288        1990
 289        UVECTOR
 290        1990
 291        T$TAT
 292        2183
 293        TAT
 294        2183
 295        T$PAGET
 296        1990                                                   ;"really UVECTOR"
 297        T$MINF
 298        1990                                                            ;"ditto"
 299        T$WORD
 300        2432
 301        WORD
 302        2432
 303        T$PCODE
 304        2502
 305        PCODE
 306        2502
 307        T$ZONE
 308        2567
 309        ZONE
 310        2567
 311        T$GC-PARAMS
 312        2630
 313        GC-PARAMS
 314        2630
 315        T$AREA
 316        2694
 317        AREA
 318        2694
 319        T$SFRAME
 320        2754
 321        SFRAME
 322        2754
 323        T$BYTES
 324        2820
 325        BYTES
 326        2820
 327        T$TYPE-W
 328        2880
 329        TYPE-W
 330        2880
 331        T$BITS
 332        3008
 333        BITS
 334        3008
 335        T$KIND-ENTRY
 336        *6007*
 337        KIND-ENTRY
 338        *6007*
 339        T$SPLICE
 340        *6101*
 341        SPLICE
 342        *6101*]>
 343
 344 <COND (<NOT <GASSIGNED? PEEP-ENABLED>> <SETG PEEP-ENABLED <>>)>
 345
 346 <COND (<NOT <GASSIGNED? LABEL-OBLIST>> <SETG LABEL-OBLIST <MOBLIST LB 0>>)>
 347
 348 <COND (<NOT <GASSIGNED? VICTIMS>> <SETG VICTIMS ()>)>
 349
 350 <COND (<NOT <GASSIGNED? SURVIVORS>> <SETG SURVIVORS ()>)>
 351
 352 <ENDBLOCK>
 353
 354 <COND (<NOT <GASSIGNED? WIDTH-MUNG>>
 355        <FLOAD "MIMOC20DEFS.MUD">
 356        <FLOAD "MSGLUE-PM.MUD">)>
 357
 358 <COND (<NOT <GASSIGNED? CONSTANT-TABLE>>
 359        <SETG CONSTANT-TABLE <IVECTOR ,CONSTANT-TABLE-LENGTH ()>>)>
 360
 361 <COND (<NOT <GASSIGNED? MV-TABLE>>
 362        <SETG MV-TABLE <IVECTOR ,MV-TABLE-LENGTH ()>>)>
 363
 364 <COND (<NOT <GASSIGNED? DEATH-TRQ>> <SETG DEATH-TRQ T>)>
 365
 366 <COND (<NOT <GASSIGNED? MIM-OBL>> <SETG MIM-OBL <LIST !.OBLIST>>)>
 367
 368 <COND (<NOT <GASSIGNED? NO-AC-FUNNYNESS>> <SETG NO-AC-FUNNYNESS <>>)>
 369
 370 <COND (<NOT <GASSIGNED? V1>> <SETG V1 <>>)>
 371
 372 <COND (<NOT <GASSIGNED? V2>> <SETG V2 <>>)>
 373
 374 <COND (<NOT <GASSIGNED? BOOT-MODE>> <SETG BOOT-MODE <>>)>
 375
 376 <COND (<NOT <GASSIGNED? INT-MODE>> <SETG INT-MODE <>>)>
 377
 378 <COND (<NOT <GASSIGNED? GC-MODE>> <SETG GC-MODE <>>)>
 379
 380 <COND (<NOT <GASSIGNED? GLUE-MODE>> <SETG GLUE-MODE <>>)>
 381
 382 <COND (<NOT <GASSIGNED? ACA-AC>> <SETG ACA-AC <>>)>
 383
 384 <COND (<NOT <GASSIGNED? NEXT-FLUSH>> <SETG NEXT-FLUSH 0>)>
 385
 386 <COND (<NOT <GASSIGNED? MAX-SPACE>> <SETG MAX-SPACE <>>)>
 387
 388 <COND (<NOT <GASSIGNED? SURVIVOR-MODE>> <SETG SURVIVOR-MODE <>>)>
 389
 390 <COND (<NOT <GASSIGNED? LIST-OF-FCNS>> <SETG LIST-OF-FCNS ()>)>
 391
 392 <SETG CB-LENGTH 512>
 393
 394 <SETG BUFL 1024>
 395
 396 <MANIFEST CB-LENGTH BUFL>
 397
 398 <USE "FILE-INDEX">
 399
 400 <COND (<NOT <GASSIGNED? CODE-BUFFER>>
 401        <SETG CODE-BUFFER <IUVECTOR ,CB-LENGTH 0>>
 402        <SETG ONE-WD ![0]>)>
 403
 404 <COND (<NOT <GASSIGNED? OUTPUT-BUFFER>>
 405        <SETG OUTPUT-BUFFER <ISTRING ,OUTPUT-LENGTH>>)>
 406
 407 <SETG CTLZ+1 <+ <SETG CTLZ 26> 1>>
 408
 409 <SETG MIM <==? <TYPEPRIM FIX> FIX>>
 410
 411 <COND (<GASSIGNED? CRLF-STRING!-INTERNAL>
 412        <SETG WORD-STRING <STRING ,CRLF-STRING!-INTERNAL "#WORD " <ASCII ,CTLZ>>>)>
 413
 414 <COND (,MIM <SETG PKG-OBL <CHTYPE PACKAGE OBLIST>>)
 415       (ELSE <SETG PKG-OBL <GETPROP PACKAGE OBLIST>>)>
 416
 417 <COND (<OR <NOT <ASSIGNED? READ-TABLE>> <L? <LENGTH .READ-TABLE> ,CTLZ+1>>
 418        <SETG READ-TABLE <SET READ-TABLE <IVECTOR ,CTLZ+1 <>>>>)>
 419
 420 <SETG FCN-OBL <MOBLIST FOO>>
 421
 422 <SETG FCN-OBL-L (,FCN-OBL)>
 423
 424 <DEFINE TERMIN-PRINT (TERMIN)
 425         #DECL ((TERMIN) I$TERMIN)
 426         <PRINC "#I$TERMIN ">
 427         <PRIN1 <CHTYPE .TERMIN FIX>>
 428         <PRINC !\ >>
 429
 430 <COND (<NOT <GASSIGNED? FOOSTR>> <SETG FOOSTR " ">)>
 431
 432 <GDECL (FOOSTR) STRING>
 433
 434 <DEFINE CHR-PRINT (CHR)
 435         #DECL ((CHR) CHARACTER)
 436         <COND (<G? <CHTYPE .CHR FIX> 127>
 437                <PRINC "#CHARACTER ">
 438                <PRIN1 <CHTYPE .CHR FIX>>)
 439               (<PRINC  "!\\">
 440                <PUT ,FOOSTR 1 .CHR>
 441                <PRINC ,FOOSTR>)>>
 442
 443 <PRINTTYPE I$TERMIN ,TERMIN-PRINT>
 444
 445 <DEFINE ATOM-PRINT (ATM "AUX" (SPN <SPNAME .ATM>))
 446         #DECL ((ATM) ATOM (SPN) STRING)
 447         <COND (<AND <G=? <LENGTH .SPN> 2>
 448                     <==? <1 .SPN> !\T>
 449                     <==? <2 .SPN> !\$>>
 450                <PRINC <REST .SPN 2>>
 451                <OR ,BOOT-MODE <PRINC "!-">>)
 452               (<AND <OR <==? <OBLIST? .ATM> <ROOT>>
 453                         <MEMBER <SPNAME .ATM> ,ROOT-ATOMS>>
 454                     <NOT ,BOOT-MODE>>
 455                <PRINC .SPN>
 456                <PRINC "!-">)
 457               (T <PRINC .SPN>)>
 458         <PRINC " ">>
 459
 460 <COND (<NOT <GASSIGNED? ROOT-ATOMS>>
 461        <SETG ROOT-ATOMS ["M$$BINDID" "M$$INT-LEVEL"]>)>
 462
 463 <GDECL (ROOT-ATOMS) <VECTOR [REST STRING]>>
 464
 465 <DEFINE T$UNBOUND-PRINT (UNB)
 466         #DECL ((UNB) T$UNBOUND)
 467         <PRINC "#UNBOUND ">
 468         <PRIN1 <CHTYPE .UNB FIX>>
 469         <PRINC !\ >>
 470
 471 <PRINTTYPE T$UNBOUND ,T$UNBOUND-PRINT>
 472
 473 <DEFINE XGLOC-PRINT (X)
 474         #DECL ((X) XGLOC)
 475         <COND (,BOOT-MODE
 476                <PRIN1 <CHTYPE .X ATOM>>)
 477               (<PRINC "%<GBIND ">
 478                <PRIN1 <CHTYPE .X ATOM>>
 479                <PRINC " T> ">)>>
 480
 481 <PRINTTYPE XGLOC ,XGLOC-PRINT>
 482
 483 <SET REDEFINE T>
 484
 485 <DEFINE XTYPE-C-PRINT  (X "AUX" ATM)
 486         #DECL ((X) XTYPE-C (ATM) ATOM)
 487         <SET ATM <CHTYPE .X ATOM>>
 488         <PRINC "%<TYPE-C ">
 489         <PRIN1 .ATM>
 490         <PRINC !\ >
 491         <COND (<==? <SET ATM <TYPEPRIM .ATM>> WORD>
 492                <SET ATM FIX>)>
 493         <PRIN1 .ATM>
 494         <PRINC ">">>
 495
 496 <DEFINE XTYPE-W-PRINT  (X "AUX" ATM)
 497         #DECL ((X) XTYPE-W (ATM) ATOM)
 498         <SET ATM <CHTYPE .X ATOM>>
 499         <PRINC "%<TYPE-W ">
 500         <PRIN1 .ATM>
 501         <PRINC !\ >
 502         <COND (<==? <SET ATM <TYPEPRIM .ATM>> WORD>
 503                <SET ATM FIX>)>
 504         <PRIN1 .ATM>
 505         <PRINC ">">>
 506
 507 <PRINTTYPE XTYPE-C ,XTYPE-C-PRINT>
 508
 509 <PRINTTYPE XTYPE-W ,XTYPE-W-PRINT>
 510
 511 <COND (<NOT <GASSIGNED? OPS>>
 512        <COND (<GASSIGNED? BLOAT> <BLOAT 100000 5000 100 1500>)>
 513        <FLOAD "<MIM.20C>OP.MUD">)
 514       (<GASSIGNED? BLOAT> <BLOAT 100000 5000 100 100>)>
 515
 516 <COND (<NOT <GASSIGNED? OPCODE>> <FLOAD "<MIM.20C>MIMOPS.MUD">)>
 517
 518 <GDECL (SURVIVORS INCHANS) LIST (OPT-LIST) <OR FALSE LIST>
 519        (THIS-GUY) <LIST ATOM <LIST [REST OBLIST]>>>
 520
 521 <DEFINE PROCESS-IFSYS (L) #DECL ((L) LIST)
 522         <REPEAT ((IFL ()) IFOBJ ITM (LP .L) (LL <REST .L>))
 523                 #DECL ((IFL LP LL) LIST)
 524                 <COND (<EMPTY? .LL> <RETURN>)>
 525                 <COND (<AND <TYPE? <SET ITM <1 .LL>> FORM>
 526                             <MEMQ <SET IFOBJ <1 .ITM>>
 527                                   '[IFSYS ENDIF IFCAN IFCANNOT]>>
 528                        <COND (<==? .IFOBJ IFSYS>
 529                               <COND (<=? <2 .ITM> "TOPS20">
 530                                      <SET IFL (<2 .ITM> !.IFL)>
 531                                      <PUTREST .LP <SET LL <REST .LL>>>)
 532                                     (T
 533                                      <PUTREST .LP <SET LL <FLUSH-TO-ENDIF
 534                                                            .LL  <2 .ITM>>>>)>)
 535                              (<OR <==? .IFOBJ IFCAN> <==? .IFOBJ IFCANNOT>>
 536                               <COND (<COND (<==? .IFOBJ IFCAN>
 537                                             <LOOKUP <2 .ITM> ,MIMOC-OBLIST>)
 538                                            (ELSE
 539                                             <NOT <LOOKUP <2 .ITM> ,MIMOC-OBLIST>>)>
 540                                      <SET IFL (<2 .ITM> !.IFL)>
 541                                      <PUTREST .LP <SET LL <REST .LL>>>)
 542                                     (T
 543                                      <PUTREST .LP <SET LL <FLUSH-TO-ENDIF
 544                                                            .LL  <2 .ITM>>>>)>)
 545                              (T
 546                               <COND (<OR <EMPTY? .IFL> <N=? <2 .ITM> <1 .IFL>>>
 547                                      <ERROR UNBALANCED-IFSYS!-ERRORS
 548                                             <2 .ITM> .IFL>)
 549                                     (ELSE
 550                                      <SET IFL <REST .IFL>>)>
 551                               <PUTREST .LP <SET LL <REST .LL>>>)>
 552                        <AGAIN>)>
 553                 <SET LL <REST <SET LP .LL>>>>>
 554
 555 <DEFINE FLUSH-TO-ENDIF (L FLG "AUX" THING (CT 1) FRST)
 556         #DECL ((L) LIST)
 557   <REPEAT ()
 558     <COND (<EMPTY? <SET L <REST .L>>>
 559            <ERROR EOF-BEFORE-ENDIF!-ERRORS>
 560            <RETURN>)>
 561     <SET THING <1 .L>>
 562     <COND (<TYPE? .THING FORM>
 563            <COND (<==? <SET FRST <1 .THING>> ENDIF>
 564                   <COND (<0? <SET CT <- .CT 1>>> <RETURN <REST .L>>)>)
 565                  (<OR <==? .FRST IFSYS> <==? .FRST IFCAN> <==? .FRST IFCANNOT>>
 566                   <SET CT <+ .CT 1>>)>)>>>
 567
 568 <DEFINE GET-NM1 (STR "AUX" (SEEN-OP <>)) #DECL ((STR) STRING)
 569         <MAPF ,STRING <FUNCTION (CH) <COND (<==? .CH !\<> <SET SEEN-OP T>)
 570                                            (<==? .CH !\>> <SET SEEN-OP <>>)
 571                                            (<AND <NOT .SEEN-OP>
 572                                                  <==? .CH !\.>> <MAPSTOP>)
 573                                            (ELSE .CH)>> .STR>>
 574
 575 <DEFINE FILE-MIMOC ("TUPLE" FILES "AUX" C OC (OUTCHAN .OUTCHAN)
 576                     (EXPFLOAD <AND <ASSIGNED? EXPFLOAD> .EXPFLOAD>)
 577                     F-OR-G (PREC <>) PRE-INDEX COMPILER-INPUT
 578                     (REDO <AND <ASSIGNED? REDO> .REDO>) ON
 579                     (PRECOMPILED <AND <ASSIGNED? PRECOMPILED> .PRECOMPILED>))
 580         #DECL ((FILES) <<PRIMTYPE VECTOR> [REST STRING]> (OUTCHAN) <SPECIAL ANY>
 581                (PREC OC C) <OR FALSE CHANNEL> (COMPILER-INPUT) <SPECIAL CHANNEL>
 582                (PRE-INDEX) <LIST [REST !<LIST ATOM FIX FIX>]>
 583                (REDO) <LIST [REST ATOM]>)
 584         <COND (<AND <SET C <OPEN "READ" <1 .FILES>>>
 585                     <SET OC <OPEN "PRINT" <SET ON <STRING <GET-NM1 <1 .FILES>>
 586                                                           ".MSUBR">>>>
 587                     <OR <NOT .PRECOMPILED>
 588                         <AND <SET PREC <OPEN "READ" .PRECOMPILED>>
 589                              <SET PRE-INDEX <BUILD-INDEX .PREC ,FCN-OBL>>
 590                              <OR <EMPTY? .REDO>
 591                                  <MAPR <>
 592                                    <FUNCTION (L "AUX" (SN <SPNAME <1 .L>>))
 593                                         <PUT .L 1
 594                                              <OR <LOOKUP .SN ,FCN-OBL>
 595                                                  <INSERT .SN ,FCN-OBL>>>>
 596                                    .REDO>>>>>
 597                <SET COMPILER-INPUT .C>
 598                <SETG INCHANS (.C)>
 599                <SET FILES <REST .FILES>>
 600                <REPEAT (ATM (BUFFER <ISTRING ,BUFL>)) #DECL ((BUFFER) STRING)
 601                  <REPEAT ((IFL ()) NAME L NXT (END <>) ITM NM ACCESS-DATA
 602                           SPN HASH-CODE)
 603                    #DECL ((L) LIST (NAME) <SPECIAL ATOM> (NXT) FORM
 604                           (END) <SPECIAL <OR FALSE ATOM>> (HASH-CODE) WORD
 605                           (ACCESS-DATA) <LIST FIX FIX>)
 606                    <COND (<SET ITM <FINISH-FILE .C .OC .EXPFLOAD>>
 607                           <COND (<TYPE? .ITM FORM>
 608                                  <COND (<AND <G=? <LENGTH .ITM> 2>
 609                                              <TYPE? <SET ATM <2 .ITM>> ATOM>>
 610                                         <SET SPN <SPNAME .ATM>>
 611                                         <SET NM
 612                                              <OR <LOOKUP .SPN ,FCN-OBL>
 613                                                  <INSERT .SPN ,FCN-OBL>>>)>
 614                                  <SET NXT .ITM>)>)
 615                          (T
 616                           <SET END T>)>
 617                    <AND .END <RETURN>>
 618                    <SET C <1 ,INCHANS>>
 619                    <COND
 620                     (<TYPE? .ITM WORD> <SET HASH-CODE .ITM>)
 621                     (<AND .PREC
 622                            <NOT <MEMQ .NM .REDO>>
 623                            <MAPF <>
 624                                  <FUNCTION (LL)
 625                                      #DECL ((LL) !<LIST ATOM FIX FIX>)
 626                                      <COND (<==? <1 .LL> .NM>
 627                                             <SET ACCESS-DATA <REST .LL>>
 628                                             <COND (<OR <L? <LENGTH .ACCESS-DATA> 3>
 629                                                        <NOT <ASSIGNED? HASH-CODE>>
 630                                                        <==? <3 .ACCESS-DATA>
 631                                                             .HASH-CODE>>
 632                                                    <MAPLEAVE>)
 633                                                   (ELSE <MAPLEAVE <>>)>)>>
 634                                  .PRE-INDEX>>
 635                      <ACCESS .PREC <1 .ACCESS-DATA>>
 636                      <CRLF .OC>
 637                      <REPEAT ((NCHRS <- <2 .ACCESS-DATA> <1 .ACCESS-DATA>>))
 638                              #DECL ((NCHRS) FIX)
 639                              <COND (<L? .NCHRS ,BUFL>
 640                                     <READSTRING .BUFFER .PREC .NCHRS>
 641                                     <PRINTSTRING .BUFFER .OC .NCHRS>
 642                                     <RETURN>)
 643                                    (ELSE
 644                                     <READSTRING .BUFFER .PREC ,BUFL>
 645                                     <PRINTSTRING .BUFFER .OC ,BUFL>
 646                                     <SET NCHRS <- .NCHRS ,BUFL>>)>>
 647                      <SKIP-MIMA .C .NM>)
 648                     (ELSE
 649                      <SET L (.NXT !<READ-LIST .C END '<SET END T>>)>
 650                      <COND (.END <CLOSE .C>)>
 651                      <SET F-OR-G <1 .NXT>>
 652                      <SET NAME <2 .NXT>>
 653                      <COND (,VERBOSE
 654                             <OR <==? .OUTCHAN ,OUTCHAN>
 655                                 <PRINC <ASCII 12>>>
 656                             <CRLF>
 657                             <PRINC "Open coding: ">
 658                             <PRIN1 .NAME>)>
 659                      <PROCESS-IFSYS .L>
 660                      <CALL-ANA .L>
 661                      <MIMOC .L>
 662                      <LOCATION-CHECK>
 663                      <FIXUP-ONE-GLUE <REST ,CODE> ,LABELS>
 664                      <ALLOCATE-CONSTANTS ,CONSTANT-VECTOR ,CODE-LENGTH>
 665                      <FIXUP-CONSTANTS <REST ,CODE>>
 666                      <WRITE-MSUBR .OC <> .F-OR-G>
 667                      <MAPF <>
 668                            <FUNCTION (LB) #DECL ((LB) LAB)
 669                                 <GUNASSIGN <REMOVE <LAB-NAM .LB>>>>
 670                            ,LABELS>)>
 671                    <AND .END <RETURN>>>
 672                  <COND (<EMPTY? .FILES>
 673                         <RETURN>)>
 674                  <CLOSE .C>
 675                  <COND (<SET C <OPEN "READ" <1 .FILES>>>
 676                         <SET FILES <REST .FILES>>
 677                         <SETG INCHANS (.C)>)
 678                        (<ERROR .C FILE-MIMOC>)>>
 679                <CLOSE .C>
 680                <CLOSE .OC>
 681                ,NULL)
 682               (ELSE
 683                <COND (<AND <ASSIGNED? C> .C>
 684                       <CLOSE .C>
 685                       <COND (<AND <ASSIGNED? OC> .OC>
 686                              <CLOSE .OC>
 687                              <DELFILE .ON>
 688                              <ERROR .PREC>)
 689                             (ELSE <ERROR .OC>)>)
 690                      (ELSE
 691                       <ERROR .C>)>)>>
 692
 693 <DEFINE FILE-GLUE ("TUPLE" FILES "AUX" C OC (TC <>) NMSTR (LEN 0) (FCN-COUNT 0)
 694                    MSUBR-ACCESS (LOWERSTR <>) (TFILES .FILES) TN (OUTCHAN .OUTCHAN)
 695                    (EXPFLOAD <AND <ASSIGNED? EXPFLOAD> .EXPFLOAD>) TOC PN ON TON
 696                    TFILE-LENGTH COMPILER-INPUT (OB ,OUTPUT-BUFFER))
 697         #DECL ((TFILES FILES) <<PRIMTYPE VECTOR> [REST STRING]> (OB) STRING
 698                (OC TC C) <OR FALSE CHANNEL> (LEN MSUBR-ACCESS TFILE-LENGTH) FIX
 699                (FCN-COUNT) FIX (LOWERSTR) <OR FALSE STRING>
 700                (OUTCHAN) <SPECIAL ANY> (COMPILER-INPUT) <SPECIAL CHANNEL>)
 701         <COND (,SURVIVOR-MODE
 702                <COND (<OR <NOT <ASSIGNED? READ-TABLE>>
 703                           <L? <LENGTH .READ-TABLE> ,CTLZ+1>>
 704                       <SETG READ-TABLE <SET READ-TABLE <IVECTOR ,CTLZ+1 <>>>>)>
 705                <COND (<NOT <NTH .READ-TABLE ,CTLZ+1>>
 706                       <PUT .READ-TABLE
 707                            ,CTLZ+1
 708                            [<ASCII ,CTLZ> <ASCII !\A> <> <> <>]>)>)>
 709         <SETG GLUE-MODE T>
 710         <SETG PRE-LIST ()>
 711         <SETG PRE-NAMES ()>
 712         <SETG PRE-OPTS ()>
 713         <SETG GLUE-LIST ()>
 714         <SETG GLUE-PC 0>
 715         <SETG MVECTOR (T FOO FOO)>
 716         <MAPR <> <FUNCTION (B:<VECTOR LIST>) <PUT .B 1 ()>> ,MV-TABLE>
 717         <SETG MV-COUNT 0>
 718         <SETG FREE-CONSTS ()>
 719         <SETG CONSTANT-VECTOR ()>
 720         <MAPR <> <FUNCTION (B:<VECTOR LIST>) <PUT .B 1 ()>> ,CONSTANT-TABLE>
 721         <SETG FINAL-LOCALS ()>
 722         <SETG MV <REST ,MVECTOR 2>>
 723         <COND (<AND <SET C <OPEN "READ" <1 .FILES>>>
 724                     <SET OC <OPEN "PRINT" <SET ON <STRING <GET-NM1 <1 .FILES>>
 725                                                   ".MSUBR">>>>
 726                     <SET TOC <OPEN "PRINT" <SET TON <STRING <GET-NM1 <1 .FILES>>
 727                                                             ".TMSUBR">>>>
 728                     <OR <NOT ,MAX-SPACE>
 729                         <SET TC <OPEN "PRINTB"
 730                                       <SET TN <STRING <GET-NM1 <1 .FILES>>
 731                                                        ".MIMOCTEMP">>>>>>
 732                <SETG INCHANS (.C)>
 733                <SET COMPILER-INPUT .C>
 734                <SET FILES <REST .FILES>>
 735                <REPEAT ()
 736                  <REPEAT (NAME ITM TMP SPN L X)
 737                        #DECL ((NAME) ATOM (ITM) <OR <FORM ANY> FALSE>)
 738                        <COND (<SET ITM <FINISH-FILE .C <> .EXPFLOAD>>
 739                               <SET C <1 ,INCHANS>>
 740                               <SET FCN-COUNT <+ .FCN-COUNT 1>>
 741                               <COND (<AND ,SURVIVOR-MODE
 742                                           <==? <1 <SET SPN <SPNAME <2 .ITM>>>>
 743                                                <ASCII ,CTLZ>>>
 744                                      <SET SPN <REST .SPN>>
 745                                      <SET NAME <OR <LOOKUP .SPN ,FCN-OBL>
 746                                                    <INSERT .SPN ,FCN-OBL>>>
 747                                      <PUT .ITM 2 .NAME>
 748                                      <COND (<MAPF <>
 749                                                   <FUNCTION (X:<LIST ATOM LIST>)
 750                                                        <COND (<AND <==? <1 .X>
 751                                                                         .NAME>
 752                                                                    <=? <2 .X>
 753                                                                        .OBLIST>>
 754                                                               <MAPLEAVE>)>>
 755                                                   ,LIST-OF-FCNS>)
 756                                            (ELSE
 757                                             <SETG LIST-OF-FCNS
 758                                                   ((.NAME <LIST !.OBLIST>)
 759                                                    !,LIST-OF-FCNS)>)>)
 760                                     (ELSE
 761                                      <SET NAME <2 .ITM>>)>
 762                               <COND
 763                                (<NOT .LOWERSTR>
 764                                 <SET LOWERSTR
 765                                  <MAPF ,STRING
 766                                   <FUNCTION (CHR "AUX" (I <ASCII .CHR>))
 767                                     #DECL ((CHR) CHARACTER)
 768                                     <COND (<AND <L=? .I <ASCII !\Z>>
 769                                                 <G=? .I <ASCII !\A>>>
 770                                            <ASCII <+ .I 32>>)
 771                                           (.CHR)>>
 772                                   <SPNAME .NAME>>>)>
 773                               <COND
 774                                (<==? <1 .ITM> GFCN>
 775                                 <COND (<EMPTY? ,PRE-NAMES>
 776                                        <PUT ,MVECTOR 2 .NAME>)>
 777                                 <SETG PRE-NAMES (.NAME !,PRE-NAMES)>
 778                                 <COND (<MEMBER "TUPLE" <3 .ITM>>
 779                                        <SETG PRE-OPTS
 780                                              (.NAME <> !,PRE-OPTS)>)
 781                                       (<MEMBER "OPTIONAL" <3 .ITM>>
 782                                        <SET TMP <READ .C>>
 783                                        <MAPR <>
 784                                              <FUNCTION (TP)
 785                                                   #DECL ((TP) <LIST ATOM>)
 786                                                   <PUT .TP 1
 787                                                        <GENLBL
 788                                                         <STRING <SPNAME <1 .TP>>
 789                                                                 <SPNAME .NAME>>>>>
 790                                              <REST <CHTYPE .TMP LIST> 3>>
 791                                        <SETG PRE-OPTS
 792                                              (.NAME .TMP  !,PRE-OPTS)>)>)>
 793                               <SET L <READ-LIST .C END '<ERROR EOF!-ERRORS>>>
 794                               <COND (<N==? <1 .ITM> GFCN> <AGAIN>)>
 795                               <MAPF <>
 796                                     <FUNCTION (ITM "AUX" OP)
 797                                          <COND
 798                                           (<TYPE? .ITM FORM>
 799                                            <COND
 800                                             (<OR <==? <SET OP <1 .ITM>> BIND>
 801                                                  <==? .OP BBIND>
 802                                                  <AND <OR <==? .OP TUPLE>
 803                                                           <==? .OP ADJ>>
 804                                                       <NOT <TYPE? <2 .ITM> FIX>>>
 805                                                  <AND <MEMQ .OP
 806                                                             '[CALL SCALL ACALL
 807                                                               UBLOCK SBLOCK
 808                                                               USBLOCK LIST]>
 809                                                       <NOT <TYPE? <3 .ITM> FIX>>>>
 810                                              <PUTPROP ,PRE-NAMES NDFRM T>
 811                                              <MAPLEAVE>)>)>>
 812                                     .L>)
 813                              (ELSE <RETURN>)>>
 814                  <CLOSE .C>
 815                  <COND (<EMPTY? .FILES>
 816                         <RETURN>)>
 817                  <COND (<SET C <OPEN "READ" <1 .FILES>>>
 818                         <SETG INCHANS (.C)>
 819                         <SET FILES <REST .FILES>>)
 820                        (<ERROR .C FILE-GLUE>)>>
 821                <DETERMINE-VICTIMS>
 822                <SET FILES .TFILES>
 823                <PUT .READ-TABLE ,CTLZ+1 <>>
 824                <COND (<SET C <OPEN "READ" <1 .FILES>>>
 825                       <SETG INCHANS (.C)>
 826                       <SET FILES <REST .FILES>>)
 827                      (<ERROR .C FILE-GLUE>)>
 828                <REPEAT GLOOP (NAME L (NXT <>) (END <>) ITM (FCN-FOUND 0)
 829                         (FIRST T) MSBASE (IFL ()))
 830                    #DECL ((L) LIST (NAME) <SPECIAL ATOM> (NXT) <OR FALSE FORM>
 831                           (END) <SPECIAL <OR FALSE ATOM>>
 832                           (ITM) ANY (FCN-FOUND) FIX (IFL MSBASE) LIST)
 833                    <REPEAT ()
 834                            <COND (<SET ITM <FINISH-FILE .C .TOC .EXPFLOAD>>
 835                                   <SET C <1 ,INCHANS>>
 836                                   <SET FCN-FOUND <+ .FCN-FOUND 1>>
 837                                   <RETURN <SET NXT .ITM>>)
 838                                  (T
 839                                   <CLOSE .C>
 840                                   <COND (<EMPTY? .FILES>
 841                                          <RETURN T .GLOOP>)>
 842                                   <COND (<SET C <OPEN "READ" <1 .FILES>>>
 843                                          <SETG INCHANS (.C)>
 844                                          <SET FILES <REST .FILES>>)
 845                                         (<ERROR .C FILE-GLUE>)>)>>
 846                    <SET L (.NXT !<READ-LIST .C END '<SET END T>>)>
 847                    <COND (.END <CLOSE .C>)>
 848                    <COND (,VERBOSE
 849                           <OR <==? .OUTCHAN ,OUTCHAN>
 850                               <PRINC <ASCII 12>>>
 851                           <CRLF>
 852                           <PRINC "Open coding: ">
 853                           <PRIN1 <SET NAME <2 .NXT>>>)
 854                          (ELSE
 855                           <SET NAME <2 .NXT>>)>
 856                    <PROCESS-IFSYS .L>
 857                    <CALL-ANA .L>
 858                    <MIMOC .L <AND ,SURVIVOR-MODE
 859                                   <SET PN <FIND-CALL .NAME ,PRE-NAMES>>
 860                                   <NOT <GETPROP .PN NDFRM>>
 861                                   <NOT <FIND-OPT .NAME ,PRE-OPTS>>
 862                                   <NOT <SURVIVOR? .NAME>>>>
 863                    <UNASSIGN NAME>
 864                    <LOCATION-CHECK>
 865                    <COND (,MAX-SPACE
 866                           <PRINTTYPE LOCAL-NAME ,PRINT>
 867                           <PRINTTYPE CONSTANT-LABEL ,PRINT>
 868                           <FIXUP-ONE-GLUE <REST ,CODE> ,LABELS>
 869                           <FIXUP-CONSTANTS <REST ,CODE> ()>
 870                           <DUMP-CODE ,CODE .TC>
 871                           <PRINTTYPE LOCAL-NAME ,PLOCAL-NAME>
 872                           <PRINTTYPE CONSTANT-LABEL ,PCONST-LABEL>)>
 873                    <MAPF <>
 874                          <FUNCTION (LB) #DECL ((LB) LAB)
 875                               <LAB-STATE .LB ()>
 876                               <LAB-FINAL-STATE .LB <>>
 877                               <LAB-DEAD-VARS .LB ()>
 878                               <LAB-CODE-PNTR .LB ()>
 879                               <REMOVE <LAB-NAM .LB>>>
 880                          ,LABELS>
 881                    <SETG GLUE-LIST (<SET MSBASE
 882                                      (,GLUE-NAME
 883                                       ,GLUE-DECL
 884                                       ,GLUE-PC
 885                                       <COND (,MAX-SPACE ()) (ELSE ,CODE)>
 886                                       ,LABELS
 887                                       ,GREFS
 888                                       ,GCALS)>
 889                                     !,GLUE-LIST)>
 890                    <COND (.FIRST
 891                           <SET FIRST <>>
 892                           <SET MSUBR-ACCESS <DO-ACCESS .TOC>>)>
 893                    <COND (<OR <NOT ,SURVIVOR-MODE>
 894                               <SURVIVOR? <1 .MSBASE>>>
 895                           <PRINT-ENTRY .MSBASE .TOC .LOWERSTR>)>
 896                    <SETG GLUE-PC <+ ,GLUE-PC ,CODE-LENGTH>>
 897                    <COND (<==? .FCN-COUNT .FCN-FOUND>
 898                           <RETURN>)>>
 899                <ALLOCATE-CONSTANTS ,CONSTANT-VECTOR  ,GLUE-PC>
 900                <CLOSE .TOC>
 901                <SET TFILE-LENGTH <- <FILE-LENGTH <SET TOC <OPEN "READ" .TON>>>
 902                                     .MSUBR-ACCESS>>
 903                <REPEAT ((BUFSTR <ISTRING 1024>))
 904                        <COND (<L? .MSUBR-ACCESS 1024>
 905                               <SET BUFSTR
 906                                    <REST .BUFSTR <- 1024 .MSUBR-ACCESS>>>)>
 907                        <COND (<NOT <EMPTY? .BUFSTR>>
 908                               <READSTRING .BUFSTR .TOC>
 909                               <PRINTSTRING .BUFSTR .OC>)>
 910                        <COND (<L=? <SET MSUBR-ACCESS <- .MSUBR-ACCESS 1024>> 0>
 911                               <RETURN>)>>
 912                <COND (.TC
 913                       <CLOSE .TC>
 914                       <SET TC <OPEN "READB" .TN>>
 915                       <COND (,VERBOSE
 916                              <PRINC "
 917 Doing fixup and output
 918 ">)>
 919                       <SET NMSTR <WRITE-MSUBR .OC .LOWERSTR>>
 920                       <MAPF <>
 921                             <FUNCTION (FROB "AUX" (CODE <READ-CODE .TC>))
 922                                  #DECL ((FROB) <LIST ATOM LIST FIX LIST LIST>
 923                                         (CODE) UVECTOR)
 924                                  <MAPF <>
 925                                        <FUNCTION (X) #DECL ((X) <LIST FIX>)
 926                                            <PUT .CODE
 927                                                 <1 .X>
 928                                                 <CHTYPE <ORB <NTH .CODE <1 .X>>
 929                                                              <GFIND <2 .X> <3 .X>>>
 930                                                         FIX>>>
 931                                        <CHTYPE <7 .FROB> LIST>>
 932                                  <MAPF <>
 933                                        <FUNCTION (X)
 934                                             #DECL ((X) <LIST FIX CONSTANT-BUCKET>)
 935                                             <PUT .CODE
 936                                                  <1 .X>
 937                                                  <ORB <NTH .CODE <1 .X>>
 938                                                       <CB-LOC <2 .X>>>>>
 939                                        <6 .FROB>>
 940                                  <MAPF <>
 941                                        <FUNCTION (WRD)
 942                                            <REPEAT ((I 4)) #DECL ((I) FIX)
 943                                                    <PRINTBYTE
 944                                                         <SET WRD
 945                                                              <CHTYPE
 946                                                               <ROT .WRD 9> FIX>>>
 947                                                    <COND (<==? <SET I <- .I 1>> 0>
 948                                                           <RETURN>)>>>
 949                                        .CODE>
 950                                  <SET LEN <+ <LENGTH .CODE> .LEN>>>
 951                             ,GLUE-LIST>
 952                       <CLOSE .TC>
 953                       <DELFILE .TN>
 954                       <SETG MAX-SPACE <>>
 955                       <WRITE-CODE .OC .NMSTR () .OB .LEN>
 956                       <AND ,INT-MODE <PRINTTYPE ATOM ,PRINT>>
 957                       <REPEAT ((BUFSTR <ISTRING 1024>))
 958                               #DECL ((BUFSTR) STRING)
 959                               <COND (<L? .TFILE-LENGTH 1024>
 960                                      <SET BUFSTR
 961                                           <REST .BUFSTR <- 1024 .TFILE-LENGTH>>>)>
 962                               <READSTRING .BUFSTR .TOC>
 963                               <PRINTSTRING .BUFSTR .OC>
 964                               <COND (<L? <SET TFILE-LENGTH
 965                                               <- .TFILE-LENGTH  1024>> 0>
 966                                      <RETURN>)>>
 967                       <FINISH-FILE .C .OC .EXPFLOAD>
 968                       <CLOSE .OC>)
 969                      (ELSE
 970                       <COND (,VERBOSE
 971                              <PRINC "
 972 Fixing Up CALLs
 973 ">)>
 974                       <GLUE-FIXUP>
 975                       <COND (,VERBOSE
 976                              <PRINC "Writing MSUBR
 977 ">)>
 978                       <WRITE-MSUBR .OC .LOWERSTR>
 979                       <REPEAT ((BUFSTR <ISTRING 1024>))
 980                        #DECL ((BUFSTR) STRING)
 981                        <COND (<L? .TFILE-LENGTH 1024>
 982                               <SET BUFSTR
 983                                    <REST .BUFSTR <- 1024 .TFILE-LENGTH>>>)>
 984                        <READSTRING .BUFSTR .TOC>
 985                        <PRINTSTRING .BUFSTR .OC>
 986                        <COND (<L? <SET TFILE-LENGTH
 987                                        <- .TFILE-LENGTH  1024>> 0>
 988                               <RETURN>)>>
 989                <FINISH-FILE .C .OC .EXPFLOAD>
 990                <CLOSE .C>
 991                <CLOSE .OC>)>
 992                <CLOSE .TOC>
 993                <DELFILE .TON>
 994                ,NULL)
 995               (ELSE
 996                <COND (<AND <ASSIGNED? C> .C>
 997                       <CLOSE .C>
 998                       <COND (<AND <ASSIGNED? OC> .OC>
 999                              <CLOSE .OC>
1000                              <DELFILE .ON>
1001                              <ERROR .TC>)
1002                             (ELSE <ERROR .OC>)>)
1003                      (ELSE
1004                       <ERROR .C>)>)>>
1005
1006 <DEFMAC DO-ACCESS ('CH)
1007         <COND (<GASSIGNED? M-HLEN> <FORM ACCESS .CH>)
1008               (ELSE <FORM 17 .CH>)>>
1009
1010 <DEFINE SURVIVOR? (A "AUX" (SP <SPNAME .A>) (VL ,VICTIMS))
1011         #DECL ((VL) LIST)
1012         <NOT <OR <MEMQ .A .VL>
1013                  <MEMBER .SP .VL>
1014                  <MAPF <>
1015                        <FUNCTION (OBJ)
1016                                <COND (<AND <TYPE? .OBJ LIST>
1017                                            <=? <1 .OBJ> .SP>
1018                                            <MEMQ <OBLIST? .A>
1019                                                  <CHTYPE <2 .OBJ> LIST>>>
1020                                       <MAPLEAVE>)>>
1021                        .VL>>>>
1022
1023 <DEFMAC CHTYPE-OBLIST ('O)
1024         <COND (<GASSIGNED? M-HLEN> <FORM CHTYPE .O ATOM>)
1025               (ELSE <FORM GETPROP .O OBLIST>)>>
1026
1027 <DEFINE DETERMINE-VICTIMS ("AUX" (VL ()) (LOF ,LIST-OF-FCNS))
1028         #DECL ((VL LOF AO) LIST)
1029         <MAPF <>
1030               <FUNCTION (LL "AUX" (A <1 .LL>) (SP <SPNAME .A>) O (PP <>)
1031                                   PO)
1032                    #DECL ((LL) !<LIST ATOM LIST>)
1033                    <COND (<OR <EMPTY? ,PRE-NAMES>
1034                               <MAPR <>
1035                                     <FUNCTION (PN "AUX" (NM <1 .PN>))
1036                                          #DECL ((PN) LIST)
1037                                          <COND (<=? <SPNAME .NM> .SP>
1038                                                 <SET PP .PN>
1039                                                 <MAPLEAVE <>>)
1040                                                (ELSE T)>>
1041                                     ,PRE-NAMES>
1042                               <AND ,INT-MODE
1043                                    <OR <L? <LENGTH .SP> 2>
1044                                        <NOT <AND <==? <1 .SP> !\I>
1045                                                  <==? <2 .SP> !\$>>>>>
1046                               <AND <SET O <OBLIST? .A>>
1047                                    <SET O <OBLIST? <CHTYPE-OBLIST .O>>>
1048                                    <OR <==? .O ,PKG-OBL> <==? .O <ROOT>>>>
1049                               <MAPF <>
1050                                     <FUNCTION (NM)
1051                                          <COND (<AND <=? <SPNAME .NM> .SP>
1052                                                      <MEMQ <OBLIST? .NM> <2 .LL>>>
1053                                                 <MAPLEAVE T>)>>
1054                                     ,SURVIVORS>>)
1055                          (<NOT <MAPF <>
1056                                 <FUNCTION (O)
1057                                      <COND (<LOOKUP .SP .O> <MAPLEAVE>)>>
1058                                 <2 .LL>>>
1059                           <SET VL ((.SP <2 .LL>) !.VL)>)>
1060                    <COND (.PP
1061                           <PUT .PP 1 <OR <MAPF <>
1062                                                <FUNCTION (O "AUX" AA)
1063                                                     <COND (<SET AA
1064                                                                 <LOOKUP .SP
1065                                                                         .O>>
1066                                                            <MAPLEAVE .AA>)>>
1067                                                <2 .LL>>
1068                                          <INSERT .SP <1 <2 .LL>>>>>
1069                           <COND (<SET PO <MEMQ .A ,PRE-OPTS>>
1070                                  <PUT .PO 1 <1 .PP>>)>)>>
1071               .LOF>
1072         <SETG VICTIMS (!,VICTIMS !.VL)>
1073         <SETG FIRST-PASS-SURVIVOR-GLUE <>>>
1074
1075 <GDECL (GLUE-LIST) <LIST [REST LIST]>>
1076
1077 <DEFINE PRINT-ENTRY (MSBASE OUTCHAN LOWERSTR)
1078   #DECL ((MSBASE) LIST (OUTCHAN) CHANNEL)
1079   <COND (,INT-MODE <PRINTTYPE ATOM ,ATOM-PRINT>)>
1080   <WIDTH-MUNG .OUTCHAN 100000000>
1081   <PRINC "<SETG " .OUTCHAN>
1082   <PRIN1 <1 .MSBASE> .OUTCHAN>
1083   <PRINC " #MSUBR [" .OUTCHAN>
1084   <PRINC .LOWERSTR .OUTCHAN>
1085   <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OUTCHAN>)
1086         (ELSE <PRINC "-IMSUBR " .OUTCHAN>)>
1087   <PRIN1 <1 .MSBASE> .OUTCHAN>
1088   <PRINC !\  .OUTCHAN>
1089   <PRIN1 <2 .MSBASE> .OUTCHAN>
1090   <PRINC !\  .OUTCHAN>
1091   <PRIN1 <3 .MSBASE> .OUTCHAN>
1092   <PRINC "]>" .OUTCHAN>
1093   <CRLF .OUTCHAN>
1094   <COND (,INT-MODE <PRINTTYPE ATOM ,PRINT>)>
1095   <WIDTH-MUNG .OUTCHAN 80>>
1096
1097 <DEFINE FINISH-FILE (INCHAN OUTCHAN EXPFLOAD "OPTIONAL" END?
1098                      (EVAL? T) "AUX" (IND '(1)) (WORD-OK? <>))
1099   #DECL ((INCHAN) CHANNEL (OUTCHAN) <OR CHANNEL FALSE>
1100          (END?) <VECTOR [REST ATOM]> (EXPFLOAD EVAL?) <OR ATOM FALSE>)
1101   <COND (<NOT <ASSIGNED? END?>>
1102          <SET WORD-OK? T>
1103          <SET END? '[FCN GFCN]>)>
1104   <REPEAT (ITM NCH)
1105     <COND (<==? <SET ITM <READ .INCHAN '.IND>> .IND>
1106            <CLOSE .INCHAN>
1107            <COND (<EMPTY? <SETG INCHANS <REST ,INCHANS>>>
1108                   <RETURN <>>)>
1109            <SET INCHAN <1 ,INCHANS>>
1110            <AGAIN>)>
1111     <COND (<NOT <OR <TYPE? .ITM STRING CHARACTER FIX>
1112                     <AND <TYPE? .ITM ATOM>
1113                          <=? <SPNAME .ITM> "\f">>>>
1114            <COND (<AND <TYPE? .ITM FORM>
1115                        <NOT <EMPTY? .ITM>>
1116                        <MEMQ <1 .ITM> .END?>>
1117                   <RETURN .ITM>)
1118                  (<AND .WORD-OK? <TYPE? .ITM WORD>>
1119                   <COND (<OR ,INT-MODE ,BOOT-MODE ,GLUE-MODE> <AGAIN>)>
1120                   <COND (.OUTCHAN
1121                          <PRINC ,WORD-STRING .OUTCHAN>
1122                          <PRIN-OCT <CHTYPE .ITM FIX> .OUTCHAN>
1123                          <CRLF .OUTCHAN>)>
1124                   <RETURN .ITM>)>
1125            <COND (<AND .EXPFLOAD
1126                        <TYPE? .ITM FORM>
1127                        <NOT <EMPTY? .ITM>>
1128                        <COND (<==? <1 .ITM> FLOAD>
1129                               <SET NCH <OPEN "READ" !<REST .ITM>>>)
1130                              (<==? <1 .ITM> L-FLOAD>
1131                               <SET NCH <L-OPEN <2 .ITM>>>)>>
1132                   <SET INCHAN .NCH>
1133                   <SETG INCHANS (.NCH !,INCHANS)>)
1134                  (T
1135                   <COND (.EVAL?
1136                          <PROG (SG AZ TMP)
1137                                <COND (<AND <TYPE? .ITM FORM>
1138                                             <NOT <EMPTY? .ITM>>
1139                                             <MEMQ <1 .ITM>
1140                                                   '[INCLUDE-WHEN USE-WHEN]>
1141                                             <NOT <EMPTY? <REST .ITM>>>
1142                                             <TYPE? <SET TMP <2 .ITM>> FORM>
1143                                             <NOT <EMPTY? .TMP>>
1144                                             <==? <1 .TMP> COMPILING?>>
1145                                        <EVAL .ITM>
1146                                        <PUT .TMP 1 DEBUGGING?>)
1147                                       (ELSE
1148                                        <EVAL .ITM>)>>)>
1149                   <COND (.OUTCHAN
1150                          <COND (,INT-MODE <PRINTTYPE ATOM ,ATOM-PRINT>)>
1151                          <PRINTTYPE CHARACTER ,CHR-PRINT>
1152                          <WIDTH-MUNG .OUTCHAN 100000>
1153                          <PRIN1 .ITM .OUTCHAN>
1154                          <CRLF .OUTCHAN>
1155                          <WIDTH-MUNG .OUTCHAN 80>
1156                          <COND (,INT-MODE <PRINTTYPE ATOM ,PRINT>)>
1157                          <PRINTTYPE CHARACTER ,PRINT>)>)>)>>>
1158
1159 <DEFINE PRIN-OCT (X CH)
1160         #DECL ((X) FIX)
1161         <PRINC !\* .CH>
1162         <COND (<0? .X> <PRINC !\0 .CH>)
1163               (ELSE <POCT .X .CH>)>
1164         <PRINC !\* .CH>>
1165
1166 <DEFINE POCT (X CH) #DECL ((X) FIX)
1167         <COND (<N==? .X 0>
1168                <POCT <LSH .X -3> .CH>
1169                <PRINC <ASCII <+ <ANDB .X 7> <ASCII !\0>>> .CH>)>>
1170
1171
1172 <GDECL (SUBRIFIED-PKGS SUBRIFIED-MSUBRS) <LIST [REST ATOM]>>
1173
1174 <DEFINE SUBRIFY? (NAME "AUX" (OBL <OBLIST? .NAME>) MS OO)
1175         <COND (<AND <GASSIGNED? .NAME>
1176                     <TYPE? <SET MS ,.NAME> MSUBR>
1177                     <OR <AND .OBL
1178                              <OR <==? <SET OO <OBLIST? <CHTYPE .OBL ATOM>>>
1179                                       #OBLIST PACKAGE>
1180                                  <AND <==? <OBLIST? <CHTYPE .OO ATOM>>
1181                                            #OBLIST PACKAGE>
1182                                       <SET OBL .OO>>>
1183                              <MEMQ <CHTYPE .OBL ATOM> ,SUBRIFIED-PKGS>>
1184                         <MEMQ .NAME ,SUBRIFIED-MSUBRS>>>
1185                <CHTYPE [.NAME
1186                         <REPEAT ((DCL:LIST <REST <3 .MS> 2>) (CNT:FIX 0) IT)
1187                                 <COND (<EMPTY? .DCL> <RETURN .CNT>)>
1188                                 <COND (<NOT <TYPE? <SET IT <1 .DCL>> STRING>>
1189                                        <SET CNT <+ .CNT 1>>)
1190                                       (<MEMQ .IT '["OPT" "OPTIONAL" "TUPLE"]>
1191                                        <RETURN <>>)>
1192                                 <SET DCL <REST .DCL>>>] SUBR-INFO>)>>
1193
1194 <DEFINE PRINT-SUBR-INFO (S:SUBR-INFO)
1195         <PRINC "%<SUBR-ENTRY ">
1196         <PRIN1 <1 .S>>
1197         <PRINC ">">>
1198
1199 <COND (<GASSIGNED? PRINT-SUBR-INFO>
1200        <PRINTTYPE SUBR-INFO ,PRINT-SUBR-INFO>)>