*DECK     END 
          IDENT  END
 END      SECT   (BINARY OUTPUT),1
  
          SST    A,B,D,E,F
          NOREF  A,B,D,E,F
  
 B=END    RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  CKS,CKS65,CKS67,BT.IDNT,BT.XFR1,WCLX,WVMX,END
          ENTRY  DDS.O,DDS.R,DDS.S,DDS.W,BT.IDN9,DLF
          ENTRY  BT.IDN8,END96,LFS.MAX
          ENTRY  OTRSAV 
          ENTRY  END93
  
*         IN FTN
          EXT    CO.TBK,CO.SNAP,CP.ERCT,CP.MXFL,F.LF,F.LGO
          EXT    FV.LGO,LOP=O,LOP=M,LGOIO,PLIMIT
          EXT    CO.ER
  
*         IN TABLES 
          EXT    BINIO,BINOUT,BA.CON,BA.FMT,BA.VAR,BA.NLST,BA.BUF,BA.PRO
          EXT    BA.APL,BA.TEM,CDD,ENTRY.,ERRORS,FAILSFT,IDENT
          EXT    LINEBUF,LOCAL,MSN,MOD,MSF,NARGS,NREXT,NSK,ORG
          EXT    PASS,PARCEL,TA.PRO,NOLIST
          EXT    TEM.MAX,TG.VDIM,TP=FMT,TP=APL,TP=NLST,TP.APL,TP.DIM
          EXT    TP=DO,TP.DO,TP.FMT,TP.NLST,TS=EQU,TS=CON,TS=STN,TS.STN 
          EXT    TS.SYM,TS.ENT,TS=ENT,TS.CON,TS=DAT,TS.DAT,TS=BLK,TS.BLK
          EXT    TT=ASF,TT=USE,TT=SCR,TS=SYM,TT=LINK,TT=FILL,TT.LINK
          EXT    TT.FILL,TT=LF,TT.SCR,TT.LF,T=FILE,T.FILE,TA=NAM,TA.NAM 
  
*         IN ERRORS 
          EXT    ERR=F,E.DO9,E.MN,E.MO1,E.MS,E.M$,E.ZA,FILL.
          EXT    E.SU11 
  
*         IN BATCH
          EXT    RUN.X
  
*         IN PIG
          EXT    PIK=PS,WIN,PIG 
  
*         IN ALLOC
          EXT    ADW,SRT
  
*         IN MAIN 
          EXT    WBL
  
*         IN KEY
          EXT    RTU,SVALUE.
  
*         IN GEN
          EXT    CAI,FVD
  
*         IN INIT 
          EXT    EQUA 
 END      SPACE  4,8
**        PASS *THREE* -- ASSEMBLE THE OBJECT CODE. 
* 
*         *END*  MAIN CONTROLLING ROUTINE.  COMPUTES BLOCK LENGTHS AND
*                ASSIGNS ALL ADDRESSES, RESERVING STORAGE WHERE 
*                NECESSARY.  ALSO CALLS *PASS TWO* TO WRAPUP THE FINAL
*                PIECES, AND *MAP* TO PRINT LISTINGS. 
* 
*         *CKS*  DIAGNOSE MISSING STATEMENT LABELS, AND UNTERMINATED
*                *DO* LOOPS.
* 
*         *DDS*  DUMP DATA STATEMENTS -- READS THE TRANSLATED *DATA*
*                STATEMENTS FROM *TS.DAT* AND PRODUCES CORRESPONDING
*                BINARY TABLES FOR THE LOADER.
* 
*         *DFT*  INITIALIZES THE BINARY OUTPUT, CHECKING ERROR COUNTS TO
*                DETERMINE IF BINARY SHOULD BE PRODUCED.  IF NOT, IT
*                OUTPUTS AN *ERRORS* DIRECTIVE IN THE BINARY, AND EXITS 
*                BACK INTO *END*, BYPASSING THE REST OF THE BINARY
*                OUTPUT.
* 
*         *DLF*  FLUSHES THE LINK AND FILL TABLES ACCUMULATED BY THE
*                OTHER PROCESSORS.
* 
*         *DTX*  FLUSHES THE *TEXT* TABLE BEING CONSTRUCTED, AND RESETS 
*                THE ORIGIN COUNTER APPROPRIATELY.
* 
*         *KAP*  TRANSLATES THE AP-LISTS GENERATED IN *TP.APL* INTO 
*                THE BINARY OUTPUT. 
* 
*         *KCF*  DUMPS THE SAVED CONSTANTS (TS.CON) AND FORMATS (TP.FMT)
*                INTO THE BINARY. 
* 
*         *KNS*  READS THE TRANSLATED *NAMELIST* GROUP DEFINITIONS FROM 
*                *TP.NLST* AND PRODUCES APPROPRIATE BINARY. 
* 
*         *RAD*  READS PSEUDO-OBJECT CODE FROM *T.INT* (OR THE OVERFLOW 
*                FILE), FILLING IN ACTUAL ADDRESSES AND RELOCATION BASES
*                AND WRITING BINARY.
* 
*         *REL*  CALLED BY OTHER ROUTINES TO DETERMINE VALUE AND
*                RELOCATION OF TAGS.
* 
*         *RIN*  READS ONE WORD FROM INTERMEDIATE -- EITHER THE TABLE,
*                *T.INT*, OR THE FILE.
* 
*         *STX*  STORES ONE WORD INTO THE *TEXT* CURRENTLY BEING BUILT, 
*                UPDATING ORIGIN COUNTER AND RELOCATION BYTES.
* 
*         *WLF*  DOES THE ACTUAL WRITE TO THE BINARY, WHETHER IT BE A 
*                FILE (*LGO*), OR, WHEN COMPILING-TO-CORE, ADDING TO A
*                TABLE (*T.LGO*). 
 WLGO     SPACE  4,8
**        WLGO - MACRO TO OUTPUT BINARY TO LGO. 
* 
*         WLGO   FWA,WC 
* 
*         ENTRY  FWA = SOURCE ADDRESS OF WORDS TO BE OUTPUT (B6). 
*                WC  = NUMBER OF WORDS TO OUTPUT  (B7). 
*         CALLS  WLF
  
  
 WLGO     MACRO  F,W
          =B6    F
          =B7    W
          RJ     WLF
 WLGO     ENDM
 END      SPACE  4,15 
**        END -  * E N D *   PROCESSING -- PASS 2 OF COMPILER.
* 
*         1.     ASSIGN ALL ADDRESSES THAT ARE NOT YET KNOWN, RESERVING 
*                STORAGE WHERE NECESSARY. 
*         2.     OUTPUT THE RELOCATABLE BINARY OBJECT FILE, MOSTLY
*                FROM THE *LONG FILE*.
*         3.     MAP IS CALLED TO PRINT THE VARIOUS VARIABLE MAPS AND 
*                OTHER LISTINGS.
*         4.     WRAP UP, PRINT STATISTICS, AND RETURN TO BATCH CONTROL.
  
  
 END      BSS    0
          SA1    MOD
          IFBIT  X1,-PFNC,END10    IF NOT COMPILING A FUNCTION PROGRAM
          SB4    SVALUE.
          RJ     =XTRV
          IFBIT  X6,DEF,END10      IF FUNCTION NAME IS DEFINED
          FATAL  E.SU11      FUNCTION NAME UNDEFINED
 END10    SA1    FAILSFT
          NZ     X1,END70    IF TABLES ARE MESSED UP, BYPASS EVERYTHING 
          SA3    MOD
          SX6    M.PFNC+M.PSUB
          BX0    X6*X3
          ZR     X0,END15    IF NOT PROCEDURE SUBPROGRAM
          RJ     RTU
 END15    RJ     CAI         FLUSH PARSED FILE
          RJ     FVD         FLUSH VARIABLE DIMENSION CODE
          SHRINK TT=ASF,0 
          SHRINK TT=USE,X6
          SHRINK =XT=SB,X6
          SHRINK TT=SCR,X6
          SHRINK TS=EQU,X6
          WCODE  0           MARK END OF PROGRAM BY FORCE UPPER 
          =A2    =XERRORS    FATAL ERROR COUNTER
          =A1    =XMOD
          NZ     X2,END17    IF FATAL 
          SBIT   X1,PBLK
          MI     X1,END17    IF BLOCKDATA 
          RJ     PIG         PROCESS FINAL INSTRUCTION GROUP. 
 END17    SA1    BINIO
          PL     X1,END20    IF INTERMEDIATE IN CORE
          WRITER F.LF 
          REWIND F.LF 
  
          IFNE   CP#RM,7,1
          READ   F.LF 
  
 END20    =X6    PASS=END 
          SA6    PASS 
          SA1    TT=LF
          BX6    X1 
          SA6    =XIGS       SET IGS TO END OF LF FOR ALLOC 
  
**        FORM BASE ADDRESSES 
  
          SA1    ORG
          SA2    TS=CON 
          SA3    TP=FMT 
          BX6    X1 
          SA4    TEM.MAX
          SA6    BA.CON      BASE OF CONSTANTS = LWA CODE 
          IX7    X2+X6
          SA1    TG.VDIM
          SX4    X4-C.TEM 
          SA7    A6+B1       BA.FMT = (BA.CON) + (NR OF CONSTANTS)
          IX6    X7+X3
          SA5    TP=APL 
          SX2    X1-C.VDIM
          IX4    X4+X2       NR OF (TEMP TAGS) = (TEMPS) + (VAR-DIMS) 
          SA6    A7+B1       BA.TEM = (BA.FMT) + (LEN OF FORMATS) 
          IX7    X4+X6
          SA3    TP=NLST
          SA7    A6+B1       BA.APL = (BA.TEM) + (NR OF TEMP TAGS)
          IX6    X7+X5
          SA6    A7+B1       BA.NLST = (BA.APL) + (LEN OF AP-LISTS) 
          IX7    X6+X3
          SA7    A6+B1       BA.VAR = (BA.NLST) + (LEN OF NAME-LISTS) 
  
  
**        COMPUTE ADDRESSES OF FORMATS. 
*                = (SN.ADR(TT.STAT)) + (BA.FMT) 
*         ALSO FORMS LOGICAL SUM OF THE *UNDEFINED* BITS OF ALL 
*                STATEMENT LABELS.
  
          SA2    TS=STN 
          SA1    TS.STN 
          SB7    59-P.SNFMT 
          SB4    X2          (B4) = LENGTH OF TABLE 
          =B2    2
          SA4    BA.FMT 
          SA3    X1-1 
          BX7    0
          LX4    P.SNAD 
          =X3    M.SNDEF     FAKE LOOP 1ST TIME FOR STACK 
  
 END24    SB4    B4-B2
          LX0    X3,B7
          ZR     X3,END26    IF EMPTY ENTRY 
          IX6    X3+X4
          BX7    -X3+X7      ACCUMULATE UNDEF BITS
          NO
          PL     X0,END26    IF NOT A *FORMAT* LABEL
          SA6    A3          RELOCATE ITS ADDRESS 
 END26    SA3    A3+B2
          PL     B4,END24    IF TABLE NOT EXHAUSTED 
          SA7    MSN
  
  
**        RELOCATE LOCAL EQUIVALENCED VARIABLES.
  
          SA1    TA=NAM 
          SA2    TS.SYM 
          SA3    TA.NAM 
 A        DECMIC P.BLOCK+17 
          SA4    =1S"A" 
          SA5    BA.VAR 
          SB7    59-P.BLOCK-17
          SB4    X1-1        (B4) = LENGTH OF ADDRESS TABLE 
          SB5    X2          (B5) = FWA SYMBOL TABLE
          SB6    X3          (B6) = FWA ADDRESS TABLE 
          IX5    X5-X4
  
 END27    SA4    B4+B6
          MI     B4,END28    IF TABLE EXHAUSTED 
          =B4    B4-1 
          LX1    X4,B7
          IX6    X5+X4
          PL     X1,END27    IF NOT LOCAL-EQUIV (BLOCK = 1S17)
          SA6    A4          ADD (BA.VAR) AND CLEAR BLOCK NUMBER
          EQ     END27       LOOP.. 
  
  
**        ASSIGN STORAGE FOR UNIQUE LOCAL VARIABLES 
  
 END28    SA2    TS=SYM 
          SA1    TA=NAM 
          AX2    1
          IX0    X2-X1
          ALLOC  TA.NAM,X0   ALLOCATE TA.NAM ONE WORD PER SYMBOL
          SA3    TS.SYM 
          SA4    TP.DIM 
          SB6    X1          B6 = FWA ADDRESS TABLE 
          SB7    X2          B7 = NUMBER OF SYMBOL ENTRIES
          SB5    X4          B5 = FWA ARRAY PARAMETERS
          SA5    BA.VAR 
          SA2    EQUA 
          =B3    2
          SA3    X3-1        INITIALIZE SYMBOL FETCH
          CLAS=  X0,(NVAR,COMM,EQUIV,NLST,EXT,ENT,FP) 
          IX5    X5+X2       ADD IN LOCAL-EQUIVALENCE-LENGTH
  
 END3     SA3    A3+B3
          ZR     B7,END32    IF TABLE EXHAUSTED 
          SB7    B7-B1
          BX2    X0*X3
          SB6    B6+B1
          LX3    -P.PNT 
          ZR     X3,END3     **** KLUDGE, AVOID NULL ENTRIES
          NZ     X2,END3     IF NOT UNIQUE LOCAL, AVOID.. 
          MX1    -L.PNT 
          BX2    -X1*X3      ISOLATE TP.DIM ORDINAL 
          SA4    X2+B5
          SBIT   X3,LONG/PNT-1
          BX6    X5 
          AX4    P.DIMLG
          SX4    X4 
          AX3    -0          -0 IFF LONG, ELSE +0 
          BX2    X3*X4       X4         ,      +0 
          IX7    X5+X4
          SA6    B6-B1
          IX5    X2+X7       ADD LENGTH AGAIN IF DOUBLE-WORD ELEMENT
          EQ     END3        LOOP.. 
  
  
**        ASSIGN MISCELLANEOUS ADDRESSES. 
*                NAMELIST -- (P.ARR(TT.NAM)) + (BA.NLST)
*                EXTERNAL -- 400000B
*         ALL OTHERS IN *NAM* TABLE ARE ALREADY DONE. 
  
 END32    SA1    TA=NAM 
          SA2    TS.SYM 
          BX7    X5 
          SA3    TA.NAM 
          SB2    X1          B2 = LENGTH OF TABLE 
          SA7    A5+B1       LOCAL LENGTH = (BA.VAR) + (UNIQUE STORAGE) 
          CLAS=  X0,(NLST,EXT)
          =X7    1
          SA5    CO.TBK 
          SA4    BA.NLST
          SX6    1R"EXT"
          AX5    -1          -0 IFF TRACEBACK ON
          SB4    X2          B4 = FWA SYMBOL TABLE
          =X1    1
          SB3    X3          B3 = FWA ADDRESS TABLE 
          SB6    X3          SAVE (B6) = FWA ADDRESS TABLE
          LX1    P.EXT-P.PNT
          =B5    2
          SA3    B4-B1       FETCH FIRST TAG WORD 
          BX5    -X5*X6      SUFFIX (OR ZERO) FOR BEF-S 
          EQ     END34       BEGIN..
  
 END33    LX6    P.PNT-P.EXT+17 
          SX7    X7+1        COUNT EXTERNALS
          SBIT   X3,BEF/PNT-1 
          =A6    B3-1 
          MX2    -L.JPADF 
          PL     X3,END34    IF NOT A BASIC-EXTERNAL-FUNCTION 
          SBIT   X3,JPADF/BEF+1 
          BX6    -X2*X3      ISOLATE SHIFT COUNT
          =A2    A3-1        FETCH SYMBOL NAME
          SB7    X6 
          LX3    X5,B7
          BX6    X2+X3       APPEND SUFFIX TO BEF NAME
          SA6    A2 
  
 END34    SA3    A3+B5       FETCH TAG TABLE ENTRY
          ZR     B2,END35    IF TABLE EXHAUSTED 
          SB2    B2-B1
          BX2    X0*X3
          SB3    B3+B1
          ZR     X2,END34    IF NOT FOR US TO DO
          LX3    -P.PNT 
          BX6    X1*X3       ISOLATE EXTERNAL BIT 
          SX2    X3 
          NZ     X6,END33    IF EXTERNAL
  
          IX6    X2+X4       RE-LOCATE NAMELIST GROUP ADDRESS 
          SA6    B3-B1
          EQ     END34       LOOP.. 
  
 END35    BSS    0
          SA7    NREXT       SAVE COUNT OF EXTERNALS
  
  
**        PUT ENTRY POINT ADDRESSES INTO ADDRESS TABLE. 
*                SQUEEZES OUT ANY -FAKE- ENTRY POINTS WHICH MAY BE
*         PRESENT DUE TO FILE LINKAGE SUPPRESSION (*SYSEDIT* OPTION). 
*                (B4) = FWA SYMBOL TABLE. 
*                (B6) = FWA ADDRESS TABLE.
  
          SA1    TS.ENT 
          SA5    TS=ENT 
          SA4    X1          FETCH FIRST ENTRY POINT
          =B4    B4+1        FUDGE..... 
          SB3    X5          (B3) = NUMBER OF E.P.
          =B7    0
  
 END36    SA3    X4+B4       FETCH TAG WORD 
          SX5    X4 
          BX6    X4 
          AX3    P.PNT
          =A4    A4+1 
          =B3    B3-1        COUNT DOWN LENGTH
          AX5    1
          SX7    X3 
          MI     X6,END37    IF FAKE E.P. 
          SA6    X1+B7
          =B7    B7+1 
 END37    SA7    X5+B6
          GT     B3,END36    IF MORE ENTRY POINTS 
          SHRINK A5,B7
  
  
**        ASSIGN BUFFER ADDRESSES.
  
          SA4    BA.BUF 
          SA1    MOD
          BX7    X4 
          IFBIT  X1,-PPRO,END45 
          SA1    T.FILE 
          SA2    NARGS
          SA3    TA.PRO 
          SA5    X1-2 
          SB4    X2          NUMBER OF FILES
          =B2    3
  
 END4     SA5    A5+B2
          ZR     B4,END45    IF NO MORE FILES 
          SB4    B4-B1
          MI     X5,END4     IF EQUIVALENCED FILE 
          SA1    =XOT.RM
          SX2    X5 
          BX6    0           PRESET NO CIO BUFFER (FWB=0) 
          ZR     X2,END41    IF BUFFER LENGTH (BFS) = 0 
          NZ     X1,END41    IF 7RM OBJECT MODE (NO CIO BUFFER) 
          BX6    X7          SET BUFFER ORIGIN
 END41    AX5    P.FBUF 
          SB7    X5-C.PRO 
          SA6    X3+B7       DEFINE BUFFER TAG
          IX7    X7+X2       ADVANCE ORIGIN 
          SA4    A5+B1
          MI     X4,END4     IF NO WSA
          SX2    X4          MRL
          AX4    18*2 
          SB7    X4-C.PRO 
  
          IFEQ   OT#RM,7,2
          SX0    4
          IX7    X7+X0
  
          SA7    X3+B7       DEFINE WSA TAG 
  
*         SIZE OF WORKING STORAGE AREA IS 4 + CEILING(MRL/10).
*         DIVISION BY 10 IS DONE BY SUBTRACTION LOOP. 
  
          =B3    0           INITIALIZE QUOTIENT
          SX4    10 
 END42    IX2    X2-X4
          =B3    B3+1        INCREMENT QUOTIENT 
          ZR     X2,END43    IF ZERO REMAINDER
          PL     X2,END42    IF DIVIDEND STILL POSITIVE 
 END43    SX0    B3 
          IX7    X7+X0       ADVANCE ORIGIN 
  
 #RM      IFEQ   OT#RM,7
  
          SA1    OT.RM
          ZR     X1,END4     IF 6RM OBJECT CODE 
          BX2    -X2         NO. OF UNUSED CHARS
          BX6    X2 
          LX2    2           *4 
          SA4    A4          WSA DESCRIPTOR 
          LX6    1           *2 
          IX2    X6+X2       *6, NO. OF UNUSED BITS 
          MX6    24 
          LX2    18 
          BX4    X6*X4       REMOVE MRL FIELD 
          IX0    X2+X0       36/0,6/UNUSED BITS,18/NO. WORDS
          BX6    X4+X0       REVISED WSA DESCRIPTOR 
          SA6    A4 
  
 #RM      ENDIF 
  
          EQ     END4        LOOP.. 
  
 END45    SA7    LOCAL       LOCAL LENGTH 
  
          RJ     GCL
          SA6    =XCOMSIZ 
  
**        FINISH LISTABLE OUTPUT. 
*         1.     DIAGNOSE PROGRAM TOO BIG, MISSING STATEMENT LABELS, AND
*                            UNTERMINATED DO-S. 
*         2.     *COMPASS*-STYLE LISTING OF MISCELLANEOUS BINARY. 
*         3.     *END* CARD.
  
          SA5    LOCAL
          IX5    X5+X6       ADD IN LOCAL COMMON LENGTHS
          AX5    17 
          NZ     X5,E.MO1    IF PROGRAM-UNIT TOO BIG
          EQ     CKS         CHECK MISSING STATEMENT NUMBERS
*         ... 
 CKSX     BSS    0           ** RETURN FROM CKS.
          SA1    LOCAL
          SA2    =XCOMSIZ 
          IX1    X1+X2
          BX7    X1 
          SA7    OTRSAV 
          SA3    =XCP.LSTF
          ZR     X3,END50    IF L=0 WAS USED
          SA3    =XLOP=M     IF R=0 WAS USED
          PL     X3,END50 
          PIA    ,=XLPS.PL
 END50    SA3    =XMOD
          SA2    ERRORS 
          SBIT   X3,PBLK
          NZ     X2,WCLX     IF ERRORS
          SA1    LOP=O
          MI     X3,WCLX     IF BLOCK DATA
          MI     X1,=XWCL    IF OBJECT LIST SELECTED
*         ... 
 WCLX     BSS    0           ** RETURN FROM *WCL*.
 SNAP=E   IFNE   TEST        DUMP ADDRESS TABLE 
          SA1    CO.SNAP
          LX1    1RE
          PL     X1,END50S   IF END SNAP NOT SELECTED 
          DUMPT  TA.NAM 
 END50S   BSS    0
 SNAP=E   ENDIF 
  
  
**        OUTPUT THE BINARY.
  
 END70    ALLOC  =XT.LGOB,=XLB.LGO  GET ROOM FOR LGO BUFFER 
          SA2    FV.LGO 
          ZR     X2,END80    IF BINARY COMPLETELY SUPPRESSED
  
          IFNE   CP#RM,7,1
          RECALL F.LGO
  
  
          EQ     DFT         DUMP FIRST TABLES
*         ... 
 DFTX     BSS    0           ** NORMAL RETURN FROM DFT
          BX6    0
          SHRINK TT=LINK,X6 
          SHRINK TT=FILL,X6 
          SHRINK =XTT=XFIL,X6 
  
          SA1    BA.CON 
          RJ     KCF         GET RID OF CONSTANTS AND FORMATS 
  
          RJ     DDS         DUMP *DATA* STATEMENTS 
  
          SA2    NREXT
          ALLOC  TT.LINK,X2  ALLOCATE BASIC LINK TABLE
          ALLOC  TT.FILL,1   ALLOCATE BASIC FILL TABLE
          ALLOC  =XTT.XFIL,1 ALLOCATE EXTENDED FILL TABLE 
  
          SA1    BA.PRO 
          RJ     RAD         RELOCATE AND OUTPUT THE LONG FILE. 
  
          SA1    BA.APL 
          RJ     KAP         COMPILE *AP-LIST* TEXT 
          SHRINK TP=APL,0    TRASH TABLE
  
          SA1    BA.NLST
          RJ     KNS         COMPILE *NAMELIST* SPACE 
  
          RJ     DTX
  
  
 #FID     IFNE   .FID,0 
          RJ     DFD         DUMP 5600/5700 TABLES
          SHRINK =XTP=CIDM,0 COLLASPE TP.CDIM 
 #FID     ENDIF 
          RJ     DLF         FLUSH LINK AND FILL TABLES 
          SA3    MOD
          IFBIT  X3,-PPRO,END80 
          WLGO   BT.XFER,2
  
*                            *DFT* RETURNS TO HERE IF ERRORS. 
  
 END80    SA1    LGOIO
          PL     X1,END82    IF LGO NOT ON DISK 
          WRITER F.LGO
 END82    SHRINK TT=LF       TRASH ALL TABLES NO LONGER NEEDED
          SHRINK TS=CON,X6
          SHRINK TP=FMT,X6
          SHRINK TP=APL,X6
          SHRINK TP=NLST,X6 
          SHRINK TS=DAT,X6
  
          SA1    LOP=M
          MI     X1,=XWVM    IF VAR MAP ON
*         ... 
 WVMX     BSS    0           ** RETURN FROM *WVM*.
          SA1    =XCP.NFLS
          SA3    CP.MXFL
          SX1    X1+1S6-1 
          AX1    6
          LX1    6           ROUND UP TO NEAREST 100B 
          BX2    X1 
          MX6    X2+X3       MAX CORE USED BY ANY SUBPROGRAM
          SA6    A3 
          SA2    =XCP.LSTF
          SA3    =XNOLIST 
          ZR     X2,LFSX     IF SHORT LIST (L=0)
          MI     X3,LFS      IF *C/-LIST,ALL* ACTIVE LIST FINAL STATS 
*         ... 
 LFSX     BSS    0           ** RETURN FROM LFS 
  
**        RETURN TO INITIAL FIELD LENGTH
  
          SA1    =XINT.FL 
          SA2    =XCP.AFLS
          LX2    30 
          IX3    X1-X2
          ZR     X3,END86    IF FL SAME AS AT START 
          MEMORY SCM,=XINT.FL,RCL 
          SA1    =XINT.FL 
 END86    AX1    30 
          BX6    X1 
          SA6    =XCP.AFLS
          SX7    X6-10       ALLOW FOR SLOP 
          LX6    30 
          SA6    A1          CLEAR COMPLETE BIT 
          SA7    =XCP.NFLS
          SA7    =XT.END
          SA1    =XF.TABS    FWA TABLES 
          IX7    X7-X1
          SA7    =XW.TABS    WIDTH OF TABLE SPACE 
          AX7    FLSLOP 
          SA7    =XTHRESH    GIVE ALLOC SOME ELBOW ROOM 
  
**        SEND ERROR MESSAGE TO DAYFILE + CONSOLE.
  
  
 END93    SA3    ERRORS      TOTAL NUMBER OF FATAL ERRORS 
          SA2    ERR=F       ERRORS IN CURRENT STATEMENT
          IX1    X2+X3
          SA2    CP.ERCT
          ZR     X1,=XRUN.X  IF NO ERRORS IN THIS ROUTINE, EXIT.. 
          IX6    X1+X2       UPDATE JOB ERROR COUNT 
          SA6    A2 
          SB6    X1          SAVE NUMBER OF ERRORS
          RJ     CDD
          SA1    =10H  FORTRAN
          SA6    LINEBUF
          SA3    =38LERROR IN  ERRORS IN COMPILATION. 
          SA2    IDENT
          BX7    X1 
          LE1    B6,END95    IF ONLY ONE ERROR
          =A3    A3+1 
 END95    =A7    A6+1        +1 =  FORTRAN
          BX6    X3 
          LX7    X2 
          =A6    A7+1        +2 = ERROR(S) IN 
          =A7    A6+1        +3 = (IDENT) 
          MESAGE LINEBUF,,RCL 
          PLINE  LINEBUF,4,1
  
          EQ     RUN.X       EXIT.. 
  
**        THIS IS ENTERED WHEN TABLE OVERFLOW WAS ENCOUNTERED DURING
*         MAP OR END PROCESSING.
  
 END96    WLGO   BT.ERR,3 
          EQ     END93
 BT.---   EJECT 
**        BT.--- BINARY OUTPUT TABLE DEFINITIONS. 
  
  
 BT=PIDL  EQU    3400B       PROGRAM/BLOCK TABLE
 BT=ENTR  EQU    3600B       ENTRY POINT TABLE
 BT=TEXT  EQU    4000B       RELOCATABLE TEXT TABLE 
 BT=XFILL EQU    4100B       EXTENDED FILL OR *XFILL* TABLE 
 BT=FILL  EQU    4200B       COMMON *FILL* TABLE
 BT=REPL  EQU    4300B       DATA REPLICATION TABLE 
 BT=LINK  EQU    4400B       EXTERNAL *LINK* TABLE
 BT=XFER  EQU    4600B       TRANSFER ADDRESS TABLE 
 BT=XLINK EQU    4500B       XLINK TABLE
 #FID     IFNE   .FID,0 
 BT=LSTN  EQU    5700B       LOADER STMT AND LINE NUMBER TABLE
 BT=LSYM  EQU    5600B       LOADER SYMBOL TABLE
 #FID     ENDIF 
 BT=LDSET EQU    7000B       *LDSET* OBJECT DIRECTIVE 
 BT=LIB   EQU      10B             *LIB* SUB-DIRECTIVE
 BT=USE   EQU      16B             *USE* SUB-DIRECTIVE
 BT=IDNT  EQU    7700B       IDENT (PRFX) TABLE 
  
 #FID     IFNE   .FID,0 
 BT=MXWC  EQU    7777B       MAXIMUM WORD COUNT PER TABLE OUTPUT TO LGO 
 #FID     ENDIF 
  
*         THE FOLLOWING DEFINITIONS ARE FOR LOADER SYMBOL TABLES. 
* 
*         HEADER WORD 
  
 BTFT     DEFINE 24,12       FORTRAN INDICATOR FIELD
 BTFI     DEFINE 23,1        FINAL TABLE FIELD
  
*         WORD ONE
  
 BTNM     DEFINE 18,42       NAME FIELD 
 BTBI     DEFINE 9,9         RELOCATION BASE INDICATOR
  
*         WORD TWO
  
 BTLM     DEFINE 59,1        LCM BIT
 BTFP     DEFINE 58,1        FP BIT 
 BTDC     DEFINE 57,1        CONSTANT UPPER BOUND BIT 
 BTTP     DEFINE 51,5        TYPE FIELD 
 BTDM     DEFINE 46,5        NUMBER OF DIMENSIONS FIELD 
 BTLC     DEFINE 30,25       LENGTH OF CHARACTERS 
 BTCP     DEFINE 24,3        BCP = BEGIN CHAR POSITION
 BTAD     DEFINE 0,24        RELATIVE ADDRESS FIELD 
 #FID     ENDIF 
  
 L.77     EQU    16B
  
 MODLVL   MICRO  1,5,/"MODLVL"     /
  
**        TARGET - TWO CHARACTERS INDICATING THE TYPE OF PROCESSOR FOR
*                  WHICH THE PROGRAM IS OPTIMIZED.
* 
*         VALID - TWO CHARACTERS INDICATING THE TYPE OF PROCESSOR ON
*                 WHICH THE PROGRAM CAN BE EXECUTED.
* 
*         TARGET  AND  VALID  ARE CALCULATED FROM  MODEL
* 
*         MODEL      -->      TARGET     -->      VALID 
*         71                  64                  64
*         72                  64                  64
*         73                  64                  64
*         74                  66                  6X
*         76                  76                  7X
*         171                 64                  64
*         172                 64                  64
*         173                 64                  64
*         174                 64                  64
*         175                 C5                  CX
*         176                 76                  7X
* 
  
 .TMP     MICRO  2,1,/"MDL"/
 TARGET   MICRO  2*".TMP"-5,2,/6466C576/
 VALID    MICRO  2*".TMP"-5,2,/646XCX7X/
  
 BT.IDNT  BSS    0           PREFIX TABLE LAYOUT
  
          LOC    0
  
          VFD    L.BTCN/BT=IDNT,L.BTWC/L.77,*P/0
          DIS    1,*******         DECK NAME
          DIS    2, MM/DD/YY  HH.MM.SS. 
          DATA   10H"OS.ID" 
          DATA   10H"LPNAME""VER" 
          VFD    30/5H"MODLVL",12/2H"TARGET",12/2H"VALID",6/1H
          DATA   2H I        HARDWARE DEPENDENCIES
 BT.IDN8  DIS    1,          PROG-UNIT TYPE 
*                                           ---  OPTIONS  --- 
 BT.IDN9  DIS    1,          DBUG TRACE 
 BT.IDNTA DIS    1,                               ROUND SYS 
 BT.IDNTU BSSZ   L.77-*+1                        USER COMMENT 
  
          LOC    *O 
  
  
**        BT.LIB - *LDSET(LIB=FORTRAN)* LOADER OBJECT DIRECTIVE.
  
 BT.LIB   VFD    L.BTCN/BT=LDSET,L.BTWC/BT.LIBL-1,*P/0
          VFD    L.BTCN/BT=LIB,L.BTWC/BT.LIBL-2,*P/0
          DATA   L FORTRAN   NORMAL FTN COMMON LIBRARY
 BT.LIBL  EQU    *-BT.LIB 
  
  
**        BT.ERR - THIS LINE IS ALL THE BINARY OUTPUT IF THERE WERE 
*                FATAL ERRORS.
  
 BT.ERR   LIT    28LERRORS IN COMPILATION.
  
  
**        BT.1ST - FIRST *TEXT* OUTPUT FOR EVERY EXECUTABLE PROGRAM-UNIT
*         CONSISTS OF --
*                  ORG    0 
*         TRACE.   VFD    42/0LNAME,18/NAME        L +
*         TEMPA0.  DATA   1777BS48
*         SAVEA0.  DATA   1777BS48
  
 A        SET    P.BTWC-P.BTRL
 BT.CONS  VFD    L.BTCN/BT=TEXT,L.BTWC/1,A/1,*P/0 
 BT.1ST   VFD    L.BTCN/BT=TEXT,L.BTWC/BT.1STL,A/1,*P/0 
          VFD    L.BTRB/2,*P/0
          VFD    42/7L*******,18/1S17 
          DATA   1777BS48 
          DATA   1777BS48 
 BT.1STL  EQU    *-BT.1ST-1 
 BT.---   SPACE  4,8
**        BT.FIT - FILE INFORMATION TABLE TEMPLATE. 
  
*         CRM FIT TEMPLATES.
  
 .RM      IFEQ   OT#RM,6
  
*         CRM FIT LOADER TEXT TABLES. 
  
 BT.FITC  BSS    0           BEGIN CRM FIT TEXT TABLES
  
*         CRM FIT SECTION (A).
  
 A        SET    P.BTWC-P.BTRL-L.BTRL 
 BT.FCAH  VFD    L.BTCN/BT=TEXT,L.BTWC/BT.FCAL+1,A/0,L.BTRL/1,*P/** 
          VFD    *P/**       FILLED BY RELOCATION BYTES 
  
 BT.FCA   VFD    42/**,17/0,1/1    FILE NAME, CIO COMPLETE BIT
          VFD    36/0,6/L.FIT6-L.FCLX-5,18/** 
                             (FIT LENGTH - 5) + FWA CIRCULAR BUFFER 
          VFD    60/0        ZERO WORD FOR REPL (MUST IMM PRECEDE REPL) 
  
 BT.FCAL  =      *-BT.FCA    LENGTH OF FIT SECTION (A)
  
*         BT.REPC - CRM FIT REPLICATION TABLE.
*         NOTE - REPL TABLE MUST IMMEDIATELY FOLLOW FIT (A) TEXT TABLE. 
  
 BT.REPC  VFD    L.BTCN/BT=REPL,L.BTWC/2,*P/1 
          VFD    33/0,9/1,18/**          REPL SOURCE
          VFD    18/L.FIT6-BT.FCAL,*P/0  REPL COUNT (DEST ADDR=SOURCE+1)
  
*         CRM FIT SECTION (B).
  
 BT.FCBH  VFD    L.BTCN/BT=TEXT,L.BTWC/BT.FCBL+1,A/0,L.BTRL/1,*P/** 
          VFD    *P/**       FILLED BY RELOC BYTES
  
 BT.FCB   VFD    36/0,2/3,22/0     LT=ANY 
          VFD    25/0,2/2,3/2,30/0 OF=N,LF=N
          VFD    24/**,36/0        *MRL* (MAX REC LEN)
          VFD    2/0,2/3,56/0      DFC=3
          VFD    60/0 
          VFD    27/0,3/6,8/0,22/** EO=AD, FWA WSA
          VFD    60/0 
          VFD    42/0,18/**        *BFS* (CIO CIRC BUFF SIZE) 
          DATA   0,0,0,0
          VFD    20/0,4/1,36/0       FORTRAN GENERATED FIT FLAG 
  
 BT.FCBL  =      *-BT.FCB    LENGTH FIT (B) 
  
*         CRM FIT SECTION (C) -- *FCL* FIT EXTENSION. 
  
 BT.FCCH  VFD    L.BTCN/BT=TEXT,L.BTWC/BT.FCCL+1,A/0,L.BTRL/1,*P/** 
          VFD    4/2,*P/0    POSITIVE RELOC OF LOWER ADDR 
  
 BT.FCC   VFD    *P/**       MRL, WSA 
  
 BT.FCCL  =      *-BT.FCC    LENGTH FIT (C) 
 BT.FCCTL =      *-BT.FCCH   LENGTH FIT (C) TEXT TABLE
  
 BT.FITCL =      *-BT.FITC   LENGTH CRM FIT TEXT TABLES 
  
 .RM      ENDIF 
  
  
*         7RM FIT TEMPLATES.
  
 .RM      IFEQ   OT#RM,7
  
*         7RM FIT LOADER TEXT TABLES. 
  
 BT.FIT7  BSS    0           BEGIN 7RM FIT TEXT TABLES. 
  
*         7RM FIT SECTION (A).
  
 A        SET    P.BTWC-P.BTRL-L.BTRL 
 BT.F7AH  VFD    L.BTCN/BT=TEXT,L.BTWC/BT.F7AL+1,A/0,L.BTRL/1,*P/** 
          VFD    *P/**       FILLED BY RELOCATION BYTES 
  
 BT.F7A   BSSZ   2
          VFD    24/0,2/2,4/1,2/0,28/0   (OF)=N,(LT)=UNLABELED
          BSSZ   3
          VFD    6/**,18/**,15/0,21/**   (MRL - UBC,WORDS), (WSA) 
          DATA   0
          VFD    14/0,4/1,42/0       FORTRAN GENERATED FIT FLAG 
          VFD    60/0        ZERO WORD FOR REPL (MUST IMM PRECEDE REPL) 
  
 BT.F7AL  =      *-BT.F7A    LENGTH OF 7RM PARTIAL FIT
  
*         BT.REP7 - 7RM REPLICATION TABLE.
*         NOTE - REPL TABLE MUST IMMEDIATELY FOLLOW FIT (A) TEXT TABLE. 
  
 BT.REP7  VFD    L.BTCN/BT=REPL,L.BTWC/2,*P/1 
          VFD    33/0,9/1,18/**          REPL SOURCE
          VFD    18/L.FIT7-BT.F7AL,*P/0  REPL COUNT (DEST ADDR=SOURCE+1)
  
 BT.FIT7L =      *-BT.FIT7   LENGTH 7RM FIT TEXT TABLES 
  
 .RM      ENDIF 
 BT.---   SPACE  4,5
**        BT.REP - REPLICATION TABLES BUILT HERE. 
  
 BT.REP   VFD    L.BTCN/BT=REPL,L.BTWC/2,*P/1 
          VFD    33/0,9/1,18/**         SOURCE OF REPL
          VFD    18/**,15/0,9/1,18/**   REPL COUNT,DESTINATION OF REPL
  
  
**        BT.TEXT - PARTIAL *TEXT* TABLE BUILT HERE.
  
 BT.TXWC  DATA   0           WORD COUNT 
 BT.TEXT  DATA   0           PARTIAL TABLE PROPER 
 BT.TXRB  DATA   0           RELOCATION BYTES 
          BSSZ   15 
  
 #FID     IFNE   .FID,0 
 BT.TXTL  EQU    *-BT.TXRB   LENGTH OF WORKING BUFFER 
 #FID     ENDIF 
  
 BINWORD  DATA   0           PARTIAL BINARY OUTPUT WORD 
 BINREL   DATA   0           PARTIAL RELOCATION 
  
 BT.ENTR  VFD    L.BTCN/BT=ENTR,*P/0
 BT.XFER  VFD    L.BTCN/BT=XFER,L.BTWC/1,*P/0 
 BT.XFR1  BSS    1           ROUTINE NAME GOES HERE 
  
*         EQUATES FOR SYMBOL AND LINE NUMBER TABLE (5600,5700)
*         GENERATION. 
  
  
*         LOADER STATEMENT AND LINE NUMBER TABLES 
  
 #FID     IFNE   .FID,0 
 BT.STTX  EQU    BT.TXRB     FWA OF BUFFER
 BT.STWC  EQU    BT.TXWC     WORD COUNT 
 BT.ST77  EQU    BT.TEXT     WORD COUNT IF T=LNT .GT. 7777B 
  
*         LOADER SYMBOL TABLE GENERATION
  
 BT.SYWC  EQU    BT.TXWC     WORD COUNT 
 BT.SYMB  EQU    BT.TEXT     LENGTH OF SYMBOL TABLE (TS=SYM)
 BT.SYTX  EQU    BT.TXRB     FWA OF BUFFER
 BT=MXDM  EQU    3           MAX NUMBER OF DIMENSIONS IN ONE VARIABLE 
 #FID     ENDIF 
 CKS      EJECT 
**        CKS -  CHECK UNDEFINED STATEMENT NUMBERS. 
*         ENTRY  (MSN) = LOGICAL SUM OF THE COMPLEMENT OF ALL TS.STAT 
*                ENTRIES. 
  
  
 CKS      BSS    0           ENTRY... 
          SA1    MSN
          IFBIT  X1,-SNDEF,CKS6 
          SA3    TS.STN 
          SA2    TS=STN 
          SB6    P.SYM
          =B3    2
          SA5    X3-1        INITIALIZE FETCH REGISTER
          SB4    X2 
  
 CKS2     SA5    A5+B3
          ZR     B4,CKS6     IF TABLE EXHAUSTED 
          SBIT   X5,SNDEF 
          SB4    B4-B3       DECREMENT TABLE LENGTH 
          MI     X5,CKS2     IF ENTRY DEFINED 
          ZR     X5,CKS2     IF EMPTY ENTRY 
          =A4    A5-1 
          AX5    X4,B6
          RJ     =XLJS       LEFT JUSTIFY STATEMENT LABEL 
          SA6    FILL.
          FATAL  E.MS        ** MISSING STATEMENT NUMBER ** 
          EQ     CKS2 
  
**        CHECK FOR UNTERMINATED *DO*-S 
  
 CKS6     SA1    NSK
          ZR     X1,CKS65    IF NO NULL STATEMENTS
          RJ     CDD
          SA6    FILL.
          EQ     E.MN        FLAG NON-ANSI NULL STATEMENTS
*         ... 
 CKS65    BSS    0           RETURN FROM E.MN 
          SA1    MSF
          NZ     X1,E.M$     IF NO MULTIPLE STATEMENTS OCCURRED 
*         ... 
 CKS67    BSS    0           RETURN FROM E.M$ 
          SA2    TP=DO
          ZR     X2,CKSX     IF NO HANGING DO-S 
          SA3    TS.STN 
          SB4    X2 
          SB3    L.DOE
          SHRINK A2,0 
          SA1    TP.DO
          SB5    X3-C.STAT-1
          SA5    X1-L.DOE+OR.DOSN 
  
          SB6    P.SYM
 CKS8     SA5    A5+B3
          ZR     B4,CKSX     IF TABLE EXHAUSTED 
          SB4    B4-B3       DECREMENT TABLE LENGTH 
          AX5    P.DOTAG
          SX4    X5+B5
          MI     X4,CKS8     IF NOT STATEMENT LABEL 
          SA4    X4          FETCH DPC OF STATEMENT NUMBER
          AX5    X4,B6
          RJ     =XLJS       LEFT JUSTIFY STATEMENT LABEL 
          SA6    FILL.
          FATAL  E.DO9       ** UNTERMINATED DO LOOP ** 
          EQ     CKS8 
 DDS      SPACE  4,8
**        DDS -  DUMP *DATA* STATEMENTS.
  
  
 DDS9     SHRINK TS=DAT,0 
  
 DDS      SUBR               ENTRY/EXIT...
  
 SNAP=D   IFNE   TEST        DUMP DATA TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,DAT.ZS   IF NO *DATA* SNAP SELECTED 
          DUMPT  (TS.DAT) 
 DAT.ZS   BSS    0
 SNAP=D   ENDIF 
  
          SA1    TS=DAT 
          SA2    TS.DAT 
          BX6    0
          SB4    X1          LENGTH OF DATA TABLE 
          SA5    X2-1        FETCH FIRST ENTRY
          SA6    PARCEL 
  
 DDS.     SA5    A5+B1
          LE     B4,DDS9     IF TABLE EXHAUSTED 
          UX1,B7 X5 
          SB4    B4-B1
          JP     B7+DDS=     JUMP TO OPERATOR 
 DDS=     BSS    0
  
 DDS.S    EQU    *-DDS=      OUTPUT SHORT DATUM 
          BX2    0           INDICATE NO RELOCATION 
          RJ     STX
          EQ     DDS. 
  
          BSS    0
 DDS.O    EQU    *-DDS=      SET ORG COUNTER
          MX4    -L.PWF+1 
          SA2    TA.NAM 
          SX6    X1          ISOLATE BIAS 
          AX1    P.DTAG+1 
          BX4    -X4*X1 
          IX3    X2+X4
          SA2    X3          FETCH ADDRESS WORD 
          MX5    -L.BLOCK+1 
          SX1    X2          ISOLATE ADDRESS
          AX2    P.BLOCK+1
          IX6    X1+X6       (ORIGIN) = ADDRESS + BIAS
          BX5    -X5*X2      ISOLATE BLOCK ORDINAL
          ZR     X5,DDS.O4   IF PROGRAM RELOCATABLE 
          =X5    X5+1 
 DDS.O4   LX5    P.BTRL 
          BX7    X5+X6
          SA7    ORG
          SA7    BT.REP+1    SAVE ORIGIN
          RJ     DTX         INITIALIZE TEXT TABLE
          EQ     DDS. 
  
          BSS    0
 DDS.R    EQU    *-DDS=      OUTPUT REPI TABLE
          SB4    B4-B1
          =X2    1
          AX5    P.DTAG 
          SX1    X1-1        C
          LX2    P.BTRL 
          SX6    X5          B
          LX1    P.BTRC 
          SA5    A5+B1
          SA4    BT.REP+1    S
          LX6    P.BTRI 
          SX3    X5          D-S
          IX4    X4+X2       ADJUST INTERNAL BLOCK NUMBER TO LOADER 
                                   BLOCK ORDINAL
          AX5    P.DTAG 
          SX0    X5          I
          IX3    X3+X4       = DESTINATION
          LX0    P.BTRI 
          BX7    X0+X4
          IX1    X3+X1
          SA7    A4 
          BX6    X1+X6
          SA6    A4+B1
          RJ     DTX         FLUSH ANY PARTIAL TEXT TABLE 
          WLGO   BT.REP,3 
          EQ     DDS. 
  
          BSS    0
 DDS.W    EQU    *-DDS=      OUTPUT DATA WORD(S)
          SB7    X1+B1       (B7) = WORD COUNT
          SB4    B4-B7       DECREMENT TABLE LENGTH 
          BX0    X1 
  
 DDS.W1   SA5    A5+B1
          BX2    0
          =X0    X0-1 
          LX1    X5 
          RJ     STX         OUTPUT A WORD
          PL     X0,DDS.W1   IF MORE WORDS TO DO
          EQ     DDS. 
 GCL      SPACE  4,8
**        GCL -  GET COMMON LENGTHS 
* 
*         THIS ROUTINE DETERMINES SIZE(S) OF SCM RESIDENT COMMON BLOCKS 
* 
*         EXIT   (X6) = TOTAL SIZE OF LOCAL COMMON
* 
  
 GCL      SUBR
          SA2    TS=BLK 
          =X6    0
          SX2    X2-2 
          SA1    TS.BLK 
          ZR     X2,EXIT.    IF NO COMMON BLOCKS
          =B3    2
          SB7    X2 
          SA4    X1+B3       INITIALIZE 
          MX0    -L.BLEN
          MX7    -L.BLVL
 GCL1     =A5    A4+1        BLOCK LENGTH - LEVEL WORD
          SB3    B3+2 
          BX3    -X0*X5      ISOLATE BLOCK LENGTH 
          AX5    P.BLVL 
          =A4    A5+1 
          BX5    -X7*X5      ISOLATE BLOCK LEVEL
          SB5    X5-3 
          ZR     B5,GCL3     IF LEVEL 3 
  
 .76      IFEQ   .CPU,76
          SB5    X5-2 
          ZR     B5,GCL3     IF LEVEL 2 
 .76      ENDIF 
  
          IX6    X6+X3
 GCL3     LE     B3,B7,GCL1  IF MORE BLOCKS 
          EQ     EXIT.
 DFD      SPACE  4,10 
**        DFD -  DUMP 5700/5600 TABLES
*         DUMPS STATEMENT/LINE NUMBER (5700) AND LOADER SYMBOL (5600) 
*         TABLES TO BINARY. 
* 
*         5700 TABLES 
* 
*         THE INFORMATION FOR 5700 TABLES EXISTS IN T.LNT IN CORRECT
*         FORMAT.  IT ONLY REMAINS TO OUTPUT THE INFORMATION TO LGO.
*         5700 TABLES ARE GENERATED BY DETERMINING FIRST IF ALL THE 
*         INFORMATION IN T.LNT WILL FIT INTO ONE TABLE (LE 7777B WORDS).
*         IF SO, ONE 5700 TABLE CONTAINING ALL THE INFORMATION WILL 
*         BE BUILT.  IF NOT, AS MANY 5700 TABLES OF MAXIMUM SIZE (7777B)
*         WILL BE BUILT AS NECESSARY, UNTIL ALL INFORMATION IS
*         PROCESSED.
*         FORMATS OF 5700 TABLE ENTRIES ARE...
* 
*         HEADER WORD 
*                12/5700,12/WORD COUNT,12/2,24/0
*         EACH ENTRY
*                17/STATEMENT LABEL,7/0,18/LINE NO,18/FWA OBJECT CODE 
* 
*         5700 TABLES ARE GENERATED USING...
*                1. BT.STTX - AN OUTPUT BUFFER
*                2. T.LNT - AN INPUT BUFFER 
*                3. T=LNT - LENGTH OF INPUT 
*         THE FOLLOWING COUNTERS ARE UTILIZED IN CONTROLLING THE LOOP 
*         WHICH GENERATES 5700 TABLES...
*                1. BT.ST77 - THE SIZE OF THE CURRENT 5700 TABLE BEING
*                   GENERATED (MAX IS 7777B PER TABLE). 
*                2. B4 - WORD COUNT (WC) FOR OUTPUT BUFFER CURRENTLY
*                        BEING BUILT (MAX IS BT.TXTL).
*                3. T=LNT - THE AMOUNT OF INPUT LEFT TO PROCESS.  T=LNT 
*                   MAY INITIALLY BE .GT. 7777B, WHICH WOULD REQUIRE
*                   GENERATION OF MORE THAN ONE 5700 TABLE. 
* 
*         5600 TABLES 
* 
*         5600 TABLES WILL BE NO LARGER THAN THE USER OUTPUT BUFFER IN
*         SIZE SINCE THE NUMBER OF PROGRAMMER VARIABLES TO BE PROCESSED 
*         AND THE NUMBER OF TABLE ENTRIES PER VARIABLE ARE NOT KNOWN
*         SOON ENOUGH FOR EFFICIENT PREDICTION. 
*         THERE WILL BE AT LEAST TWO WORDS PER ENTRY AND POSSIBLY 3.
*         THE FORMATS FOR WORDS 1,2,3 ARE...
* 
*         HEADER WORD 
*                12/5600,12/WORD COUNT,12/2,1/F,23/SAVEA1 
* 
*                F      = 0, NOT FINAL SYMBOL TABLE 
*                       = 1, IF FINAL SYMBOL TABLE
*                SAVEA1 = SUBPROGRAM REL. ADDR. OF WORD IN WHICH
*                         SUBPROGRAM INITIALIZATION WILL SAVE REG A1. 
* 
*         WORD 1
*                42/0LNAME,9/RB,9/L 
* 
*                RB = RELOCATION BASE DESIGNATOR.  SEE SECTION 8 OF 
*                     LOADER REFERENCE MANUAL.
*                L = NUMBER OF ITEMS IN THIS ENTRY (L .GE. 2).
* 
*         WORD 2
*                1/LCM,1/FP,2/0,5/TYPE,5/D,16,LEN,2/0,4/BCP,24/RA 
* 
*                LCM = 1 IF ECS/LCM RESIDENT
*                FP  = 1 IF FORMAL PARAMETER AND
*                      RA = FPNO, THE FORMAL PARAMETER NUMBER.
*                TYPE= 1 IF LOGICAL 
*                      2 IF INTEGER 
*                      3 IF REAL
*                      4 IF DOUBLE
*                      5 IF COMPLEX 
*                      6 IF BOOLEAN 
*                      7 IF CHARACTER 
*                D   = NO OF DIMENSIONS 
*                LFN = LENGTH OF CHARACTERS OF A CHARACTER ITEM,
*                      0 FOR OTHER ITEMS
*                BCP = BEGIN CHAR POSITION FOR CHARACTER ITEM 
*                RA  = RELATIVE ADDRESS - SEE ALSO FP.
* 
*         WORD 3 (IF D .NE. 0).  DIMENSION DESCRIPTORS
*                1/LCM,1/FP,1/C,1/LB,23/0,9/RB,24/RA
* 
*                LCM AND FP ARE AS ABOVE BUT APPLY TO THE SUBSCRIPT IF
*                IT IS A VARIABLE.
* 
*                C   = 1 IF BOUND (OF DIMENSION) IS CONSTANT
*                      0 IF VARIABLE DIMENSION
*                RB  = 0 IF C = 1 
*                    = RELOCATION BASE DESIGNATOR IF C = 0. 
*                RA  = UPPER BOUND IF C = 1 
*                    = FORMAL PARAMETER NO IF C = 0.
* 
*         IF NON-UNITY LOWER BOUNDS EXISTED, AND THEY DONT HERE YET,
*         THERE WOULD BE A FOURTH WORD THAT LOOKS LIKE THE THIRD WORD 
*         WHICH DESCRIBES THE NON-UNITY LOWER BOUND IN A LIKE MANNER. 
* 
*         USES   ALL
  
  
 #FID     IFNE   .FID,0 
  
 DFDSV    BSS    3           DIM DESCRIPTORS SAVED HERE TEMPORARILY 
  
 DFDX     BX6    0
          SA6    BT.TXWC     (=BT.SYWC) CLEAR FOR NEXT USE OF DTX 
  
 DFD      SUBR   -
          SA1    =XCO.ID     DEBUG ON FLAG
          ZR     X1,EXIT.    IF DEBUG NOT ON
  
**        PROCESS LINE NUMBER TABLE.
*         FIRST SEE HOW MUCH THERE IS TO PROCESS AND DETERMINE THE
*         SIZE OF THE FIRST 5700 TABLE TO MAKE. 
  
 DFD21    SA2    =XT=LNT
          ZR     X2,DFD40    IF NOTHING IN T.LNT, CHECK 5600 TABLE
          SX6    BT.TXTL     LENGTH OF WORKING BUFFER 
          SB2    X2-BT=MXWC 
          SX4    BT=MXWC
          GE     B2,DFD23    IF T=LNT .GE. BT=MXWC (7777B)
          LX4    X2 
  
*         CONSTRUCT A HEADER WORD FOR THE 5700 TABLE. 
  
 DFD23    BX7    X4 
          SA6    BT.STWC     MAX WORKING BUFFER SIZE
          LX4    P.BTWC 
          SX3    BT=LSTN
          =X5    2
          LX3    P.BTCN 
          BX6    X3+X4       5700 .AND. WORD COUNT
          SA7    BT.ST77     SIZE OF NEXT 5700 TABLE
          LX5    P.BTWC-L.BTWC
          BX6    X6+X5
          SA6    BT.STTX     HEADER = 12/5700,12/WRD CNT,12/2,24/0
          =B4    1           WC = 1 
  
*         NOW PACK UP AN OUTPUT BUFFER. 
  
 DFD25    SB2    X2-BT.TXTL 
          GT     B2,DFD27    IF T=LNT .GT. SIZE OF WORKING BUFFER 
          =X7    X2+B1
          SA7    BT.STWC     WORKING BUFFER SIZE IF T=LNT .LT. BT.TXTL
 DFD27    SA1    BT.STWC
          =B7    X1 
          SA1    =XT.LNT
          SA2    =XT=LNT
          SA3    BT.STTX     FWA OUTPUT BUFFER
          SA4    BT.ST77     SIZE OF THIS 5700 TABLE
          SA5    X1-1        INITIALIZE FETCH 
 DFD29    SA5    A5+B1       FETCH ELEMENT
          BX6    X5 
          SA6    A3+B4       ELEMENT TO OUTPUT BUFFER 
          =B4    B4+1        WC = WC + 1
          =X2    X2-1        T=LNT = T=LNT - 1
          =X4    X4-1        LEFT TO GO FOR THIS 5700 TABLE 
          ZR     X4,DFD31    IF THIS 5700 TABLE IS FULL 
          =B2    B4-B7
          LT     B2,DFD29    IF WORKING BUFFER NOT FULL 
  
*         UPDATE TABLES AND COUNTERS (T.LNT,T=LNT,BT.ST77). 
  
 DFD31    SX7    A5+B1
          LX6    X2 
          SA7    A1          UPDATE T.LNT 
          SA6    A2          UPDATE T=LNT 
          BX7    X4 
          SA7    A4          LEFT TO GO FOR THIS 5700 TABLE 
          WLGO   BT.STTX,B4  OUTPUT TO LGO
  
          =B4    0           WC = 0 
          SA1    BT.ST77
          ZR     X1,DFD21    IF COMPLETED ONE TABLE 
          SA2    =XT=LNT
          EQ     DFD25
  
**        PROCESS LOADER SYMBOL TABLE.
  
 DFD40    BSS    0
          SA1    TS=SYM 
          BX6    X1 
          SA6    BT.SYMB     SAVE TS=SYM.  CANNOT ALTER TS=SYM. 
          SA3    TS.SYM 
          =X7    1
          SA5    X3-1        INITIALIZE FOR TABLE FETCH 
          SA7    BT.SYWC     INITIALIZE WORD COUNT
  
*         FIND A PROGRAMMER DEFINED VARIABLE TO PROCESS.
  
 DFD42    SA3    BT.SYMB     BT.SYMB # TS=SYM 
          ZR     X3,DFD88    SYMBOL TABLE PROCESSING COMPLETE 
          SA5    A5+2        (X5) = 2ND ELEMENT OF TS.SYM ENTRY 
          =X7    X3-2 
          SA7    BT.SYMB     DECREMENT NO OF WORDS IN TS.SYM
          ZR     X5,DFD42    IF A ZERO ENTRY
          LX5    -P.EST      SHIFT TYP BIT TO SIGN BIT
          MI     X5,DFD43    IF TYPE VARIABLE 
          LX5    P.EST-P.NVAR SHIFT VAR BIT TO SIGN BIT 
          PL     X5,DFD42    NOT A PROGRAMMER VARIABLE
          LX5    P.NVAR      RESTORE X5 
          EQ     DFD43A 
 DFD43    LX5    P.EST       RESTORE X5 
 DFD43A   =X2    0           INITIALIZE WORD 2
  
*         BUILD 1ST AND 2ND WORDS OF 5600 TABLE.  THEY WILL BE
*         ACCUMULATED IN REGS X1 AND X2, RESPECTIVELY.
  
          =B4    2           (B4) = WORD COUNT (WC) 
          SA4    A5-B1       GET 1ST ELEMENT OF ENTRY IN TS.SYM 
          LX6    X5          SAVE X5
          MX0    L.SYM
          BX1    X0*X4       WORD 1 = 42/0LNAME,18/0
  
*         SEE IF THIS VARIABLE IS A FORMAL PARAMETER. 
  
          LX5    -P.ENT      FORMAL PARAMETER BIT TO SIGN BIT 
          PL     X5,DFD44    IF NO FORMAL PARAMETER (FP)
          LX5    P.ENT-P.FPNO 
          MX0    -L.FPNO
          =X2    1
          BX3    -X0*X5      EXTRACT FORMAL PARAMETER NO (FPNO) 
          LX2    P.BTFP 
          =X3    X3-1 
          IX2    X2+X3       WORD 2 = 1/0,1/FP,34/0,24/FPNO 
  
*         CHECK FOR LCM/ECS, THIS VARIABLE. 
  
 DFD44    BX5    X6 
          LX5    -P.ARY      LEVEL BIT TO SIGN BIT
          PL     X5,DFD46    IF NO LEVEL
          LX5    P.ARY-P.LEVN 
          MX0    -L.LEVN
          BX3    -X0*X5      EXTRACT LEVEL NO 
          =B3    X3-3 
 .76      IFEQ   .CPU,76
          =B3    B3+B1
 .76      ENDIF 
          LT     B3,DFD46    IF NOT LEVEL 2 OR 3 (LCM)
          =X0    B1 
          LX0    P.BTLM 
          BX2    X2+X0       WORD 2 = 1/LCM,1/..,34/0,24/.... 
  
*         EXTRACT THE MODE, OR TYPE FOR THIS VARIABLE.
  
 DFD46    LX5    X6 
          MX0    -L.MODE
          BX3    -X0*X5      EXTRACT MODE 
          LX3    P.BTTP 
          BX2    X2+X3       WORD 2 = 1/...,1/..,2/0,5/TYPE,27/0,24/..
  
*         IF THIS VARIABLE ISNT A FORMAL PARAMETER, GET THE RELATIVE
*         ADDRESS OF IT.  ALSO CALCULATE *RB*, THE VALUE OF WHICH 
*         DEPENDS WHETHER THE VARIABLE IS IN COMMON.
  
          LX5    -P.ENT      FP BIT TO SIGN BIT 
          SX3    B0          RELOCATION BASE DESIGNATOR (RB) = 0
          MI     X5,DFD48    IF FP BIT IS SET 
          LX5    P.ENT-P.TAG
          MX0    -L.TAG 
          BX3    -X0*X5      EXTRACT TAG FIELD
          =X7    X3-C.SYM    EXTRACT ORDINAL
          SA3    TA.NAM 
          AX7    1           1/2 TS.SYM INDEX 
          =B3    X7          = INDEX INTO TA.NAM
          SA4    X3+B3       RELATIVE ADDR ENTRY FOR THIS VARIABLE
          MX0    -L.RELADD
          BX7    -X0*X4      EXTRACT RELATIVE ADDRESS 
          BX2    X2+X7       WORD 2 = 1/..,1/..,2/0,5/TYPE,27/0,24/RELAD
          LX5    P.TAG-P.VAR  COMMON BIT TO SIGN BIT
          =X3    B1          RB = 1 
          PL     X5,DFD48    IF NOT IN COMMON 
          MX0    -L.BLOCK 
          LX4    -P.BLOCK 
          BX7    -X0*X4      EXTRACT BLOCK ORDINAL
          AX7    1           HALVE IT 
          =X3    X7+2        RB = 2+N = ITH COMMON BLOCK IN PIDL
 DFD48    LX3    P.BTBI 
          BX1    X1+X3       WORD 1 = 42/....,9/RB,9/.. 
          BX5    X6 
          LX5    -P.NLST     ARRAY BIT TO SIGN BIT
          PL     X5,DFD80    IF NOT AN ARRAY
  
*         IF THE VARIABLE IS AN ARRAY, PROCESS ITS DIMENSION
*         INFORMATION.
  
          LX5    P.NLST-P.PNT 
          MX0    -L.PNT 
          BX7    -X0*X5      EXTRACT INDEX TO TP.DIM ENTRY
          SA3    =XTP.CIDM
          =B3    X7 
          SA4    X3+B3       GET TP.DIM ENTRY 
          MX0    L.NDIM 
          BX7    X0*X4       EXTRACT NO OF DIMS 
          LX7    P.BTDM-P.NDIM
          BX2    X2+X7       WORD 2 = 1/.,1/.,2/0,5/.,5/DIMS,22/0,24/.. 
          LX7    -P.BTDM
          =B2    X7          SAVE NO. OF DIMS COUNT 
  
*         NOW DO 3RD WORD FOR DIMENSIONED VARIABLE. 
  
          BX7    X4 
          LX7    59-P.VDIM   SHIFT VDIM BIT TO SIGN BIT 
          SB7    B2 
          =A4    A4+B1
 DFD50    MI     X7,DFD54    IF VARIABLY DIMENSIONED
          LX4    P.DIM
          MX0    3-L.DIM
          BX3    -X0*X4      WORD 3 = 36/0,24/UPPER BOUND 
          SX7    B1 
          LX7    P.BTDC 
          BX3    X3+X7       WORD 3 = 1/0,1,0,1/CONS,1/0,32/0,24/...
 DFD52    BX7    X3 
          SA7    DFDSV-2+B4  DIM DESCRIPTORS SAVED HERE TEMPORARILY 
          =B7    B7-1 
          =B4    B4+1 
          ZR     B7,DFD80    IF DONE
  
*         VARIABLY DIMENSIONED. 
  
 DFD54    SX7    B4+1        NEXT DIM POSITION
          MX0    -1 
          BX7    -X0*X7 
          SA4    A4 
          NZ     X7,DFD58    IF 0DD DIMENSION POSITION
          SA4    A4+B1       GET NEXT ENTRY 
          LX4    P.DIM       DIM POSITION IS EVEN SHIFT 
*                            INFORMATION TO UPPER 30
 DFD58    BX7    X4 
          LX7    L.NDIM      VDIM BIT THIS ENTRY
          PL     X7,DFD50    THIS ONE IS A CONSTANT 
          LX4    P.DIM       SHIFT INFO TO LOWER 30 
          BX3    X4 
          MX0    -L.PWF 
          BX6    -X0*X3      EXTRACT INDEX
          =B6    X6          INDEX
          SA3    TS.SYM 
          SA3    X3+B6       GET TS.SYM ENTRY FOR THIS SUBSCRIPT
          LX3    -P.ARY      LEVEL BIT TO SIGN BIT
          =X7    1           FP BIT 
          PL     X3,DFD60    IF NOT ECS/LCM 
          LX3    P.ARY-P.LEVN 
          MX0    -L.LEVN
          BX5    -X0*X3      EXTRACT LEVEL NO 
          =B3    X5-3 
 .76      IFEQ   .CPU,76
          =B3    B3+B1
 .76      ENDIF 
          LT     B3,DFD60 
          =X7    3           LCM,FP BITS
 DFD60    LX7    P.BTFP 
          LX3    P.ARY-P.FPNO 
          MX0    -L.FPNO
          BX5    -X0*X3 
          =X5    X5-1 
          BX3    X7+X5       WORD 3 = 1/LCM,1/FP,34/0,24/FPNO 
          EQ     DFD52       SAVE CURRENT DIM DESCRIPTOR TEMPORARILY
  
*         THE 2 OR MORE WORDS ARE BUILT - FINISH OFF WORD 1 AND 
*         STUFF IT IN THE OUTPUT BUFFER.
  
 DFD80    =X5    B4 
          BX6    X1+X5       WORD 1 = 42/...,9/..,9/NO WORDS THIS ENTRY 
          SA1    BT.SYWC
          IX7    X1+X5
          SA7    A1          WC = WC + NO WORDS THIS ENTRY
          =B2    X1          = INDEX TO OUTPUT BUFFER 
          LX7    X2 
          SA6    B2+BT.SYTX  WORD 1 TO OUTPUT BUFFER
          SA7    A6+B1       WORD 2 TO OUTPUT BUFFER
          =B4    B4-2 
          EQ     B4,B0,DFD86  IF NO MORE WORDS THIS ITERATION 
  
*         STORE THE DIMENSION WORDS INTO THE OUTPUT BUFFER. 
  
 DFD82    SA1    DFDSV       DIM DESCRIPTORS SAVED HERE TEMPORARILY 
          =B4    B4-1 
 DFD83    BX7    X1 
          SA7    A7+B1       DIM DESCRIPTORS TO OUTPUT BUFFER 
          =B4    B4-1 
          MI     B4,DFD86    IF DONE
          SA1    A1+B1
          EQ     DFD83
  
*         MAKE UP THE HEADER WORD AND OUTPUT THIS BUFFER IF THERE ISNT
*         ROOM FOR 5 MORE THE NEXT TIME AROUND. 
  
 DFD86    SA1    BT.SYWC
          SX2    BT.TXTL
          IX3    X2-X1       TOTAL ALLOWED - WC 
          SX4    X3-BT=MXDM-2 X4=MAX NO OF WDS/ENTRY
          PL     X4,DFD42    IF ROOM FOR AT LEAST *BT=MXDM+2* WDS 
  
*         HERE IF 1. RAN OUT OF SYMBOLS TO PROCESS. 
*                 2. WORKING OUTPUT BUFFER IS FULL AND MUST BE EMPTIED. 
  
*         LOOK AHEAD FOR THE NEXT VALID VARIABLE TO PROCESS 
  
 DFD88    SA3    BT.SYMB     (X3) = LENGTH OF SYMBOL TABLE
          ZR     X3,DFD89    SYMBOL TABLE PROCESSING COMPLETE 
          SA5    A5+2        GET NEXT ELEMENT OF TS.SYM ENTRY 
          ZR     X5,DFD88A   ZERO ENTRY 
          LX5    -P.EST      SHIFT TYP BIT TO SIGN BIT
          MI     X5,DFD88B   IF TYPE VARIABLE 
          LX5    P.EST-P.NVAR SHIFT VAR BIT TO SIGN BIT 
          MI     X5,DFD88B   IF PROGRAMMER VARIABLE 
 DFD88A   =X7    X3-2        DECREMENT NO OF WORDS
          SA7    BT.SYMB     UPDATED BT.SYMB
          ZR     X7,DFD89    SYMBOL TABLE PROCESSING COMPLETE 
          EQ     DFD88
 DFD88B   SA5    A5-2        RESTORE A5 
  
*         MAKE A HEADER WORD FOR THIS BUFFER. 
  
 DFD89    SX6    BT=LSYM
          SA1    BT.SYWC
          =B7    X1          WORD COUNT INPUT TO *WLGO* 
          =X4    X1-1 
          LX4    P.BTWC 
          LX6    P.BTCN 
          BX0    X4+X6       = 12/5600,12/WC,36/0 
          =X7    2
          LX7    P.BTFT 
          BX0    X0+X7       = 12/5600,12/WC,12/2,24/0
          SA4    BT.SYMB
          NZ     X4,DFD90    IF NOT LAST TABLE TO BE OUTPUT 
  
*         SET THE FINAL BUFFER FLAG ON THIS BUFFER"S HEADER WORD. 
  
          =X6    1
          LX6    P.BTFI 
          BX0    X0+X6       HEADER = 12/5600,12/WC,12/2,1/FINAL,23/0 
  
*         PUT SAVEA1 WORD IN HEADER WORD. 
  
 DFD90    SA1    =XMOD
          SBIT   X1,PBLK
          MX4    0           PRESET SAVEA1 IN CASE SUBPROG IS BLOCKDATA 
          MI     X1,DFD91    IF  BLOCKDATA   SUB-PROGRAM
          SA1    =XTA.PRO 
          SA4    X1+CT.TPA1-C.PRO  EXTRACT SAVEA1 
 DFD91    BX6    X0+X4       HEADER WORD= 12/5600,12/WC,12/2,1/F,23/SVA1
          SA6    BT.SYTX
  
          WLGO   BT.SYTX,B7 
 DFD92    SA1    BT.SYMB
          ZR     X1,DFDX     IF DONE. 
          =X7    1
          SA7    BT.SYWC     WC = 1 
          EQ     DFD42
  
 #FID     ENDIF 
          SPACE  4,10 
 DFT      SPACE  4,30 
**        DFT -  DUMP FIRST TABLES FOR LOADER.
* 
* 
*         THIS ROUTINE PUMPS OUT -- 
* 
*         1.  IDNT  (77)  TABLE 
*         2.  LDSET (70)  DIRECTIVE      (IF NOT *BLOCKDATA*) 
*         3.  PIDL  (34)  TABLE 
*         4.  ENTR  (36)  TABLE          (IF NOT *BLOCKDATA*) 
*         5.  TRACEBACK WORDS            (IF NOT *BLOCKDATA*) 
*         6.  FIT(S)                     (IF     *PROGRAM*  ) 
*         7.  FILE VECTOR FOR Q8NTRY.    (IF     *PROGRAM*  ) 
* 
*         IF THERE WERE ANY FATAL ERRORS, ONLY THE 77-TABLE AND AN
*                *ERRORS* DIRECTIVE WILL BE DUMPED. 
* 
*         EXIT   TO *DFTX* FOR NORMAL CASE, OR... 
*                TO *END80* TO SUPRESS BINARY 
* 
*         USES   ALL BUT *A0*.
*                (TT.SCR) FOR BUILDING SOME SCRATCH TABLES. 
*         CALLS  DTX, ALC, STX, WLF.
  
  
 DFT8     WLGO   BT.ERR,3 
          EQ     END80       EXIT..  (BYPASS NORMAL BINARY OUTPUT)
  
 DFT      BSS    0           ENTRY... 
          SA1    =XTL.DATE
          SB2    CHAR 
          SA2    =XTL.TIME
          SA4    BINOUT 
          LX6    X1,B2
          LX7    X2,B2
          SA6    BT.IDNT+2
          =A7    A6+1 
          BX2    0
          SA1    =XCP.MODL
          MI     X4,DFT2     IF BINARY IS TO BE PRODUCED
          SA2    =10H **ERRORS
 DFT2     LX6    X1 
          BX7    X2 
          SA6    BT.IDNT+BT.IDNTU 
          =A7    A6+1 
          WLGO   BT.IDNT,L.77+1 
          SA4    BINOUT 
          PL     X4,DFT8     IF SUPPRESSED BINARY 
          SA3    MOD
          IFBIT  X3,PBLK,DFT25
          SB5    BT.LIBL     TABLE LENGTH 
          SB6    BT.LIB      TABLE ORIGIN 
  
 .RM      IFEQ   OT#RM,6
  
          SA1    =XCO.STA 
          PL     X1,DFT23    IF NOT STATIC MODE 
  
*         EXTEND LDSET TABLE TO INCLUDE NECESSARY USE 
*         TABLE FOR CRM STATIC MODE.
  
          =X3    =XM.STCRM   STLCRM. ALWAYS LOADED
          SA5    MOD
          LX5    48 
          PL     X5,DFT20 IF NOT MAIN PROGRAM 
          MX5    1
          LX5    12 
          BX3    X3+X5    ADD ONE MORE SELECTION TO LDSET FILE
 DFT20    SA4    CO.ER
          SA2    =XSTATIC 
          ZR     X4,DFT21    IF NO ERROR RECOVERY 
          SX3    X3+=XM.STRP2 
  
 DFT21    =X6    BT.LIBL+1   LENGTH LDSET,LIB+USE HEADER
          BX5    X3+X2
          CX4    X5          NUMBER OF USE ENTRIES
          IX0    X4+X6
          SHRINK TT=SCR 
          ALLOC  TT.SCR,X0   ROOM FOR LDSET,LIB,USE TABLE 
          SB5    X2          TABLE LENGTH 
          SB6    X1          TABLE ORIGIN 
          MVE    BT.LIBL,BT.LIB,B6
          SX7    BT=USE 
          =X2    X4+1 
          SA3    B6 
          BX0    X4 
          LX2    P.BTWC      LDSET WORD COUNT INCREMENT 
          LX0    P.BTWC      USE WORD COUNT 
          LX7    P.BTCN 
          IX6    X3+X2
          BX7    X7+X0
          SA2    =XSTLTAB 
          SA6    A3          RESET LDSET HEADER 
          =A7    B6+BT.LIBL  SET USE HEADER 
          =A2    A2-1        PRELOAD
  
 DFT22    LX5    -1 
          =A2    A2+1        NEXT USE NAME
          ZR     X2,DFT23    IF FINISHED
          PL     X5,DFT22    IF ROUTINE NOT NEEDED
          BX7    X2 
          =A7    A7+1        STORE USE NAME 
          EQ     DFT22       LOOP 
  
 .RM      ENDIF 
  
 DFT23    WLGO   B6,B5       WRITE OUT LDSET
  
  
**        PIDL - PROGRAM IDENTIFICATION AND LENGTH TABLE. 
*                ALSO CONTAINS THE LOCAL COMMON BLOCK TABLE.
  
 DFT25    SA2    TS=BLK 
          AX0    X2,B1
          SHRINK TT=SCR 
          ALLOC  TT.SCR,X0+1 ROOM FOR *PIDL* TABLE PLUS HEADER WORD 
          SA3    IDENT
          =X2    X2-1        (X2) = LENGTH OF *PIDL* TABLE
          SA4    LOCAL
          =B7    X2+1        (B7) = LENGTH OF SCRATCH TABLE 
          SA5    TS.BLK 
          =X7    BT=PIDL
          =B3    2
          LX7    P.BTCN 
          BX6    X3+X4
          LX2    P.BTWC 
          IX7    X7+X2
          SA4    X5+2        INITIALIZE A4
          SA7    X1          *PIDL* CONTROL WORD
          =A6    X1+1 
 DFT3     EQ     B3,B7,DFT55 IF NO MORE BLOCKS
          =B3    B3+1 
          =A5    A4+1        BLOCK LENGTH/LEVEL WORD
          MX0    -L.BLEN
          BX3    -X0*X5      ISOLATE BLOCK LENGTH 
          AX5    P.BLVL      RIGHT-JUSTIFY LEVEL
          MX0    -L.BLVL
          BX5    -X0*X5      ISOLATE BLOCK LEVEL
          SB5    X5-3 
          ZR     B5,DFT43    IF LEVEL 3 
  
 .76      IFEQ   .CPU,76
  
          SB5    X5-2 
          ZR     B5,DFT43    IF 7000 LEVEL 2
  
 .76      ENDIF 
  
          EQ     DFT5 
  
*         ECS/LCM BLOCKS USE LENGTH = (BLEN)/8 -- ROUNDED UP
  
 DFT43    MX0    -3 
          BX5    -X0*X3      GRAB REMAINDER 
          AX3    3           DIVIDE BY 8
          ZR     X5,DFT45    IF DIVISION EXACT
          =X0    1
          IX3    X3+X0       LENGTH FOR *PIDL*
 DFT45    MX0    1
          LX0    P.BTYP+1    POSITION ECS/LCM BIT 
          BX3    X3+X0
 DFT5     BX6    X4+X3       42/NAME,  1/TYPE,  17/LENGTH 
          =A6    A6+1 
          =A4    A5+1        NEXT ENTRY (PRESUMABLY)
          EQ     DFT3        LOOP 
  
 DFT55    WLGO   X1,B7       OUTPUT *PIDL* TABLE
          SA3    MOD
          BX6    0
          SBIT   X3,PBLK
          SHRINK TT=SCR,X6   REMOVE THE ALLOCATION
          MI     X3,DFTX     IF *BLOCKDATA*, EXIT.. 
  
**        DUMP *ENTR* TABLE.
  
          SA5    TS=ENT 
          LX0    X5,B1
          SB5    X5          SAVE (B5) = LENGTH OF ENTRY POINT TABLE
          ALLOC  TT.SCR,X0   ROOM TO BUILD THE *ENTR* TABLE 
          SA4    BT.ENTR
          =B7    X2+1        (B7) = LENGTH OF SCRATCH TABLE 
          LX2    P.BTWC 
          BX6    X4+X2
          SA3    TS.SYM 
          =X0    1
          SA5    TS.ENT 
          =B4    X3+1        B4 = FWA TAG TABLE 
          LX0    P.BTRL 
          SA6    X1          *ENTR* CONTROL WORD
          SA4    X5          (A4) = FWA ENTRY PTS.
  
 DFT6     SA3    X4+B4       FETCH TAG WORD 
          SX5    X4          ISOLATE ORDINAL
          =B5    B5-1 
          AX3    P.PNT
          BX7    X4-X5       ISOLATE NAME 
          SX6    X3 
          =A7    A6+1 
          BX6    X0+X6       INDICATE PROGRAM-RELATIVE ADDRESS
          =A4    A4+1 
          =A6    A7+1 
          NZ     B5,DFT6     IF MORE ENTRY POINTS 
  
          WLGO   X1,B7
          SHRINK TT=SCR      REMOVE THE ALLOCATION
  
**        OUTPUT TRACEBACK WORDS. 
  
          SA1    =XNAME      ROUTINE NAME SPACE FILLED
          LX1    CHAR 
          MX0    7*CHAR 
          BX1    X0*X1       TRUNCATE TO 7 CHARACTERS 
          SA4    ENTRY. 
          SX4    X4 
          SA3    TA.NAM 
          AX7    X4,B1       = HALF ORDINAL 
          IX0    X7+X3
          SA5    X0          FETCH ADDRESS OF MAIN ENTRY POINT
          SX3    X5 
          BX6    X1+X3
          SA6    BT.1ST+2 
          WLGO   BT.1ST,BT.1STL+1 
  
*         ADD FITS IF MAIN PROGRAM. 
  
          SA1    MOD
          IFBIT  X1,-PPRO,DFTX
  
          SA2    TA.PRO 
          =A3    X2+CT.FILE-C.PRO 
          SX6    X3 
          SA6    ORG
          RJ     DTX         SET ORIGIN = *FILE.* 
  
*         OUTPUT *Q2NTRY* *LIST* AP-LIST. 
  
 .RM      IFEQ   OT#RM,6
  
          SA1    TA.PRO 
          SA2    NARGS       NUMBER OF FILES
          SA3    X1+CT.FILE-C.PRO 
          SB7    X2 
          SX1    X3+L.LIST   ADDRESS OF FILES VECTOR
          NZ     X2,DFT60    IF MAIN PROGRAM WITH FILES 
          SA2    =XCO.STA 
          ZR     X2,DFT60    IF NOT STATIC MODE 
          =X1    X1+1        BIAS OF STLTAB AP-LIST POINTER 
          SX6    X1+B7       FILES VECTOR ADDRESS + NO. OF FILES
          =X6    X6+1        + ZERO TERM. = ADDRESS OF STLTAB 
          PX6    B1,X6       PACK IN AP-LIST WORD IDENTIFIER
          SA6    DFTA        STORE IN TEMP
  
 DFT60    PX1    B7,X1       PACK IN NUMBER OF FILES
          =X2    2           LOWER PROGRAM RELOCATION 
          RJ     STX
          SA1    PLIMIT      PRINT LIMIT
          SA2    =XCO.STA    STATIC INDICATOR 
          BX1    X1+X2
          =X2    0           NO RELOCATION
          RJ     STX
          SA1    DFTA 
          ZR     X1,DFT65    IF NO STLTAB NEEDED
          =X2    2           LOWER PROGRAM RELOCATION 
          RJ     STX         OUTPUT STLTAB POINTER
  
 DFT65    =X1    0           ZERO TERMINATOR
          IX2    X2-X2
          RJ     STX
  
 .RM      ENDIF 
  
 DFT70    SA1    T.FILE 
          SA2    T=FILE 
          =X3    3
          IX6    X1+X3
          SA5    X1 
          MX4    L.FNAM 
          IX7    X2-X3
          ZR     X5,DFT78    IF NO MORE FILES 
          SA6    A1 
          SA7    A2 
          BX0    X4*X5       ISOLATE FILE NAME
          =A5    A5+1 
          BX3    X5 
          =X2    2           LOWER PROGRAM RELOCATION 
          AX3    P.FFIT 
          SX6    X3          FIT ADDRESS OF FILE
          BX1    X6+X0
          RJ     STX         OUTPUT POINTER WORD
  
          SA1    T.FILE 
          SA5    X1+1-3      (A5,X5) = 2ND WORD OF FILE TABLE ENTRY 
          MI     X5,DFT70    IF EQUIVALENCED FILE, DON-T ISSUE FIT
          SX4    X5          (X4) = CIO BUFFER LENGTH (BFS) 
          AX5    P.FFIT 
          SX0    X5          (X0) = FIT ORIGIN
          MX7    -18
  
 .RM      IFEQ   OT#RM,6
  
*         ENTER FIT-RELATIVE ORIGIN ADDRESSES IN LOADER TEXT SKELETONS. 
  
          SA1    BT.FCAH
          SA2    BT.REPC+1
          BX1    X7*X1
          IX6    X1+X0
          SA6    A1          FIT (A) TEXT TABLE HEADER
          BX2    X7*X2
          SX1    X0+BT.FCAL-1      ZERO WORD REPL SOURCE ADDR 
          BX6    X2+X1
          SA6    A2          REPL SOURCE WORD 
          SA1    BT.FCBH
          SA2    BT.FCCH
          SX3    X0+L.FIT1   FIT (B) ORIGIN 
          BX1    X7*X1
          IX6    X1+X3
          BX2    X7*X2
          SA6    A1          FIT (B) TEXT TABLE HEADER
          SX3    X0+L.FIT6-L.FCLX  FIT (C) ORIGIN 
          BX6    X2+X3
          SA6    A2          FIT (C) TEXT TABLE HEADER
  
*         ENTER LFN AND CIO BUFFER INFO (FWB, BFS) IN SKELETONS.
  
          SA1    A5-B1       LFN
          SX2    B1          CIO COMPLETE BIT 
          BX3    X7*X1
          IX6    X3+X2
          AX5    P.FBUF-P.FFIT
          SA6    BT.FCA      LFN, CMPLT TO FIT (A)
          BX7    0           PRESET NO FWB RELOCATION 
          MX6    0           PRESET NO FWB
          SA3    TA.PRO 
          ZR     X4,DFT72    IF NO CIO BUFFER (BFS=0) 
          SB2    X5-C.PRO 
          SA1    X3+B2       BUFFER ORIGIN (FWB)
          =X7    2           PGM LOCAL RELOC
          BX6    X1          SET FWB
          LX7    60-2*4      SET FWB (2ND WORD) RELOCATION
 DFT72    SA6    BT.FCA+1    FWB OR 0 TO FIT (A)
          SA7    BT.FCAH+1   RELOCATION BYTES OR 0 TO FIT (A) 
          LX7    X4 
          BX4    0           PRESET NO MRL
          SA7    BT.FCB+7    BFS TO FIT (B) 
  
*         ENTER MRL AND WSA.  WRITE FIT (A), REPL, FIT (B) AND FIT (C)
*         TO BINARY OUTPUT FILE.  NOTE THAT FIT (C) IS WRITTEN ONLY IF
*         MRL WAS SPECIFIED (MRL .NE. 0). 
  
          SB7    BT.FITCL-BT.FCCTL       PRESET *OMIT FIT (C)*
          SA5    A5+B1
          MX6    2           =6S57, PRESET NO WSA 
          BX7    0           PRESET NO WSA RELOCATION 
          LX6    30-57       ERR OPT (EO) = AD = 6S30 
          MI     X5,DFT74    IF MRL NOT SPECIFIED 
          MX0    -L.FRCL
          BX4    -X0*X5      EXTRACT MAX RECORD LENGTH (MRL)
          AX5    P.FREC 
          SB2    X5-C.PRO 
          SA1    X3+B2       WSA ORIGIN 
          LX4    P.BTMRL
          BX7    X4+X1
          IX6    X6+X1       EO, WSA
          SA7    BT.FCC      MRL, WSA TO FIT (C)
          SB7    BT.FITCL    SET *WRITE FIT (C)*
          =X7    2           PGM LOCAL RELOC
          LX7    60-6*4      SET WSA (6TH WORD) RELOCATION
 DFT74    SA6    BT.FCB+5    EO/WSA OR 0 TO FIT (B) 
          SA7    BT.FCBH+1   WSA RELOC BYTE OR 0 TO FIT (B) HEADER
          BX6    X4 
          SA6    BT.FCB+2    MRL TO FIT (B) 
          WLGO   BT.FITC,B7  LOADER TABLES (3 OR 4) TO BIN OUTPUT FILE
          EQ     DFT70       LOOP FOR NEXT FILE 
  
 .RM      ENDIF 
  
 .RM      IFEQ   OT#RM,7
  
*         ENTER FIT-RELATIVE ORIGIN ADDRESSES IN LOADER TEXT SKELETONS. 
  
          SA1    BT.F7AH
          SA2    BT.REP7+1
          SX3    X0+BT.F7AL-1      ZERO WORD REPL SOURCE ADDR 
          BX1    X7*X1
          IX6    X1+X0
          SA6    A1 
          BX2    X7*X2
          IX6    X2+X3
          SA6    A2 
  
*         ENTER MRL AND WSA.  WRITE FIT (A) AND REPL TO BINARY OUTPUT 
*         FILE. 
  
          SA5    A5+B1
          BX7    0           PRESET NO WSA RELOCATION 
          MX6    0           PRESET NO MRL/WSA
          MI     X5,DFT76    IF MRL NOT SPECIFIED 
          MX0    -L.FRCL
          SA3    TA.PRO 
          BX4    -X0*X5      EXTRACT MAX RECORD LENGTH (MRL)
          AX5    P.FREC 
          SB2    X5-C.PRO 
          SA3    X3+B2       WSA ORIGIN 
          LX4    P.BTMRL
          =X7    2           PGM LOCAL RELOC
          BX6    X4+X3
          LX7    60-7*4      SET WSA (7TH WORD) RELOCATION
 DFT76    SA6    BT.F7A+6    MRL/WSA OR 0 TO FIT
          SA7    A1+B1       WSA RELOC BYTE OR 0 TO TEXT HEADER 
          WLGO   A1,BT.FIT7L FIT AND REPL TO BINARY OUTPUT FILE 
          EQ     DFT70       LOOP FOR NEXT FILE 
  
 .RM      ENDIF 
  
  
  
*         LASTLY, TERMINATE THE FILE VECTOR TABLE WITH -- 
*         (CRM) ONE ZERO WORD, OR 
*         (7RM) ONE WORD CONTAINING THE COMPLEMENT OF THE RUN-TIME
*               *OUTPUT* FILE PRINT LIMIT.
  
 DFT78    =X6    X1+1 
          SX7    X7+2        MARK LAST WORD REMOVED 
          SA6    A1 
          SA7    A2 
          SA3    =XOT.RM
          BX2    0
          SA1    PLIMIT 
          BX6    -X3
          IX7    X2+X6
          BX3    X3+X7       +0 IF (OT.RM)=0, ELSE -0 
          BX1    -X1*X3      +0 IF (OT.RM)=0, ELSE -(PLIMIT)
          RJ     STX         OUTPUT FILE LIMIT TERMINATES TABLE 
  
 .RM      IFEQ   OT#RM,6
  
*         GENERATE WEAK EXTERNAL TABLE IF REQUIRED + LINK 
  
          SA1    DFTA 
          ZR     X1,DFTX     IF NO STLTAB NEEDED,  EXIT.. 
  
          SHRINK =XTT=SCR 
          SX2    =XN.STL
          SX1    =XL.STL+2   STLTAB, HEAD OF STLTAB + XLINK 
          LX4    B1,X2
          IX2    X2+X4       LENGTH OF ASSOCIATED XLINK 
          IX0    X1+X2
          ALLOC  =XTT.SCR,X0
          SB5    X2          TABLE LENGTH 
          SX3    =XL.STL+1
          SX6    BT=TEXT     CONSTRUCT TEXT TABLE HEADER
          LX3    P.BTWC 
          LX6    P.BTCN 
          =X4    1
          BX6    X6+X3       OR IN WORD COUNT 
          LX4    P.BTRL 
          SA2    DFTA 
          BX6    X6+X4       OR IN RELOCATION 
          SX2    X2 
          BX6    X6+X2       OR IN FWA STLTAB 
          MX7    0
          SA6    X1          STORE IN TT.SCR
          =A7    A6+1        STORE ZERO RELOCATION WORD 
          SB4    =XL.STL
  
 DFT77    =A7    A7+1 
          =B4    B4-1 
          NZ     B4,DFT77    IF NOT FINISHED STLTAB BODY
  
*         OUTPUT XLINK FOR WEAK EXTERNAL STLTAB.
  
          SX3    =XN.STL
          SX6    BT=XLINK    CONSTRUCT XLINK HEADER 
          LX4    B1,X3
          IX3    X4+X3       LENGTH OF XLINK BODY 
          LX6    P.BTCN 
          =X3    X3-1        XLINK BODY - FINAL TERMINATOR
          LX3    P.BTWC 
          BX6    X6+X3
          SA2    DFTA 
          =A6    A7+1        STORE XLINK HEADER 
          =X5    X2-1        (X5) = FWA STLTAB - 1
          SA3    =XSTLTAB    (A3/X3) = FWA AND CONTENTS OF STLTAB 
          =X4    1           (X4) = 1 
          MX0    1           (X0) = TOGGLE
  
 DFT77.3  SX2    0           LOW ORDER BIT POSITION 
          BX7    X3+X4       NAME + WEAK EXTERNAL BIT 
          PL     X0,DFT77.6  IF TOGGLE, SET LOW 30 BIT POSITION 
          SX2    30          HIGH 30 BIT POSITION 
          =X5    X5+1        BUMP RELOCATION WORD ADDRESS 
  
 DFT77.6  LX0    30          TOGGLE THE TOGGLE
          BX6    X5 
          LX2    P.BTXPS
          LX6    P.BTXRA
          =A7    A6+1        STORE FIRST WORD XLINK 
          BX6    X6+X2       RA + POS 
          SX7    L.STLF 
          BX6    X6+X4       RA+POS + RELOC BASE
          LX7    P.BTXSZ
          BX6    X6+X7       RA+POS+RELOC BASE + ADDR FIELD LENGTH
          =A6    A7+1        STORE SECOND WORD XLINK
          =A3    A3+1        NEXT STLTAB ENTRY
          ZR     X3,DFT77.8  IF FINISHED
          MX6    0
          SA6    A6+1        TERMINATOR FOR THIS ENTRY
          EQ     DFT77.3
  
 DFT77.8  WLGO   X1,B5       WRITE IT ALL OUT 
  
 .RM      ENDIF 
          EQ     DFTX 
 .RM      IFEQ   OT#RM,6,2
          ENTRY  DFTA 
 DFTA     BSSZ   1           TEMP CELL OF FWA STLTAB
  
 DLF      SPACE  4,15 
**        DLF -  DUMP *LINK*, *FILL*, AND *XFILL* TABLES. 
* 
*         DUMPS LINK AND FILL TABLES TO BINARY. 
* 
*         TABLE MANAGER MAY CALL THIS ROUTINE TO FREE UP TABLE SPACE. 
*         WHEN IT DOES SO, THE LGO FILE MUST HAVE BEEN ALREADY FLUSHED
*         TO DISK, AND (LGOIO) UPDATED TO REFLECT THIS.  OTHERWISE, WHEN
*         WE ATTEMPT TO ADD WORDS TO AN SCM-RESIDENT LGO FILE, A NASTY
*         INFINITE LOOP RESULTS.
* 
*         BASIC IDEA STOLEN FROM *DLAST* IN *COMPASS VER 2.0*.
*         CALLS  SRT, WLF.
  
  
 DLF8     NZ     B5,DLF85 
          SA6    A6+B1       STORE HANGING HALF-WORD
 DLF85    SX4    BT=FILL
          SX3    A6-B6
          LX4    P.BTCN 
          =B7    X3+1 
          LX3    P.BTWC 
          BX6    X4+X3       MANUFACTURE CONTROL WORD 
          SA6    B6 
          WLGO   B6,B7
  
*         PROCESS *XFILL* TABLE 
  
 DLF9     SA2    =XTT=XFIL
          SA1    =XTT.XFIL
          SB7    X2 
          SB6    X1          B6 = FWA TABLE 
          EQ     B7,B1,DLF   IF EMPTY *XFILL* TABLE, EXIT.. 
          SX4    BT=XFILL 
          SX3    B7-B1
          LX4    P.BTCN 
          LX3    P.BTWC 
          BX6    X4+X3       MANUFACTURE CONTROL WORD 
          SA6    B6 
  
 SNAP=X   IFNE   TEST        DUMP *XFILL* TABLE 
          SA3    CO.SNAP
          LX3    1RX
          PL     X3,DLF8S 
          DUMPT  (=XTT.XFIL)
 DLF8S    BSS    0
 SNAP=X   ENDIF 
  
          WLGO   B6,B7
          SHRINK TT=XFIL,1
  
 DLF      SUBR               ENTRY/EXIT...
  
*         PROCESS *LINK* TABLE. 
  
 SNAP=K   IFNE   TEST        DUMP *LINK* TABLE
          SA3    CO.SNAP
          LX3    1RK
          PL     X3,DLF0S    IF LINK TABLE SNAP NOT SELECTED
          DUMPT  (TT.LINK)
 DLF0S    BSS    0
 SNAP=K   ENDIF 
  
          SA2    TT=LINK
          SA1    TT.LINK
          SA3    NREXT
          IX6    X2-X3
          ZR     X6,DLF5     IF NO EXTERNALS
          SA6    A2          FAKE LENGTH TO ACTUAL FOR SORT 
          IX1    X1+X3       ADJUST ORIGIN TO IGNORE GHOST WORDS
          RJ     SRT
  
          SA1    TT.LINK
          SA2    TT=LINK
          SA3    TS.SYM 
          SA4    NREXT
          SA0    X3          A0 = FWA NAME TAB
          IX0    X1+X4
          SB7    X2          B7 = (LEN LINK)
          SA5    X0 
          SB4    X1          (B4) = FWA PHYSICAL TABLE
          SB6    30 
          SA6    X1          PRESET STORE ADDR
          MX1    L.SYM
          MX0    30 
          SB5    -B1
          SB2    -B1
  
 DLF2     AX2    X5,B6       ISOLATE EXT NO 
          SB3    X2 
          SB2    B2+B1
          BX7    -X0*X5      ISOLATE 30/OUTPUT STUFF
          EQ     B3,B5,DLF3    IF SAME AS LAST EXT
          SA3    B3+A0       FETCH EXT NAME 
          SB5    B3 
          LX6    30 
          ZR     B2,DLF25    IF NO HANGING HALF-WORD
          SA6    A6+B1
 DLF25    BX6    X1*X3       ISOLATE NAME 
          SB2    B0 
          SA6    A6+B1       STORE NEW NAME 
          BX6    0
 DLF3     SB7    B7-B1
          LX4    X6,B6
          BX6    X7+X4
          SA5    A5+B1
          ZR     B2,DLF4     IF LOWER BYTE
          SA6    A6+B1
          SB2    -B1
          BX6    0
 DLF4     NZ     B7,DLF2     IF TABLE NOT EXHAUSTED 
          LX6    30 
          MI     B2,DLF45    IF NO HANGING HALF-WORD
          SA6    A6+B1
 DLF45    SX7    A6-B4       RESULTANT SIZE OF LINK TABLE 
          SA1    TT.LINK
          =B7    X7+1 
          SX4    BT=LINK
          LX7    P.BTWC 
          SB6    X1 
          LX4    P.BTCN 
          BX6    X4+X7       FORM *LINK* CONTROL WORD 
          SA6    B6 
          WLGO   B6,B7       WRITE OUT THE LINK TABLE 
  
 DLF5     SA1    NREXT
          SHRINK TT=LINK,X1 
  
*         PROCESS *FILL* TABLE. 
  
          SA2    TT=FILL
          SA1    TT.FILL
          SB7    X2 
          BX6    0
          EQ1    B7,DLF9     IF EMPTY *FILL* TABLE
          SA6    X1          ZERO THE DUMMY WORD SO SORT WONT MOVE IT 
          RJ     SRT
  
          SA1    TT.FILL
          SA2    TT=FILL
          MX0    -30
          SB2    30 
          SB6    X1          B6 =  FWA  TABLE 
          BX7    0
          SB4    X2+B6       B4 = LWA+1 TABLE 
          SA1    B6+B1       FETCH FIRST ENTRY
          SHRINK A2,1 
          SA6    B6-B1
          SB3    B6+B1
  
 DLF6     BX6    X6+X3
          SB5    30 
          SA6    A6+B1
 DLF7     GE     B3,B4,DLF8     IF TABLE EXHAUSTED
          AX2    X1,B2
          SB3    B3+B1
          BX4    X7-X2
          ZR     X4,DLF75    IF SAME BLOCK AS PREVIOUS
          SB3    B3-B1       SET TO RE-PROCESS LAST ENTRY 
          BX1    X2 
          LX7    X2 
  
 DLF75    BX3    -X0*X1      ISOLATE FILL BYTE
          SA1    B3 
          ZR     B5,DLF6     IF LOWER 
          LX6    X3,B2
          SB5    B2-B5       INDICATE NEXT IS LOWER 
          EQ     DLF7 
 DTX      SPACE  4,15 
**        DTX -  DUMP *TEXT* TABLE. 
*         IF TABLE IS EMPTY, NO WRITE WILL TAKE PLACE, BUT THE TABLE
*                WILL BE RESET TO INDICATE *EMPTY* AND (ORG). 
*         USES   A1-A4,A6,A7  B2,B3,B5-B7 
*         CALLS  WLF. 
  
  
 DTX7     SA1    ORG
          =X2    1
          BX7    0
          LX2    P.BTRL 
          SA7    BT.TXRB
          IX6    X1+X2       ADJUST INTERNAL BLOCK ORDINAL TO LOADER
                                   BLOCK NUMBER.
          SA6    A7-B1
          SA7    A6-B1
  
 DTX      SUBR               ENTRY/EXIT...
          SA1    BT.TXWC
          SX7    X1-15
          SX6    BT=TEXT
          ZR     X1,DTX7     IF EMPTY TABLE, AVOID..
          =A3    A1+1 
          LX7    2
          SA2    A3+B1       BT.TXRB WORD 
          SX1    X1+B1
          LX6    P.BTCN 
          SB7    X1+B1
          SB3    X7          SHIFT FOR PARTIAL TABLE RELOC BYTES
          LX1    P.BTWC 
          BX3    X6+X3
          SB6    A3 
          IX6    X3+X1
          AX7    X2,B3
          SA6    A3 
          SA7    A2 
          WLGO   B6,B7
          EQ     DTX7 
 KAP      SPACE  4,8
**        KAP -  COMPILE AP-LISTS.
*         RELOCATES AND RE-FORMATS *TP.APL* INTO BINARY LOADER TEXT.
*         ENTRY  (X1) = ORIGIN OF AP-LISTS. 
*         USES   ALL
*         CALLS  DTX, REL, STX. 
  
  
 KAP      SUBR               ENTRY/EXIT...
          BX7    0
          BX6    X1 
          SA7    BINWORD
          SA6    ORG
          SA7    A7+B1
          MX6    -L.LBIAS 
          SA6    RELMASK
          RJ     DTX         RESET TEXT TABLE 
  
 KAP2     SA4    TP=APL 
          SA2    TP.APL 
          MX3    -1 
          IX7    X4+X3       DECREMENT LENGTH OF TABLE
          SX6    X2+B1       INCREMENT ORIGIN OF TABLE
          SA1    X2          FETCH TABLE ENTRY
          ZR     X4,EXIT.    IF TABLE EXHAUSTED 
          SA7    A4 
          SA6    A2 
          BX2    0
          ZR     X1,KAP8     NO RELOCATION FOR +-0
          MX0    -L.APIO
          MI     X1,KAP8     NO RELOCATION FOR NEGATIVE ENTRIES (PLUGS).
          BX5    -X0*X1 
          BX1    X0*X1       REMOVE I/O BITS
          LX1    P.LTAG-P.ATAG     ADJUST TO LONG FILE FORM 
          ZR     X5,KAP7     IF NORMAL (NOT I/O) ITEM 
          BX6    0           CLEAR ACCUMULATOR FOR EXTRA GOODIES
          =X0    M.AVAR 
          BX3    X0*X5
          LX3    P.IOIND-P.AVAR    COPY *IOIND* BIT 
          LX0    P.AFIT-P.AVAR
          BX2    X0*X5
          LX2    P.IOFIT-P.AFIT    COPY VARIABLE FIT BIT
          BX6    X3+X2
          LX0    P.ALCM-P.AFIT
          BX3    X0*X5
          LX3    P.IOLCM-P.ALCM 
          MX0    -L.ASIZ
          BX2    -X0*X5      ISOLATE *ASIZ* 
          BX6    X6+X3       COPY *LCM* BIT 
          AX5    P.ATYP 
          MX4    -L.ATYP
          BX7    -X4*X5 
          SB7    X7          ISOLATE *ATYP* FIELD 
          SX5    X2 
          JP     B7+*+1 
  
          LOC    0           APTYP     ?ASIZ? 
  
          EQ     KAP6          0       IGNORE 
  
          EQ     KAP4          1       SIZE 
  
          SA3    BA.CON        2       CON-TAG ORDINAL
          EQ     KAP3 
  
          SA3    BA.TEM        3     VAR-DIM TAG ORDINAL
          EQ     KAP10
  
          SA3    TA.PRO        4       PRO-TAG ORDINAL
          EQ     KAP9 
  
          LX1    X5            5       OUTPUT CONTROL 
          BX2    0
          LX1    P.IOTYP
          EQ     KAP8         NO RELOCATION 
          LOC    *O 
  
 KAP3     IX5    X3+X5
          =X4    1
          LX4    P.IOIND
          BX6    X6+X4       SET INDIRECT BIT 
          SX7    10B
          LX5    P.IOSIZ-P.IOLEN
          SA7    BINREL      INDICATE UPPER ADDRESS RELOCATABLE 
  
 KAP4     SA2    TS.SYM 
          BX3    X1 
          LX5    P.IOLEN
          IX6    X5+X6
          MX0    -L.PWF 
          AX3    P.LTAG 
          BX4    -X0*X3      TAG ORDINAL
          AX3    L.PWF       TAG TYPE 
          SB7    X3-C.VAR/1S13
          NZ     B7,KAP5     IF NOT VARIABLE TAG
          IX2    X2+X4
          MX7    -L.FPNO
          SA3    X2          FETCH TAG WORD 
          MX0    -L.MODE
          BX5    -X0*X3      ISOLATE TYPE 
          AX3    P.FPNO 
          LX5    P.IOTYP
          BX7    -X7*X3 
          BX6    X5+X6
          ZR     X7,KAP6     IF NOT A FORMAL PARAMETER
          AX1    P.LBIAS
          =X5    1
          MX0    -L.LBIAS 
          IX7    X7-X5
          BX3    -X0*X1 
          BX1    X6+X7       *FP* NUMBER
          LX5    P.IOFP      SET *IOFP* BIT 
          SA2    BINREL 
          LX3    L.IOARG
          BX1    X1+X5
          BX1    X1+X3
          EQ     KAP8        NO RELOCATION FOR FORMAL PARAMETER 
  
**        TAG IS TEMP OR CONSTANT --
*                (BIAS) FIELD CONTAINS THE MODE.
  
          SYMASK (LBIAS)
 KAP5     SA3    ="E"B
          BX2    X3*X1
          BX1    -X3*X1      CLEAR OLD BIAS FIELD 
          AX2    L.MODE 
          BX0    X3*X2       EXTRACT ACTUAL OFFSET
          IX1    X1+X0
          BX5    -X3*X2      EXTRACT MODE 
          LX5    P.IOTYP-P.LBIAS+L.MODE 
          BX6    X5+X6
  
 KAP6     SA6    BINWORD
  
 KAP7     =B2    1           INDICATE LOWER ADDRESS 
          BX5    X1 
          RJ     REL         RELOCATE THE ADDRESS 
          SA1    BINWORD
          =A2    A1-BINWORD+BINREL
  
 KAP8     RJ     STX         STORE INTO TEXT TABLE
          EQ     KAP2        LOOP.. 
  
**        TAG IS PROGRAM -- 
*                USED FOR *ERR=* ADDRESS FIELD
  
 KAP9     IX5    X3+X5
          =X7    4
          SA3    X5          FETCH TABLE ENTRY
          SA7    BINREL      INDICATE UPPER ADDRESS RELOCATABLE 
          SX6    X3 
          LX6    30          MOVE TO UPPER
          PL     X3,KAP6     IF CODE-RELATIVE 
          SA5    BA.APL 
          LX5    30 
          IX6    X5+X6
          EQ     KAP6 
 KAP10    SA2    TEM.MAX
          SX4    X2-C.TEM 
          IX3    X3+X4
          EQ     KAP3 
 KCF      SPACE  4,8
**        KCF -  COMPILE CONSTANTS AND FORMATS. 
*         ENTRY  (X1) = ORIGIN OF CONSTANTS.
  
  
 KCF      SUBR               ENTRY/EXIT...
          SA2    TS.CON 
          SA3    TS=CON 
          LX7    X1 
          BX6    0
          SA7    ORG
          SHRINK A3,X6       DE-ALLOCATE CONSTANT TABLE 
          SB4    X3          B4 = LENGTH OF TABLE 
          SA5    X2 
          RJ     DTX         INITIALIZE TABLE 
          ZR     B4,KCF5     IF NO CONSTANTS
  
 KCF2     MX2    0
          BX1    X5 
          RJ     STX
          SB4    B4-B1
          SA5    A5+B1
          NZ     B4,KCF2     IF TABLE NOT EXHAUSTED 
  
*         DUMP FORMATS. 
  
 KCF5     SA2    TP.FMT 
          SA3    TP=FMT 
          BX6    0
          SB4    X3 
          SA5    X2 
          ZR     B4,EXIT.    IF NO FORMATS
          SHRINK A3,X6       DE-ALLOCATE FORMAT TABLE 
  
 KCF6     MX2    0
          BX1    X5 
          RJ     STX
          SB4    B4-B1
          SA5    A5+B1
          NZ     B4,KCF6     IF TABLE NOT EXHAUSTED 
          EQ     EXIT.
 KNS      SPACE  4,8
**        KNS -  COMPILE *NAMELIST* SPACE.
*         RELOCATES AND RE-FORMATS *TP.NLST* INTO BINARY LOADER TEXT. 
*         ENTRY  (X1) = ORIGIN FOR NAMELIST GROUP DESCRIPTORS.
*         USES   ALL
*         CALLS  DTX, REL, STX. 
  
  
 KNS9     SHRINK TP=NLST,0
  
 KNS      SUBR               ENTRY/EXIT...
  
 SNAP=E   IFNE   TEST        DUMP NAMELIST TABLE
          SA2    CO.SNAP
          LX2    1RE
          PL     X2,KNS1S    IF NO *END* SNAP SELECTED
          DUMPT  (TP.NLST)
 KNS1S    BSS    0
 SNAP=E   ENDIF 
          BX6    X1 
          SA6    ORG
          MX6    -L.LBIAS 
          SA6    RELMASK
          RJ     DTX         INITIALIZE TEXT TABLE
  
 KNS2     SA2    TP=NLST
          SA3    TP.NLST
          MX4    -1 
          IX7    X2+X4       SHRINK TABLE BY ONE WORD 
          SA1    X3 
          =X6    X3+1 
          ZR     X2,KNS9     IF TABLE EXHAUSTED 
          SA7    A2 
          SA6    A3 
          BX2    0
          RJ     STX         OUTPUT GROUP-NAME WORD 
          EQ     KNS7 
  
**        OUTPUT ITEM-NAME WORD 
  
 KNS4     =X2 
          RJ     STX         OUTPUT ITEM-NAME WORD
  
          SA2    TP=NLST
          SA3    TP.NLST
          MX4    -1 
          IX7    X2+X4       SHRINK TABLE BY ONE WORD 
          SA5    X3 
          =X6    X3+1 
          ZR     X2,E.ZA     IF TABLE EXHAUSTED 
          MX2    -P.DIM 
          SA7    A2 
          SA6    A3 
          BX6    X2*X5
          =B2    1           INDICATE LOWER PARCEL
          BX5    -X2*X5 
          SB6    X5          SAVE TAG 
          SA6    BINWORD
          LX5    P.LTAG 
          RJ     REL         COMPUTE ADDRESS RELOCATION 
          SA1    BINWORD
  
 #MD      IFEQ   .DAL,1 
  
          SX5    B6          RESTORE TAG
          BX6    X1          SAVE (BINWORD) 
          LX5    P.2TAG 
          RJ     =XCLT       CHECK FOR LCM TAG
          BX1    X6          (BINWORD)
          NZ     X3,KNS5     IF NOT LCM TAG 
          MX0    1
          LX0    1+29 
          BX1    X0+X1       INSERT LCM BIT 
 KNS5     BSS    0
  
 #MD      ENDIF 
  
          SA2    BINREL 
 KNS6     RJ     STX         OUTPUT ADDRESS WORD
  
**        CHECK FOR FURTHER DIM-WORDS.
  
 KNS7     SA2    TP=NLST
          SA3    TP.NLST
          MX4    -1 
          IX7    X2+X4       SHRINK TABLE BY ONE WORD 
          SA1    X3 
          =X6    X3+1 
          ZR     X2,E.ZA     IF TABLE EXHAUSTED 
          BX2    0
          MX3    CHAR 
          SA7    A2 
          SA6    A3 
          BX0    X3*X1       ISOLATE UPPER CHARACTER
          NZ     X0,KNS4     IF NEW ITEM-NAME WORD
          NZ     X1,KNS6     IF NOT END-OF-GROUP WORD 
          RJ     STX
          EQ     KNS2        CONTINUE.. 
 LFS      SPACE  4,8
**        LFS    - LIST FINAL STATISTICS
* 
*         ENTRY  (X1) = MAX CORE REQUIRED BY THIS PROGRAM UNIT
*         EXIT TO LFSX
 LFS      BSS    0
          PIA 
          LX6    -2*CHAR
          SA6    LFS.MAX
  
 TEST     IFNE   TEST        NUMBER OF TABLE CRASHES IN *TEST* MODE 
          SA1    =XMOVES
          ZR     X1,LFS1     IF NO CRASHES
          RJ     CDD
          SA6    A1 
          PLINE  A1,3,1 
 LFS1     PIA    =XPARSLEN
          LX6    -2*CHAR
          SA6    A1 
          PLINE A1,4,1       OUTPUT LARGEST PARSED FILE LENGTH
 TEST     ENDIF 
  
          SA2    =XTIME1
          RJ     =XCPTIM     ELAPSED TIME FOR SUBPROGRAM
          SA6    LFS.TM 
          RJ     =XTIMER
          SA6    =XTIME1     RESET TIME 
          PLINE  LFSE,5,1 
          EQ     LFSX        EXIT 
  
  
 LFSE     BSS    0
 LFS.MAX  DIS    1,(MAXCORE)
          DIS    2, "SCM" STORAGE USED
 LFS.TM   DIS    1,(CPTIM)
          DIS    ,/ SECONDS/
 RAD      SPACE  4,20 
**        RAD -  RELOCATE AND DUMP *LONG FILE*. 
*         ENTRY  (X1) = ORIGIN OF PROGRAM TEXT
*         USES   ALL
*         CALLS  DTX, RIN, REL, STX.
  
 RADA     BSSZ   1           STORAGE FOR PACKED 15 BIT INSTRUCTIONS 
 RADB     BSS    1           STORAGE FOR READW INPUT
  
 RAD      SUBR               ENTRY/EXIT...
  
 SNAP=F   IFNE   TEST        DUMP LONG FILE 
          SA4    CO.SNAP
          LX4    1RF
          PL     X4,RADS     IF LONG FILE SNAP NOT SELECTED 
          DUMPT  (TT.LF)
 RADS     BSS    0
 SNAP=F   ENDIF 
  
          SA3    MOD
          SBIT   X3,PBLK
          SX7    3
          BX6    X1 
          SA6    ORG
          MI     X3,EXIT.    IF *BLOCKDATA* 
          SA7    PARCEL 
          RJ     DTX         INITIALIZE TABLE 
          MX6    -18
          SA6    RELMASK
  
*         READ NEXT INSTRUCTION FROM TT.LF. 
  
 RAD2     SA2    RADA 
          NZ     X2,RAD23    IF READING PACKED INSTRUCTION
          SA4    BINIO
          SA1    TT=LF
          NZ     X4,RAD21    IF TT.LF ON DISK 
          SA2    TT.LF
          MX3    -1 
          IX7    X1+X3       SHRINK LONG FILE BY ONE WORD 
          =X6    X2+1 
          SA5    X2 
          ZR     X1,EXIT.    IF TABLE EXHAUSTED 
          SA7    A1 
          SA6    A2 
          EQ     RAD22
  
 RAD21    READW  F.LF,RADB,1
          SA5    RADB        FETCH WORD READ
          ZR     X5,EXIT.    IF TABLE EXHAUSTED 
  
 RAD22    MX3    45          MASK OFF LOW ORDER 12 BITS 
          BX2    -X3*X5 
          BX7    X3+X2
          NZ     X7,RAD24    IF NOT PACKED INSTRUCTION
          BX2    X3*X5
  
 RAD23    MX3    15 
          BX5    X3*X2       ISOLATE TOP INSTRUCTION
          BX7    -X3*X2      REMOVE FROM PACKAGE
          LX7    15          REPOSITION 
          SA7    RADA        STORE PACKAGE REMNANTS 
  
 RAD24    MX1    L.LI12 
          SA2    PARCEL 
          BX3    X1*X5       ISOLATE *GHIJ* 
          MX6    -2          X6 = -3
          SB2    X2-2 
          LX3    L.LGH
  
 .76      IFEQ   .CPU,76
  
          BX4    X3 
          LX4    3           X4 = GHI 
          SB5    X4-014B
          MI     B5,RAD25    IF GHI LESS THAN *014* 
          SB5    X4-016B
          PL     B5,RAD25    IF GHI GREATER THAN *015*
  
*         HERE IF R/W LCM 
  
          SA4    X4+=XPIK=LCM-014B X4 = INST SKELETON 
          EQ     RAD27
  
 RAD25    BSS    0
  
 .76      ENDIF 
  
          SA4    X3+PIK=PS   X4 = INST SKELETON 
 RAD27    LX3    L.LI12-L.LGH+1    X3 = (GHIJ)*2
          AX4    60 
          AX0    X3,B1       X0 = (GHIJ)
          IX3    X3+X6
          BX7    X4*X3       X7 = + LONG, 0 SHORT, - CALL 
          PX3    X7 
          NX7    X3 
          UX3    X7 
          SX0    X0-100B
          AX3    47          X3 = +1    ,   0    ,    -1
          BX7    -X3            = -1    ,  -0    ,    +1
          IX3    X7-X6          = +2    ,  +3    ,    +4
          BX0    X4*X0       X0 = + LONG, 0 SHORT, - ALL PSEUDOS
          BX4    -X6*X3      X4 = +2    ,  +3    ,    +0
          SB3    X4+B2
          GT     B3,B0,RAD3  IF ENOUGH ROOM FOR INST
  
**        BEGIN NEW WORD -- PAD OUT (BINWORD) WITH (PARCEL) NO-OPS
  
          SA3    =460006100046000B
          MX7    L.LI15 
          SX2    -B2         = 2 - (PARCEL) 
          SA1    BINWORD
          LX2    4           = 32 - 16*P
          SB7    X2+B2       = 32-16P+P-2 = 30 - 15(P)
          AX7    B7 
          SA2    A1+B1
          BX3    -X7*X3      GET PROPER NUMBER OF NO-OPS
          IX1    X1+X3
          RJ     STX         STORE THE WORD INTO CURRENT TEXT TABLE 
          SA2    PARCEL 
  
 RAD3     SB2    X2 
          ZR     X0,RAD4     IF SHORT INSTRUCTION 
          PL     X0,RAD5     IF LONG BUT NOT PSEUDO 
          SB4    X0+100B
  
          JP     B4+*+1 
  
          LOC    0
  
          MX1    -L.LTAG     BSS
          AX5    -P.LTAG
          EQ     RAD35
  
          SX2    0100B-I.CALL      CALL (RJ WITH TRACE) 
          EQ     RAD34
  
          SX2    0100B-I.RJ        RETURN JUMP (NO TRACE) 
          EQ     RAD32
  
          MX1    -L.LI             JP INST
          BX4    -X1*X5 
          EQ     RAD37
  
          SX2    0400B-I.EQ        UNCONDITIONAL *EQ* JUMP
*         EQ     RAD32
  
          LOC    *O 
  
 RAD32    LX2    P.LI12 
          IX5    X5+X2       CHANGE PSEUDO TO NORMAL
          RJ     REL
          SA2    BINREL 
          SA1    BINWORD
          NE     B4,B1,RAD33       IF NOT *CALL*
          SX2    X2+2        INDICATE LOWER PGM REL 
          SA4    SAVETR      LINE NUM FOR TRACEBACK 
          BX1    X1+X4       ADD LINE NUM. BACK IN FOR TRACEBACK
 RAD33    RJ     STX         STORE IN *TEXT* TABLE
          EQ     RAD2 
  
 RAD34    MX1    L.TRC
          LX1    P.TRC+L.TRC
          BX6    X1*X5       SAVE LINE NUM. FOR TRACEBACK 
          BX5    -X1*X5      REMOVE LINE NUM. FROM BINWORD
          SA6    SAVETR      SAVE LINE NUM FOR TRACEBACK
          EQ     RAD32
  
**        BSS 
  
 RAD35    SA3    ORG
          BX1    -X1*X5      ISOLATE NUMBER OF WORDS TO BE RESERVED 
          IX6    X1+X3
          SA6    A3          INCREMENT ORIGIN 
          EQ     RAD2 
  
**        JP
  
 RAD37    LX4    L.LI        POSITION THE *B-BOX* 
          BX5    X1*X5
          SX2    X4+0200B-I.JP
          EQ     RAD32
  
**        MERGE 15-BIT INST INTO (BINWORD)
  
 RAD4     SX7    B2-B1
          SX1    B2 
          SA7    A2 
          SA2    BINWORD
          LX1    4
          SB7    X1+15
          SB3    B7-B2
          MX0    15 
          BX5    X0*X5       CLEAR REST OF WORD 
          LX5    B3 
          BX6    X2+X5
          SA6    A2 
          EQ     RAD2 
  
**        GET RELOCATION FOR 30-BIT INST. 
  
 RAD5     SX7    B2-2 
          SA7    A2          ADVANCE PARCEL COUNT 
  
***       CHECK FOR OBJECT TIME REPRIEVE INSTRUCTIONS *6102---*.
*         MUST PUT COMPLIMENT OF LENGTH OF PROGRAM UNIT IN 1ST *6102---*
*         FOR OTR.
*         (X5) = INSTRUCTION IN LONG FILE FORMAT
  
          SA1    CO.ER
          ZR     X1,RAD6     ER=0 
          MX1    L.LI12 
          BX3    X1*X5
          SA4    =6102BS48
          BX3    X4-X3
          NZ     X3,RAD6     IF NOT A *6102* INSTR
          MX3    L.TAG
          LX3    48 
          BX2    X5*X3
          LX2    L.LI12 
          PL     X2,RAD6     IF TAG FIELD OF  *6102*  IS POSITIVE 
          SA3    OTRSAV 
          MX0    -L.TAG 
          BX3    -X0-X3 
          LX3    30 
          IX5    X4+X3       COMPLEMENT LENGTH OF ROUTINE TO TAG FIELD
 RAD6     RJ     REL
          EQ     RAD2 
  
 SAVETR   BSSZ   1           SAVE TRACEBACK LINE NUM DURING RELOCATION
 OTRSAV   BSSZ   1
 REL      SPACE  4,20 
**        REL -  RELOCATE 30-BIT INSTRUCTION. 
* 
*         ENTRY  (X5) = INSTRUCTION IN LONG FILE FORM.
*                            (PSEUDOS WILL NOT BE CHANGED.) 
*                (B2) = PARCEL TO RECEIVE THIS INSTRUCTION. 
*                            3 _ UPPER
*                            2 _ MIDDLE 
*                            1 _ LOWER
*                            0 _ ** SYSERR ** 
*                (ORG) = OBJECT ADDRESS OF THIS INST. 
*                (RELMASK) = COMPLEMENT MASK OF BIAS FIELD SIZE.
*                            (-18 FOR INSTRUCTIONS.)
*                            (-24 FOR AP-LISTS.)
* 
*         EXIT   INSTRUCTION AND RELOCATION HAVE BEEN OR-ED INTO BINWORD
*                            AND BINREL.
*                *LINK* AND *FILL* TABLE ENTRIES MADE AS NECESSARY. 
* 
*         USES   A1-A3,A6,A7  B3,B7  X0,X4,X5 
*         CALLS  ADW. 
  
  
 REL      SUBR               ENTRY/EXIT...
          MX2    -L.LI12
          AX5    P.LBIAS
          MX3    -L.LBIAS 
          BX3    -X3*X5      ISOLATE OFFSET 
          AX5    -P.LBIAS+P.LTAG
          SX6    X5          X6 = TAG 
          BX0    X5          KEEP TAG FOR LATER ECS/LCM CHECK 
          LX2    -P.LTAG+P.LI12 
          BX7    0           INDICATE NO RELOCATION 
          SX4    B0          INDICATE NO SPECIAL RELOCATION 
          BX2    -X2*X5      X2 = 30/0, 12/GHIJ, 18/0 
          MI     X6,REL9     IF NEGATIVE TAG FIELD
          MX5    L.PWF
          LX6    -L.PWF 
          SB7    X6-C.BASE/1S13 
          BX6    X5*X6       ISOLATE ORDINAL
          LX6    L.PWF       RIGHT JUSTIFY
          MI     B7,REL8     IF NO TAG PRESENT
          =X7    2           NOMINAL RELOCATION 
          SB3    B2-B1
          LX7    B3 
          JP     B7+*+1 
  
          LOC    0
  
          SA1    TA.NAM      20    VARIABLE 
          EQ     REL5 
  
          SA1    TA.NAM      22    VARIABLE 
          EQ     REL5 
  
          SA1    TS.STN      24    STATEMENT
          EQ     REL4A
  
          SA1    TA.PRO      26    PROGRAM
          EQ     REL4 
  
          SA1    TEM.MAX     30    VAR-DIM
          EQ     REL3A
  
          SA1    BA.TEM      32    TEM/IND
          EQ     REL3 
  
          SA1    BA.CON      34    CONSTANT 
          EQ     REL3 
  
          LOC    *O 
  
  
 REL3A    SB7    X1-C.TEM 
          SX6    X6+B7
          SA1    BA.TEM 
*         EQ     REL3        CONTINUE..  (ALMOST) 
  
  
 REL3     IX6    X6+X1       CONSTANTS, TEMPS, AP-LISTS 
          SX6    X6 
          EQ     REL8 
  
  
 REL4A    SB7    X6          STATEMENT LABELS 
          SA1    X1+B7
          AX1    P.SNAD 
          SX6    X1 
          EQ     REL8 
  
 REL4     SB7    X6          STATEMENT LABELS + PROGRAM TAGS
          SA1    X1+B7       FETCH TABLE ENTRY
          SX6    X1 
          PL     X1,REL8     IF CODE-RELATIVE 
          SA1    BA.APL 
          IX6    X1+X6
          EQ     REL8 
  
  
**        RELOCATE A NAME TAG.
*         FIND ADDRESS AND BLOCK NUMBER IN TA.NAM(ORD)
*         NEGATIVE ADDRESS INDICATES AN EXTERNAL, AND NON-ZERO BLOCK NUM
*                MEANS COMMON.  FOR THOSE, PREPARE (X4) FOR ADDING TO 
*                FILL/LINK TABLE. 
  
 REL5     AX6    1
          SB7    X6 
          SA1    X1+B7       FETCH ADDRESS TABLE ENTRY
          MX4    -L.BLOCK+1 
          SX6    X1          ISOLATE (BLOCK-RELATIVE) VALUE 
          AX1    P.BLOCK+1
          BX4    -X4*X1      ISOLATE BLOCK NR 
          ZR     X4,REL55    IF THE NOMINAL BLOCK 
          BX7    0
          SX4    X4+2 
 REL55    PL     X6,REL8     IF NO EXTERNAL 
          SB3    TT.FILL
          SB3    -B3
          SX1    B3+TT.LINK 
          SX4    B7+B7
          LX1    P.BTRL 
          SX6    B0 
          BX4    X1+X4       INDICATE EXT, VICE COMM
          SX7    B0 
*         EQ     REL8 
  
  
**        COMPUTE FINAL ADDRESS FIELD  =  [NEG] * ADDR + OFFSET 
*         ENTRY  (X3) = OFFSET. 
*                (X2) = *GHIJ*S18  (= INST SHIFTED LEFT BY 18)
*                (X4) = SPECIAL RELOCATION FLAG  --  42/WHICH, 18/ORD 
*                            = 0 _ NO SPECIAL ACTION. 
*                            " 0 _ COMMON OR EXTERNAL RELOCATABLE.
*                            (ORD = BLOCK NUMBER OR TAG ORDINAL)
*                            (WHICH = WHICH TABLE TO ENTER.)
*                (X6) = PARTIAL ADDRESS 
*                (X7) = RELOCATION ALREADY COMPUTED.
  
 REL8     LX3    -L.LBIAS    SIGN EXTEND THE BIAS 
          SA1    BINWORD
          AX3    -L.LBIAS 
          IX6    X3+X6       (X6) = FINAL ADDRESS 
          SA3    RELMASK
          =X5    B2-1 
          BX6    -X3*X6      TRIM BIAS TO FIT IN RESULT FIELD SIZE
          LX5    4           = 16*( (PARCEL) - 1 )
          SX3    B2-B1
          BX6    X6+X2
          SA2    A1+B1
          IX3    X5-X3
          SB3    X3          = 15*( (PARCEL) - 1 )
          LX6    X6,B3       POSITION FINAL INSTRUCTION HALF-WORD 
          BX6    X1+X6       OR INST INTO BINWORD 
          IX7    X7+X2       MERGE RELOC INTO BINREL
          SA6    A1 
          SA7    A2 
          ZR     X4,EXIT.    IF NO SPECIAL RELOCATION 
  
**        MAKE LINK/FILL TABLE ENTRY -- 
  
          BX6    X5 
          BX5    X0 
          LX5    P.2TAG      TAG FOR *CLT*
          RJ     =XCLT       CHECK FOR LCM/ECS TAG
          NZ     X3,REL85    IF NOT LCM OR ECS TAG
  
*         MAKE *XFILL* TABLE ENTRY -- 
  
          SX2    X4          ISOLATE BLOCK ORDINAL
          SA1    ORG
          SX7    B3          LOW-ORDER BIT POSITION OF ADDRESS FIELD
          LX1    6
          BX6    X1+X7
          LX6    6
  
*         WHEN DIRECT MODE (LCM=D) IS IMPLEMENTED, A TEST MUST GO IN
*         TO DETECT WHICH MODE IS IN EFFECT.  DIRECT MODE WILL MEAN 
*         ADDRESS FIELDS TO BE RELOCATED ARE 18 BITS.  FOR NOW ALL
*         LCM/ECS REFERENCES ARE TO POINTER WORDS, SO THE SIZE VALUE
*         IS 21 BITS. 
  
          SX7    21 
          BX6    X6+X7
          LX6    9
          BX6    X6+X2
          LX6    9
          SX7    B1 
          BX6    X6+X7       = 30/(ORG), 6/0, 6/21, 9/ORD, 9/1
          ADDWD  =XTT.XFIL
          EQ     EXIT.
  
 REL85    BX5    X6          RESTORE X5 
          SX2    X4          ISOLATE BLOCK/EXTERNAL ORDINAL 
          SA1    ORG
          AX4    P.BTRL 
          LX5    L.BTRL-4 
          SX5    X5+1S11+1   X5 = 1/1, 2/(PARCEL)-1, 9/1
          LX5    P.BTRL 
          LX2    30 
          BX6    X5+X1
          IX6    X2+X6       = 30/ORD, 12/(X5), 18/(ORG)
          ADDWD  X4+TT.FILL 
  
 SNAP=K   IFNE   TEST        DUMP *LINK* TABLE
          SA3    CO.SNAP
          LX3    1RK
          PL     X3,REL8S    IF LINK TABLE SNAP NOT SELECTED
          DUMPT  (TT.LINK)
 REL8S    BSS    0
 SNAP=K   ENDIF 
  
          EQ     EXIT.
  
  
**        HANDLE NEGATIVE TAG FIELDS HERE.
*                THIS ANACHRONISM SHOULD NOT BE PERMITTED TO EXIST, 
*                EXCEPT THAT IT MIGHT BE DIFFICULT FOR OTHER PARTS OF 
*                THE COMPILER TO LEARN HOW TO PUT ALL NUMBERS INTO THE
*                BIAS FIELDS. 
  
 REL9     LX6    -L.TAG      SIGN EXTEND
          AX6    -L.TAG 
          EQ     REL8        CONTINUE AS FOR NORMAL BIAS
  
 RELMASK  BSS    1           COMPLEMENT MASK OF BIAS FIELD SIZE 
 STX      SPACE  4,15 
**        STX -  STORE *TEXT* TABLE ENTRY.
*         ENTRY  (X1) = WORD TO BE OUTPUT 
*                (X2) = RELOCATION BYTE FOR THAT WORD 
*         EXIT   TABLE UPDATED AND FLUSHED AS NECESSARY.
*                (ORG) INCREMENTED. 
*                (PARCEL) INDICATES EMPTY.
*                (BINWORD) = (BINREL) = 0 
*         USES   A1,A2,A3,A4,A6,A7  B3,B4,B5,B6,B7
*         CALLS  DTX. 
  
  
 STX      SUBR               ENTRY/EXIT...
          SA3    BT.TXWC
          BX6    X1 
          SA1    BT.TXRB
          SX7    3
          SA6    X3+BT.TEXT+2 
          SX6    X3+B1
          LX1    L.BTRB 
          SA6    A3          UPDATE WORD COUNT
          SA7    PARCEL      INDICATE EMPTY WORD
          BX7    X2+X1
          SA2    ORG
          SX3    X6-15
          BX6    0
          SA7    A1 
          SA6    BINWORD
          =X7    1
          IX7    X2+X7       INCREMENT ORIGIN COUNTER 
          SA6    A6+B1
          SA7    A2 
          MI     X3,EXIT.    IF NOT FULL TABLE
  
          RJ     DTX         FLUSH TEXT TABLE 
          EQ     EXIT.
 WLF      SPACE  4,20 
**        WLF -  WRITE *LGO* FILE.
* 
*                ALL BINARY OUTPUT MUST BE DONE THRU THIS ROUTINE.
*         PLEASE USE THE MACRO FORM, *WLGO*, TO INSURE CORRECT CALLING
*         SEQUENCE.  HANDLES COMPILE-TO-CORE AND OVERFLOW TO ECS. 
* 
*         ENTRY  (B6) = FWA DATA
*                (B7) = WORD COUNT
*         USES   A1-A4,A6,A7  B2,B3,B5-B7 
*         CALLS  FA=WTW.
  
  
 .CMLOD   IFNE   .CMLOD 
 .LCM     IFNE   .LCM 
 WLF6     SHRINK TX=LGO      JUST OVERFLOWED, LCM TO DISK 
 .LCM     ENDIF 
  
 WLF7     SB7    B5          JUST OVERFLOWED, SCM TO DISK 
          SHRINK T=LGO
 .CMLOD   ENDIF 
  
 WLF8     SX6    B4          SAVE (B4)
          SA6    =XGT1
          WRITEW F.LGO,B6,B7 WRITE IT OUT WHEN ON DISK
          SA1    =XGT1
          SB4    X1          RESTORE (B4) 
  
 WLF      SUBR               ENTRY/EXIT...
  
 .CMLOD   IFEQ   .CMLOD      COMPILE-TO-CORE
          EQ     WLF8 
 .CMLOD   ELSE
          SA1    LGOIO
          MI     X1,WLF8     IF *LGO* ON DISK 
          SB5    B7 
          IFNE   .LCM,,1
          NZ     X1,WLF4     IF *LGO* IN LCM
          ALLOC  T.LGO,B7 
          SA1    LGOIO
          MI     X1,WLF7     IF JUST OVERFLOWED TO DISK 
          IFNE   .LCM,,1
          NZ     X1,WLF4     IF JUST OVERFLOWED TO LCM
          MOVE   B6,B7-B5,B5
          EQ     EXIT.
  
 .LCM     IFNE   .LCM        TRY TO MOVE IT TO LCM
 WLF4     ALLOX  TX.LGO,B7   ALLOCATE THE ECS TABLE 
          SA1    LGOIO
          MI     X1,WLF6     IF JUST OVERFLOWED TO DISK 
          WLCM   B6,B5       WRITE IT TO LCM
          EQ     EXIT.
 .LCM     ENDIF 
  
 .CMLOD   ENDIF 
          POPMAC WLGO 
 ENTRY    SPACE  4,8
          LIST   D
          END 
