*DECK     FAS - FORTRAN INTERNAL ASSEMBLER. 
          IDENT  FAS
 FAS      SECT   (FORTRAN INTERNAL ASSEMBLER.)
 FAS      SPACE  4,10 
  
  
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN FSNAP
          EXT    DMT=,FI=BRLI 
  
*         IN FTN
          EXT    CO.ARGC,CO.DBPM,CO.OPT,CO.PW,CO.SNAP,CP.MODL,FV.LGO
          EXT    F.LGO,F.PB,GT1,TL.DATE,TL.PTYP,TL.TIME 
          EXT    CO.ARGF
  
*         IN IDP
          EXT    IDP= 
  
*         IN LIST 
          EXT    PIK,VFD
  
*         IN PUC
          EXT    BINIO,BN=APL,BN=SUB,BN=SUB0,CBI,ERRORS,F.LBT,IDENT 
          EXT    LINEBUF,LINES,MOD,NREXT,N.TABLE,PIA,PIK=PS,SAVE,SUM.LBT
          EXT    S=BU,S=LENP,S=ENTRY,S=RD,S=SA1,S=VD,T=APL,T=BLKS,T=CLW 
          EXT    T=DIM,T=DATS,T=ENT,T=FILL,T=IOA,T=LA,T=LCA,T=LCC,T=LGOB
          EXT    T=LINK,T=LNT,T=NLST,T=PTXT,T=PTXTR,T=SCR,T=SYM 
          EXT    T=XFIL,T.API,T.APL,T.BLKS,T.CAC,T.CLW,T.CON,T.DATS 
          EXT    T.DIM,T.ENT,T.FILL,T.FMT,T.FPI,T.FPO,T.GL,T.IOA,T.IOI
          EXT    T.LA,T.LCA,T.LCC,T.LGOB,T.LINK,T.LNT,T.NLST,T.PTXT 
          EXT    T.PTXTR,T.SCR,T.SUB,T.SUB0,T.SYM,T.XFIL,USAVE,WO.LOO 
          EXT    WO.56,WO.57,T.CLWB,T=CLWB
          EXT    LEVEL2 
  
*         IN REC
          EXT    ADA
  
*         IN RLINK
          EXT    CII,PAT
  
*         IN UTILITY
          EXT    CIO=,DXB,MVE=,RDW=,SFN,SST,WOD,WTW=
 FAS      SPACE  4,10 
**        PASS *THREE* -- ASSEMBLE THE OBJECT CODE. 
* 
*         *FAS*  CONTROLLING ROUTINE FOR FORTRAN INTERNAL ASSEMBLER.
* 
* 
*         ********** PSEUDO INSTRUCTION PROCESSORS *********
* 
* 
*         *DDS*  DUMP DATA STATEMENTS -- READS THE TRANSLATED *DATA*
*                STATEMENTS FROM *T.DATS* AND PRODUCES CORRESPONDING
*                BINARY TABLES FOR THE LOADER.
* 
*         *DFT*  DUMP FILE TABLES.  DUMPS FIT + FET (S).
* 
*         *DIT*  DUMP IDENTIFICATION TABLES.  DUMPS IDNT, LDSET, PIDL,
*                ENTR TABLES AND TRACEBACK WORDS. 
* 
*         *DLC*  DUMP *LDSET COMMON* DIRECTIVES FOR COMMON AND LOCAL
*                BLOCKS DECLARED TO BE SAVED. 
* 
*         *KAP*  TRANSLATES THE AP-LISTS GENERATED IN *T.APL* INTO
*                THE BINARY OUTPUT. 
* 
*         *KIO*  TRANSLATE THE I/O AP-LIST GENERATED IN *T.IOA* 
*                INTO THE BINARY OUTPUT.
*         *KNS*  READS THE TRANSLATED *NAMELIST* GROUP DEFINITIONS FROM 
*                *T.NLST* AND PRODUCES APPROPRIATE BINARY.
* 
*         *KON*  PROCESS THE SAVED CONSTANTS (T.CON) INTO THE BINARY. 
* 
*         *RAD*  READS PSEUDO OBJECT CODE FROM *T.PB* (OR THE OVERFLOW
*                FILE), FILLING IN ACTUAL ADDRESSES AND RELOCATION BASES
*                AND WRITING BINARY.  ALSO WRITES OBJECT LISTING VIA A
*                CALL TO  *PIK*  (IN  *LIST*  ) IF REQUIRED.
* 
* 
*          ********** SUPPORTING ROUTINES **********
* 
* 
*         *BNW*  STORES CURRENT TEXT WORD INTO TEXT TABLE AND BEGINS
*                A NEW WORD.
* 
*         *BST*  BUILD  *SUB*  OBJECT TABLE.
* 
*         *BSZ*  BUILD *SUB0* OBJECT TABLE. 
* 
*         *DFD*  DUMPS STATEMENT/LINE NUMBER (5700) AND LOADER SYMBOL 
*                (5600) TABLES TO BINARY. 
* 
*         *DLC*  DUMP *LDSET,COMMON* DIRECTIVES FOR SAVE
* 
*         *DLF*  FLUSHES THE LINK AND FILL TABLES ACCUMLATED BY THE 
*                OTHER PROCESSORS.
* 
*         *DTX*  FLUSHES THE *TEXT* TABLE BEING CONSTRUCTED, AND RESETS 
*                THE ORIGIN COUNTER APPROPRIATELY.
* 
*         *FST*  FORMAT LOADER SYMBOL TABLE FOR CID/ PMDMP IN A SCRATCH 
*                TABLE. 
* 
*         *OCL*  TRANSLATES ENTRIES OF T.CLW (TABLE OF CHARACTER LENGTH 
*                WORDS) INTO BINARY FORM DEFINED AS LO. . 
* 
*         *ORD*  OUTPUT RUN-TIME DIMENSION TABLE TO BINARY. 
* 
*         *OTB*  OUTPUT A TABLE TO BINARY FILE. 
* 
*         *OSB*  OUTPUT *SUB* /*SUB0* BLOCK TO BINARY FILE. 
* 
*         *PAW*  PREPARE I/O AP-LIST WORD FOR NAMELIST MEMBERS. 
* 
*         *PIT*  WRITE IDNT(77) TABLE TO BINARY FILE. 
* 
*         *POL*  TRANSFER CONTROL TO APPROPRIATE LISTING ROUTINE
*                IN DECK *LIST* IF LISTING OPTION IS ON.
* 
*         *PUSE* SUBROUTINE TO PROCESS   USE  PSEUDO.  SWITCHES ORG 
*                AND PARCEL COUNTERS AS DICTATED BY  USE  PSEUDO
*                INSTRUCTION.  CALLED BY PSEUDO INSTRUCTION PROCESSOR 
*                PP=USE.
* 
*         *RBS*  RELOCATE   BSS  INSTRUCTIONS.
* 
*         *REL*  CALLED BY OTHER ROUTINES TO DETERMINE VALUE AND
*                RELOCATION OF TAGS.
* 
*         *RNI*  READS ONE WORD FROM THE PRE-BINARY FILE (T.PB OR F.PB).
* 
*         *SMW*  STORES MULTIPLE WORDS INTO BINARY TEXT, WITHOUT
*                RELOCATION.
* 
*         *STI*  FOR A BLOCK DATA SUBPROGRAM, SKIP PB INSTRUCTIONS
*                UNTIL AN I.EMI INSTRUCTION IS REACHED. 
* 
*         *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*). 
          SPACE  4,10 
          TITLE  MACROS AND DEFINITIONS.
 WLGO     SPACE  4,10 
**        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
 MDL      SPACE  4,30 
 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"/   73747576
 TARGET  MICRO  2*".TMP"-5,2,/6466C576/ 
 VALID   MICRO  2*".TMP"-5,2,/646XCX7X/ 
          SPACE  4,30 
          TITLE  BINARY OUTPUT TABLE DEFINITIONS. 
**        BT.--- BINARY OUTPUT TABLE DEFINITIONS. 
  
  
 BT=PIDL  EQU    3400B       PROGRAM/BLOCK TABLE
 BT=PTEXT EQU    3500B       PARTIAL WORD TEXT TABLE
 BT=ENTR  EQU    3600B       ENTRY POINT TABLE
 BT=XTEXT EQU    3700B
 BT=XFILL EQU    4100B       EXTENDED FILL OR *XFILL* TABLE 
 BT=FILL  EQU    4200B       COMMON *FILL* TABLE
 BT=XREPL EQU    4700B
 BT=LINK  EQU    4400B       EXTERNAL *LINK* TABLE
 BT=XFER  EQU    4600B       TRANSFER ADDRESS TABLE 
 BT=LSYM  EQU    5600B       LOADER SYMBOL TABLE
 BT=LSTN  EQU    5700B       LOADER STMT AND LINE NUMBER TABLE
 BT=LDSET EQU    7000B       *LDSET* OBJECT DIRECTIVE 
 BT=LIB   EQU    10B         *LIB* SUB-DIRECTIVE
 BT=CMN   EQU    32B         *COMMON* SUB-DIRECTIVE 
 BT=MAP   EQU    11B         *MAP* SUB-DIRECTIVE
 BT=PREST EQU    12B         *PRESET* SUB-DIRECTIVE 
 BT=IDNT  EQU    7700B       IDENT (PREFIX) TABLE 
 BT=MXWC  EQU    7777B       MAXIMUM WORD COUNT PER TABLE OUTPUT TO LGO 
  
  
**        HEADER WORD DEFINITIONS. (BT.)
  
  
          DESCRIBE  BT.,60
 CN       DEFINE 12          CODE NUMBER
 WC       DEFINE 12          WORD COUNT 
 PMDT     DEFINE 1           =1 IF CREATE ZZZZZDT FILE FOR PMDMP
          DEFINE 8
 RL       DEFINE 9
 TYP      DEFINE 1           BLOCK TYPE  (PIDL DESCRIPTIONS)
          DEFINE 17 
  
*         DEFINE XTEXT HEADER WORD
  
          REDEF 
 CN       DEFINE 12          CODE NUMBER
 WC       DEFINE 12          WORD COUNT 
 PMDT     DEFINE 1           =1 IF CREATE ZZZZZDT FILE FOR PMDMP
          DEFINE 2
 RLX      DEFINE 9
          DEFINE 24 
  
*         DEFINE PARTIAL WORD TEXT TABLE FORMAT (BT.PTEXT). 
  
          REDEF 
 LEN      DEFINE 18 
 BCP      DEFINE 6
 RP       DEFINE 1           REPLICATION INDICATOR
          DEFINE 2
 RB       DEFINE 9           RELOCATION BASE
 FWA      DEFINE 24 
  
 RIP      DEFINE 24,47       REPLICATION INCREMENT FOR PTEXT
 RCP      DEFINE 24,23       REPLICATION COUNT FOR PTEXT
  
*         DEFINE REPLICATION TABLE FORMAT (BT.XREP) 
  
          REDEF 
 C        DEFINE 15          NO. OF TIMES BLOCK COPIED
 B        DEFINE 12          BLOCK SIZE 
 K        DEQU   B,18        DESTINATION ADDRESS INCREMENT
 RS       DEFINE 9           RELOCATION BASE
 AS       DEFINE 24          RELATIVE ADDRESS 
 BT.LSYM  SPACE  4,10 
*         LOADER SYMBOL TABLE HEADER TEMPLATE.
  
*         DEFINE  HEADER WORD (BT.) . 
  
          REDEF 
 CN       DEFINE 12          CODE NUMBER
 WC       DEFINE 12          WORD COUNT 
          DEFINE 2
 LO       DEFINE 10          LANGUAGE ORDINAL, =4 FOR FTN5
 LTB      DEFINE 1           =1 IF LAST SYMBOL TABLE
 DST      DEFINE 1           =1 IF THIS IS A DIMENSION DESCRIPTOR 
 TY       DEFINE 2           PROGRAM TYPE 
          DEFINE 2
 SA1      DEFINE 18          RELATIVE ADDRESS OF WORD TO SAVE REG. A1 
  
 L.BTRB   EQU    4           WIDTH OF A RELOCATION BYTE 
 L.77     EQU    16B
          SPACE  4,10 
**        BT.IDNT - IDNT (PREFIX) TABLE DIRECTIVE 
  
 BT.IDNT  BSSENT 0           PREFIX TABLE LAYOUT
  
          LOC    0
  
          VFD    BT.CNL/BT=IDNT,BT.WCL/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  CONENT 1H          PROG-UNIT TYPE 
*                                           ---  OPTIONS  --- 
 BT.IDN9  CONENT 1H          DBUG TRACE 
 BT.IDNTA DIS    1,                               ROUND SYS 
          DIS    1, 
 BT.IDNTB DIS    1,                               ARG 
 BT.IDNTU BSSZ   L.77-*+1                        USER COMMENT 
  
          LOC    *O 
 BT.DBMP  SPACE  4,10 
**        BT.DBMP - *LDSET PRESET* AND *LDSET MAP* LOADER SUB-DIRECTIVES
*         REQUIRED BY PMDMP.
  
 BT.DBPM  BSS 
          VFD    BT.CNL/BT=PREST,BT.WCL/1,18/0,18/1 
          VFD    60/60000000000433400000B 
          VFD    BT.CNL/BT=MAP,BT.WCL/1,17/0,18/3,1/1 
          DATA   7LZZZZZMP
 BT.DBPML EQU    *-BT.DBPM
          SPACE  4,10 
**        BT.LIB - *LDSET(LIB=FORTRAN)* LOADER OBJECT DIRECTIVE.
  
 BT.LIB   VFD    BT.CNL/BT=LIB,BT.WCL/BT.LIBL-1,*P/0
          DATA   L FTN5LIB
 BT.LIBL  EQU    *-BT.LIB 
          SPACE  4,10 
**        BT.ERR - THIS LINE IS ALL THE BINARY OUTPUT IF THERE WERE 
*                FATAL ERRORS.
  
 BT.ERR   LIT    28LERRORS IN COMPILATION.
 BT.XREP  SPACE  4,10 
**        BT.XREP - REPLICATION TABLES BUILT HERE.
  
 BT.XREP  VFD    BT.CNL/BT=XREPL,BT.WCL/2,*P/1
          VFD    27/0,9/1,24/**    SOURCE OF REPL 
          VFD    15/**,12/0,9/1,24/**    REPL COUNT, DESTINATION OF REPL
 BT.XREPL EQU    *-BT.XREP
  
 BT.PTEXT SPACE  4,10 
**        BT.PTEXT - PARTIAL WORD TEXT TABLE BUILT HERE.
  
 BT.PTEXT VFD    BT.CNL/BT=PTEXT,BT.WCL/**,*P/0 
          VFD    BT.LENL/**,BT.BCPL/**,BT.RPL/**,2/0,BT.RBL/**, 
          VFD    BT.FWAL/** 
          VFD    12/0,BT.RIPL/**,BT.RCPL/** 
          SPACE  4,10 
  
**        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 
 BT.TXTL  EQU    *-BT.TXRB   LENGTH OF WORKING BUFFER 
  
 BINWORD  DATA   0           PARTIAL BINARY OUTPUT WORD 
 BINREL   DATA   0           PARTIAL RELOCATION 
  
 BT.ENTR  VFD    BT.CNL/BT=ENTR,*P/0
 BT.XFER  VFD    BT.CNL/BT=XFER,BT.WCL/1,*P/0 
 BT.XFR1  BSSENT 1           ROUTINE NAME GOES HERE 
 BT.LSTN  SPACE  4,10 
*         STATEMENT LINE NUMBER TABLE HEADER TEMPLATE.
  
 BT=FTN5  EQU    4           LANGUAGE ORDINAL FOR FTN5
 BT=LSYML EQU    3           NO. OF WORDS PER (5600) TABLE ENTRY
          ERRNZ  Z=SYM-BT=LSYML 
  
 BT.LSTN  VFD    BT.CNL/BT=LSTN,BT.WCL/**,12/BT=FTN5,*P/0 
  
*         LOADER SYMBOL TABLE HEADER TEMPLATE.
  
 BT.LSYL  VFD    BT.CNL/BT=LSYM,BT.WCL/**,2/0,BT.LOL/BT=FTN5
          VFD    BT.LTBL/0,BT.DSTL/0,BT.TYL/0,2/0,BT.SA1L/**
 BT.LSYM  VFD    BT.CNL/BT=LSYM,BT.WCL/**,2/0,BT.LOL/BT=FTN5
          VFD    BT.LTBL/0,BT.DSTL/0,BT.TYL/0,2/0,BT.SA1L/**
 MODEV    SPACE  4,10 
          PURGMAC  MODEV
          MACRO  MODEV,ADDR,B,L,I,R,D,COMPLEX,CHAR,COMMA
          ENTRY  ADDR 
 ADDR     VFD    28/0,4/COMMA,4/CHAR,4/COMPLEX,4/D,4/R,4/I,4/L,4/B
          ENDM
  
 CIDMOD   MODEV  6,1,2,3,4,5,7,0   MODES FOR CID/PMD
  
 COMMOD   MODEV  1,4,1,0,2,3,5,0   MODES FOR COBOL (DAP S1518)
 LABMOD   CON    6           MODE FOR LABELS
  
 FCLMOD   MODEV  6,1,2,3,4,5,8,7   MODES FOR FCL
 ICDEF    SPACE  4,10 
**        ICDEF - MACRO TO DEFINE I/O CONTROL CODE PROCESSING TABLE.
  
  
          PURGMAC ICDEF 
  
          MACRO  ICDEF,ICN,NULL 
          JP     KIO=ICN
 -        VFD    30/0 
 ICDEF    ENDM
*CALL,COMSIOC 
 PSUD     SPACE  4,10 
**        PSUD,IPSUD - MACRO TO DEFINE PSEUDO INSTRUCTION JUMP TABLE. 
  
  
          PURGMAC PSUD,IPSUD
 PSUD     MACRO  PSN
          JP     FO=PSN 
-         VFD    12/0,18/=YLI=PSN 
 PSUD     ENDM
  
 IPSUD    MACRO  PSN
          JP     FI=PSN 
-         VFD    12/0,18/=YLI=PSN 
 IPSUD    ENDM
 FAPSUD   BSSENT 0           ENTRY FROM *LIST*
*CALL     COMSPSU            PSEUDO INSTRUCTION DEFINITIONS 
          LOC    Z.PSUD 
 OC=FLA   CON    =YLI=FLA 
          LOC    *O 
 CELLS    SPACE  4,10 
**        CELLS.
  
  
 BCI      BSSZ   1           .LT. 0 IF PROCESSING CCG TYPE INSTRUCTIONS 
 DELAY    BSSZ   1           12/2000B+FPNO, 48/ORGIN  (FOR *BST*) 
 ORG      CONENT 0           ORIGIN COUNTER 
 PARCEL   CONENT 0           PARCEL COUNTER, 3=EMPTY, -1=FULL 
 ORGSUB   CONENT 0           LISTING ORIGIN COUNTER FOR SUB BLOCK 
 SUBFLG   CONENT 0           .LT. 0 IF INHIBIT *SUB*
 ORGSUB0  CONENT 0           LISTING ORIGIN COUNTER FOR SUB0 BLOCK
 TAGSUB0  CONENT 0           LISTING TAG FOR *SUB0* 
 OL=BIN   BSSENT 1           BINARY WORD TO BE LISTED 
 OL=LBF   BSSENT 1           LABEL FIELD FWA          (PW .VS. NON-PW)
 OL=PB    BSSENT 1           (PB.) FORMAT INSTRUCTION TO BE LISTED
 OL=RL    BSSENT 1           RELOCATION INDICATOR FOR LISTING 
 SAVVD    BSS    1           SAVED WC.RA OF *VD.* 
 TEMP     BSS    4           TEMPORARIES
 RELSIZ   BSS    1
          TITLE  FAS - MAIN PRE-BINARY INSTRUCTION PROCESSOR. 
 FAS      SPACE  4,10 
**        FAS -  FORTRAN INTERNAL ASSEMBLER.
*         CONTROLLING ROUTINE.
*         CALLED BY AND EXITS TO  *REC*.
*         PROCESSES THE PRE-BINARY FILE (T.PB OR F.PB). 
* 
*         USES   ALL
* 
*         CALLS  DDS,DFT,DIT,GCL,PCT,PFT,RIP,RNI
  
  
 FAS      SUBR   =           ENTRY/EXIT 
  
  
*         INITIALIZE LINK AND FILL TABLES.
  
          BX6    0
          SA1    CO.ARGC
          NZ     X1,FAS1     IF ARG=COMMON
          SA6    COMMOD      [ALL]COMMOD = 0
          SA6    LABMOD 
  
 FAS1     SHRINK T=LINK,X6
          SHRINK T=FILL,X6
          SHRINK T=XFIL,X6
          SHRINK T=LNT,X6 
          SA2    NREXT
          ALLOC  T.LINK,X2   ALLOCATE BASIC LINK TABLE
          ALLOC  T.FILL,1    ALLOCATE BASIC FILL TABLE
          ALLOC  T.XFIL,1    ALLOCATE EXTENDED FILL TABLE 
          SA2    CO.OPT 
          ZR     X2,FAS5     IF OPT = 0, BUFFER IS STATIC 
  
*         INITIALIZE LGO BUFFER.
  
          SA2    FV.LGO 
          ZR     X2,FAS5     IF BINARY NOT REQUESTED
          SHRINK T=LGOB 
          IFEQ   CP#RM,0,2   IF CIO I/O 
          SA2    F.LGO+I.CBSET
          SKIP   1           SKIP 7RM CODE
          SA2    F.LGO+I.HBSET
  
          LX2    -18
          SX0    X2 
          ALLOC  T.LGOB,X0   GET ROOM FOR LGO BUFFER
  
          IFNE   CP#RM,0,1   IF NOT SCOPE 2 
          RECALL F.LGO
  
 FAS5     SA2    ERRORS 
          NZ     X2,END.ERR  IF FATAL ERRORS
  
*         CALCULATE COMPLEMENT OF (PROGRAM UNIT LENGTH) = -(SUM.LBT), 
*         AND SAVE IN  T.SYM(S=LENP) FOR OBJECT TIME REPRIEVE 
*         ...SPECIFICALLY USED DURING PROCESSING OF (SB0 B2 - LEN) INST.
  
          SA3    S=LENP      ORDINAL INTO LENP ENTRY IN T.SYM 
          SA1    SUM.LBT
          LX0    X3,B1
          IX3    X0+X3       = 3 * ORDINAL = INDEX INTO T.SYM 
          SA2    T.SYM
          IX2    X2+X3
          SA3    X2+WC.W
          MX0    -WC.RAL
          LX3    -WC.RAP
          BX4    X0*X3       CLEAR OLD (WC.RA)
          BX5    -X1         (X5) = COMPLEMENT OF (SUB.LBT) 
          BX3    -X0*X5      TRIM COMPLEMENT TO (WC.RA) WIDTH 
          BX7    X3+X4
          LX7    WC.RAP 
          SA7    A3          UPDATE (WC.) OF (S=LENP) 
  
*         INITIALIZE SOME CELLS.
  
          SA1    S=VD 
          SA2    T.SYM
          SA7    ORDA 
          =B2    X1+WC.W
          LX3    X1,B1
          SB2    B2+X3       STINDV = 3 * (S=VD)
          ERRNZ  3-Z=SYM
          SA1    X2+B2       WCV = T.SYM(STINDV) + WC.W 
          MX6    -WC.RAL
          LX1    -WC.RAP
          BX6    -X6*X1      RAV = RA[WCV]
          SA6    SAVVD       (SAVVD) = RAV
          SB4    BN=SUB0
          SB3    BN=SUB 
          SA1    F.LBT+B3 
          SA2    F.LBT+B4 
          MX0    -LB.ORGL 
          LX1    -LB.ORGP 
          LX2    -LB.ORGP 
          BX7    0
          SX6    3
          SA7    ORG         INITIALIZE  ORG = 0
          SA7    DELAY       INITIALIZE  DELAY = 0
          SA7    CBI         INITIALIZE  CBI = 0
          SA6    PARCEL      INITIALIZE  PARCEL = 3 
          BX6    -X0*X1 
          SA7    BINREL      INITIALIZE  BINREL = 0 
          SA7    BINWORD     INITIALIZE  BINWORD = 0
          BX7    -X0*X2 
          SA6    ORGSUB      (ORGSUB) = ORG[L.LBT(BN=SUB)]
          SA7    ORGSUB0     (ORGSUB0) = ORG[L.LBT(BN=SUB0)]
          RJ     DTX         INITIALIZE TEXT TABLE
          SA1    CO.PW
          SX1    X1-126 
          SX6    LINEBUF+4
          SA6    OL=LBF      (OL=LBF) -> LINEBUF+4
          PL     X1,FASRTN   IF NOT PW MODE 
          SX7    LINEBUF+1
          SA7    A6          (OL=LBF) -> LINEBUF+1
  
  
**        RETURN FROM PSEUDO INSTRUCTION PROCESSORS.
  
  
 FASRTN   BSS    0
          RJ     RNI         READ NEXT INSTRUCTION
          SA2    PARCEL 
          SB2    X2 
          MX0    PB.GHIJL 
          BX3    X0*X5       (X3) = GHIJ
          LX3    PB.GHIJL    48/0,12/GHIJ 
          SB4    X3 
          BX7    -X3
          SB3    B2-2 
          SA7    RADC        (RADC) = - GHIJ
  
          IFEQ   TEST,ON,2   IF TEST MODE 
          SB7    Z.PSUD 
          GE     B4,B7,"BLOWUP"    IF ILLEGAL PSEUDO NUMBER 
          JP     B4+OCPSUD   JUMP TO PSEUDO INSTRUCTION PROCESSOR 
 FO=XXX   SPACE  4,30 
**        THIS SECTION CONTAINS OC$ PSEUDO INSTRUCTION PROCESSORS.
*         THESE ROUTINES ARE INVOKED FROM ROUTINE  *FAS*  WHICH 
*         FINDS FROM THE PSEUDO INSTRUCTION JUMP TABLE AN ENTRY 
*         LABEL OF THE FORM    *  FO=XXX  *    , THEN JUMPS TO
*         IT. 
*         ENTRY  (X5) = INSTRUCTION 
*         EXIT   IS ALWAYS TO   *FASRTN*   .
 FO=ADDR  SPACE  4,10 
 FO=ADDR  LX5    -PB.BIASP
          SB4    X5          SAVE BIAS FIELD
          ERRNZ  PB.BIASL-18
          LX5    PB.BIASP 
          MX0    -PB.TAGL 
          LX0    PB.TAGP
          BX5    -X0*X5      CLEAR ALL BUT TAG
          =B2    1
          MX6    -18
          SA6    RELMASK
          SX6    PB.BIASP 
          SA6    RELPOS 
          RJ     REL
          SA1    BINWORD
          SX2    B4 
          LX2    18 
          SX1    X1          ISOLATE ADDRESS
          BX1    X1+X2
          SA2    BINREL 
          BX0    X1 
          RJ     STX
          RJ     FBP
          EQ     FASRTN 
 FO=APL   SPACE  4,10 
 FO=APL   BSS    0           PROCESS OC$APL PSEUDO
          =B6    0           INDICATE REGULAR AP-LIST 
          CALL   PAT         PRE-PROCESS AP-LIST TABLE
          SA2    T=LCA
          SA3    T=APL
          SX2    X2-1 
          BX6    X3 
          SA6    APLA        SAVE (APLA) = CURRENT LENGTH OF T.APL
          ZR     X2,APL.20   IF NO LCM POINTERS 
          ALLOC  T.APL,X2 
          SA5    APLA 
          SA4    T.APL
          SA1    T=LCA
          SA2    T.LCA
          SX1    X1-1 
          SX2    X2+B1
          IX3    X4+X5
          MOVE   X1,X2,X3    APPEND LCA TABLE TO APL
  
*         TRANSFORM LCA TABLE INTO AUXILIARY SYMBOL TABLE 
*         AS NEEDED TO PROCESS CODE, BY CONVERTING TO WORD C
*         FORMAT RELOCATION INFO POINTING TO LCM POINTERS IN
*         T.APL . 
  
          SA1    APLA 
          SA2    T.LCA
          SB5    X2+B1       I = 1
          SB6    BN=APL 
          SA2    F.LBT+B6 
          MX7    1
          MX0    -LB.ORGL 
          LX7    1+WC.RAP 
          LX2    -LB.ORGP 
          SA5    T=LCA
          BX3    -X0*X2 
          IX6    X1+X3
          SX5    X5-1 
          LX6    WC.RAP      RAT = ORG[LBT(BN=APL)] + T=APL - T=LCA-1 
 APL.15   ZR     X5,APL.20   IF T.LCA EXHAUSTED 
          SX5    X5-1 
          SA6    B5          RA[LCA(I)] = RAT 
          IX6    X6+X7       RAT = RAT+1
          =B5    B5+1        I = I + 1
          EQ     APL.15 
  
 APL.20   MX6    0
          SHRINK T=PTXTR,X6 
          RJ     KAP         COMPILE APLISTS (AND LCM POINTERS) 
          =B6    0           INDICATE REGULAR APLIST
          RJ     POL         PRINT OBJECT LISTING 
          SHRINK T=APL,0
          SHRINK T=PTXTR,X6 
          EQ     FASRTN 
  
 APLA     BSSENT 1           T=APL BEFORE T=LCA APPENDED
 FO=BMI   SPACE  4,10 
 FO=BMI   BSS    0           PROCESS OC$BMI PSEUDO
          RJ     RAD         PROCESS *TS* TYPE INSTRUCTIONS 
          EQ     FASRTN 
 FO=BSS   SPACE  4,10 
 FO=BSS   BSS    0           PROCESS OC$BSS PSEUDO FOR LABELS 
          RJ     RBS         RELOCATE   BSS   INSTRUCTION 
          EQ     FASRTN 
 FO=CON   SPACE  4,10         PROCESS OC$CON PSEUDO 
 FO=CON   BSS    0
          RJ     POL         PRINT CONSTANT TABLE 
          SA1    T.CON
          RJ     SMW         STORE MULTIPLE WORDS (T.CON) 
          EQ     FASRTN 
 FO=FEQU  SPACE  4,10 
 FO=EQUN  BSS    0           *EQUN* PSEUDO
          RJ     POL         PRINT *  LENP.  EQUN   * 
          EQ     FASRTN 
 FO=FMT   SPACE  4,10 
 FO=FMT   BSS    0           PROCESS OC$FMT PSEUDO
          RJ     POL         PRINT FORMAT TABLE 
          SA1    T.FMT
          RJ     SMW         STORE MULTIPLE WORDS (T.FMT) 
          SA3    CO.OPT 
          SA4    T=LA 
          NZ     X3,FASRTN   IF NOT QCG 
          SX6    -OC=FLA
          ZR     X4,FASRTN   IF NO LABELS ASSIGN-ED 
          SA6    RADC 
          RJ     FLA         FORMAT LABELS ASSIGN-ED
          EQ     FASRTN 
 FO=FVEC  SPACE  4,10 
 FO=FVEC  BSS    0
          SA2    T.SYM
          MX0    -PB.TAGL 
          LX5    -PB.TAGP 
          BX0    -X0*X5      TAGI = TAG[INSTRUCTION]
          ZR     X0,FVEC.10 
          IX2    X2+X0
          =A1    X2-WB.W+WC.W      *WC* 
          =A4    A1-WC.W+WA.W      *WA* 
          MX0    WA.SYML
          BX0    X0*X4       ISOLATE LFN
          MX4    1
          BX0    X0-X4       TURN OFF BIT 59
 FVEC.10  LX5    PB.TAGP-PB.BIASP 
          MX3    -PB.BIASL
          BX3    -X3*X5 
          ERRNZ  PB.BIASL-18
          BX1    X0+X3       MERGE LFN AND BUFL (OR MRL, OR PLIM) 
  
 FVEC.20  =X2    0
          BX0    X1 
          RJ     STX         OUTPUT POINTER WORD
          RJ     FBP         PRINT FILE DESCRIPTOR
          EQ     FASRTN 
  
 FO=PLIM  SA1    =XCO.LL     PRINT LIMIT
          EQ     FVEC.20
 FO=IDNT  SPACE  4,10 
 FO=IDNT  BSS    0           PROCESS OC$IDENT PSEUDO
          RJ     DIT         DUMP IDENTIFICATION TABLES 
          RJ     POL         PRINT * IDENT  PROGNAM*
          EQ     FASRTN 
 FO=IOM   SPACE  4,10 
 FO=IOM   BSS    0           PROCESS OC$IOM PSEUDO
          SB6    1           INDICATE IO-APLIST TABLE 
          SA1    T=IOA
          ZR     X1,FASRTN   IF NO I/O
          CALL   PAT         PRE-PROCESS I/O AP-LIST TABLE
          MX6    0
          SHRINK T=PTXTR,X6 
          SHRINK T=CLWB,X6
          RJ     KIO         COMPILE I/O AP-LISTS 
          RJ     OCL         OUTPUT CHARACTER LENGTH ARRAYS 
          RJ     POL
          SHRINK T=CLW,0
          SHRINK T=IOA,X6 
          SHRINK T=PTXTR,X6 
          SHRINK T=CLWB,X6
          EQ     FASRTN 
 FO=LCC   SPACE  4,10 
 FO=LCC   BSS    0           PROCESS OC$LCC PSEUDO
          SA1    T.LCC
          LX5    0-PB.BIASP 
          SB6    X1 
          ERRMI  PB.BIASL-18
          SB6    X5+B6       ADDRESS OF DIRECTIVE 
          LX5    PB.BIASP-PB.TAGP 
          SB7    X5          LENGTH OF DIRECTIVE
          ERRMI  PB.TAGL-18 
          SHRINK T=LCC
          WLGO   B6,B7       OUTPUT LOADER DIRECTIVE
          WRITER F.LGO,RCL
          SA5    RADB 
          RJ     POL
          EQ     FASRTN 
 FO=LOO   SPACE  4,10 
 FO=LOO   BSS    0           TURN ON / OFF OBJECT LISTING 
          MX6    -PB.BIASL
          AX5    PB.BIASP 
          BX6    -X6*X5 
          SA6    WO.LOO      (WO.LOO) = BIAS [INSTRUCTION]
          EQ     FASRTN 
 FO=NLST  SPACE  4,10 
 FO=NLST  BSS    0           PROCESS OC$NLST PSEUDO 
          RJ     KNG         COMPILE NAMELIST GROUP DEFINITIONS 
          RJ     POL         PRINT NAMELIST TABLE 
          SHRINK T=NLST,0 
          EQ     FASRTN 
 FO=USE   SPACE  4,10 
 FO=USE   BSS    0           PROCESS OC$USE PSEUDO
          BX7    X5 
          RJ     PUSE        GO SWITCH  ORG  AND  PARCEL
          RJ     DTX         DUMP TEXT
          RJ     POL         PRINT OBJECT LISTING 
          EQ     FASRTN 
 FO=TRAC  SPACE  4,10 
 FO=TRAC  BSS    0           PROCESS OC$TRAC PSEUDO 
          SA1    IDENT       ROUTINE NAME IN  0L  FORMAT
          CALL   SFN         SPACE FILL NAME
          MX0    7*CHAR 
          BX1    X0*X6       TRUNCATE TO 7 CHARACTERS 
          SA4    S=ENTRY     SYMBOL TABLE ORDINAL FOR ENTRY 
          LX0    X4,B1       DOUBLE ORDINAL 
          SA3    T.SYM
          IX0    X0+X4       =   3 * ORDINAL
          IX3    X0+X3
          ERRNZ  3-Z=SYM
          =A4    X3+WC.W     FETCH (X4) = SYMTAB WORD WC
          MX0    -WC.RAL
          BX3    -X0*X4      ISOLATE  RA  FIELD 
          BX1    X1+X3
          =X2    2           PROGRAM RELATIVE 
          LX0    X1 
          RJ     STX         STORE TEXT TABLE ENTRY (TRACE.)
          RJ     FBP         PRINT  *  NAME  TRACE.*
          =X1    1777B
          LX1    48 
          MX2    0           NO RELOCATION
          RJ     STX         STORE TEXT TABLE  ENTRY (TEMPA0.)
          EQ     FASRTN      EXIT...
 FO=END   SPACE  4,10 
**        FO=END - END OF PREBINARY PROCESSING. 
*         PROCESS SUBS AND SET ISUB BLOCK LENGTHS.
*         LIST REMAINING OBJECT LISTING AND FINISH DUMPING TABLES TO
*         THE BINARY. 
  
  
 FO=END   BSS    0
          RJ     POL         PRINT * END   PROGNAM* 
          SA1    FV.LGO 
          ZR     X1,EXIT.    IF NO BINARY 
          SA4    T.SUB
          =X7    BN=SUB 
          RJ     OSB         OUTPUT *SUB* BLOCK 
          SA4    T.SUB0 
          =X7    BN=SUB0
          RJ     OSB         OUTPUT *SUB0* BLOCK
          RJ     DTX         DUMP/RESET TEXT TABLE
          RJ     DLF         FLUSH LINK AND FILL TABLES 
          RJ     DFD         DUMP 5600/5700 TABLES
          SA3    MOD
          SBIT   X3,MO.PROP 
          PL     X3,END.50   IF NOT PROGRAM 
          WLGO   BT.XFER,2
  
*         END LGO FILE - RETURN TO MAIN BATCH CONTROL.
  
 END.50   WRITER F.LGO
          EQ     EXIT.
  
*         OUTPUT ERRORS BINARY IF FATAL ERRORS. 
  
 END.ERR  BSS    0           ENTRY FOR FATAL ERRORS IN COMPILATION
          RJ     PIT         PUMP  OUT IDNT (77) TABLE
          WLGO   BT.ERR,3    ...FOLLOWED BY ERRORS BINARY 
          EQ     END.50 
  
 SAVCBI   EQU    TEMP        KEEP OLD (CBI) DURING OUTPUT OF *SUB* BLOCK
          TITLE  RAD - *TS* TYPE INSTRUCTION PROCESSOR
          SPACE  4,30 
**        THE FOLLOWING SECTION CONTAINS *TS* TYPE INSTRUCTION
*         PROCESSORS.  THE MAIN ROUTINE IN THIS GROUP IS *RAD*, WHICH 
*         IS ENTERED FROM THE PSEUDO INSTRUCTION PROCESSOR  *FO=BMI*. 
 RAD      SPACE  4,30 
**        RAD - RELOCATE AND DUMP PRE-BINARY INSTRUCTIONS.
* 
*         ENTRY  (OC$BMI) PSEUDO ENCOUNTERED. 
*         EXIT   (I.EMI) PSEUDO ENCOUNTERED.
*         USES   ALL
*         CALLS  BNW,DTX,REL,RIP,ROL,STX
  
  
 RAD      SUBR               ENTRY/EXIT...
          MX6    0
          SA6    BCI
          SX7    3
          SA7    PARCEL 
          RJ     DTX         INITIALIZE TABLE 
          SX7    PB.BIASP 
          MX6    -PB.BIASL
          SA7    RELPOS 
          SA6    RELMASK
  
  
**        RETURN FROM I. PSEUDO INSTRUCTION PROCESSOR.
*         READ NEXT INSTRUCTION FROM T.PB.
  
  
 RADRTN   BSSENT 0
          SA2    RADA 
          MX7    0
          SA7    TAGSUB0     CLEAR SUB0 TAG 
          NZ     X2,RAD20    IF READING PACKED INSTRUCTION
          SA1    RADF 
          ZR     X1,RAD10    IF NO SB0 FILL NEEDED
          SX6    X1-1 
          SA6    A1          DECREMENT
          SA5    RADD        SB0+0
          NZ     X6,RAD5     IF SB0+0 
          SA5    RADE        SB0+LINE/SEQ NO. 
  
 RAD5     BX7    X5 
          SA7    OL=PB
          SA7    RADB 
          EQ     RAD15
  
 RAD10    RJ     RNI         READ NEXT INSTRUCTION
  
 .T       IFEQ   TEST,ON,1   IF TEST MODE 
          ZR     X5,"BLOWUP" IF TABLE EXHAUSTED 
          SA1    BCI
          PL     X1,RAD15    IF NOT PROCESSING CCG TYPE INSTRUCTIONS
  
*         FOR CCG TYPE INSTRUCTIONS, CONVERT *SI* FORMAT TO *PB* FORMAT 
*         BEFORE PROCESSING.
  
 .T       IFEQ   TEST,ON
          SA2    CO.OPT 
          ZR     X2,"BLOWUP" QCG SHOULD NOT HAVE CCG TYPE INSTRUCTIONS
 .T       ENDIF 
          MX0    -PB.GHIJL
          LX5    PB.GHIJL 
          BX0    -X0*X5      GHIJ[INSTRUCTION]
          SX6    X0-I.ECI 
          LX5    -PB.GHIJL
          ZR     X6,RAD30    IF I.ECI INSTRUCTION 
          UX6    B2,X5
          MI     B2,RADRTN   IF CCG PSEUDO - IGNORE 
          CALL   CII         CONVERT INSTRUCTION
          EQ     RAD30
  
 RAD15    MX3    PB.INSTL*3 
          MX3    PB.INSTL*3 
          BX2    -X3*X5 
          BX7    X3+X2
          NZ     X7,RAD30    IF NOT PACKED INSTRUCTION
          BX2    X3*X5
 RAD20    MX3    PB.INSTL 
          BX5    X3*X2       ISOLATE TOP INSTRUCTION
          BX7    -X3*X2      REMOVE FROM PACKAGE
          LX7    PB.INSTL    REPOSITION 
          SA7    RADA        STORE PACKAGE REMNANTS 
  
*         DETERMINE IF THIS IS A PSEUDO INSTRUCTION.
*                (X5) = CURRENT INSTRUCTION.
  
 RAD30    SA2    PARCEL 
          BX7    X5          (OL=PB) = INSTRUCTION ACTUALLY ASSEMBLED 
          MX0    PB.GHIJL 
          SA7    RADB        ** TEMP ** 
          SA7    OL=PB
          BX3    X0*X5
          MX6    -2          X6 = -3
          SB2    X2 
          SB3    X2-2 
          LX3    PB.GHL 
          SX1    X3          X1 = GH
          ZR     X1,RAD=PSI  IF PSEUDO
  
  
**        NON-PSEUDO INSTRUCTIONS.
*         THE SIGN BIT OF THE INSTRUCTIONS CORRESPONDING ENTRY IN THE 
*         *PIK=PS* TABLE INDICATES WHETHER IT IS A LONG (SET) OR SHORT
*         (NOT SET) INSTRUCTION.
  
  
          SA4    X3+PIK=PS   X4 = INST SKELETON 
          LX3    PB.GHL 
          SB4    X3 
          LX3    B1          X3 = (GHIJ)*2
          AX4    60          EXTEND SIGN BIT OF SKEL TO MAKE A MASK 
          BX7    X4*X3       X7 = + LONG, 0 SHORT 
          SA7    RADC        LONG/SHORT INDICATOR 
  
*         ADJUST THE PARCEL COUNTER FOR THIS INSTRUCTION. 
*         ENTER WITH (B3) = PARCEL -2 
*         EXIT WITH  (B3) = PARCEL + ADJUSTMENT FOR INSTRUCTION 
  
          PX3    X7 
          NX7    X3 
          UX3    X7 
          AX3    47          X3 = +1 LONG, 0 SHORT
          BX7    -X3         X7 = -1     , -0 
          IX3    X7-X6       X3 = +2     , +3 
          BX4    -X6*X3      X4 = +2     , +3 
          SB3    X4+B3       (B3) = (X4) + PARCEL - 2 
 RAD40    RJ     BNW         FORCE UPPER
          SA1    RADC 
          NZ     X1,RAD70    IF NOT A SHORT INSTRUCTION 
  
  
**        MERGE 15-BIT INSTRUCTION INTO (BINWORD).
  
          SX7    B2-B1
          SX1    B2 
          SA7    PARCEL 
          SA2    BINWORD
          SB5    15          LEN = 15 
          LX1    4
          SB7    X1+B5
          SB3    B7-B2       SHIFT COUNT = 15*PARCEL +15
          MX0    15 
          BX5    X0*X5       CLEAR REST OF WORD 
          LX5    B3 
          BX6    X2+X5       MERGE INSTRUCTION INTO BINWORD 
          SA6    A2 
  
 RADOL1   BSSENT 0
*         EQ     RADRTN      PLUGGED IF NOT LO=O
          BX1    X6 
          SB4    B3          INSTRUCTION SHIFT COUNT
          CALL   VFD         CONVERT AND FORMAT INSTRUCTION 
          SA3    =10H 
          EQ     RAD90
  
  
**        GET RELOCATION FOR 30-BIT INST. 
  
  
 RAD70    SX7    B2-2 
          MX0    -PB.H2L
          SA7    PARCEL      (PARCEL) = PARCEL - 2
          BX1    X5 
          LX1    -PB.H2P
          BX3    -X0*X1      H2I = H2 [INSTRUCTION] 
          SA4    T.SYM
          ZR     X3,RAD80    IF H2I .EQ.0  (NO ADDRESS DECREMENT) 
  
*         FOR INSTRUCTIONS REQUIRING ADDRESS DECREMENT, COMPUTE 
*         RELOCATION FOR THE TAG AND BIAS, MINUS THE RELOCATION 
*         FOR THE H2[INSTRUCTION] TAG AND SUBSTITUTE INTO BIAS FIELD
*         OF THE INSTRUCTION  BEFORE CALLING REL. 
*         SET H2[INSTRUCTION] = 0,   TAG[INSTRUCTION] = 0.
  
          BX1    X0*X1       GET RID OF H2 FIELD
          MX6    -PB.TAGL 
          LX1    PB.H2P-PB.TAGP 
          HX5    PB.BIAS
          AX5    -PB.BIASL   BIASI = BIAS [INSTRUCTION] 
          BX2    -X6*X1      TAGI = TAG [INSTRUCTION] 
          BX1    X6*X1       GET RID OF TAG FIELD 
          LX7    X3,B1
          IX3    X3+X7       STINDH = 3 * H2I 
          ERRNZ  3-Z=SYM
          SB4    X2 
          SB3    X2+B4
          MX0    -WC.RAL
          LX1    PB.TAGP-PB.BIASP 
          IX3    X4+X3
          SA2    X3+WC.W     WCH = T.SYM(STINDH) + WC.W 
          LX2    -WC.RAP
          BX6    -X0*X2      RAH = RA[WCH]
          SB4    B3+B4       STINDI = 3 * TAGI
          ERRNZ  3-Z=SYM
          SB4    X4+B4
          MX3    -PB.BIASL
          =A4    B4+WC.W     WCI = T.SYM(STINDI) + WC.W 
          LX4    -WC.RAP
          BX7    -X0*X4      RAI = RA[WCI]
          IX2    X7-X6       RAI = RAI - RAH
          IX7    X2+X5       ADDRESS = RAI + BIASI
          BX1    X3*X1       GET RID OF BIAS FIELD
          BX6    -X3*X7      TRIM ADDRESS TO SIZE OF BIAS 
          BX5    X1+X6
          LX5    PB.BIASP 
 RAD80    RJ     REL
          SA1    BINWORD
          SA2    BINREL 
          SB7    X2 
  
*         (B3) = INSTRUCTION SHIFT COUNT
*         (B7) = RELOCATION BYTE
*         (X1) = BINARY WORD OUTPUT.
  
 RADOL2   BSSENT 0
*         EQ     RADRTN      PLUGGED IF NOT LO=O
  
 RAD85    SB5    30          LEN = 30 
          SB4    B3+B5       INSTRUCTION SHIFT COUNT + LEN
          CALL   VFD
          SX2    B7          (X2) = RELOC INFO
          SA3    =10H 
          SB3    B2-B1       = (PARCEL) - 1 
          MX0    -3 
          AX1    X2,B3
          BX0    -X0*X1      ISOLATE THIS RELOC VALUE 
          ZR     X0,RAD90    IF NO RELOCATION 
          SA3    =10H+
 RAD90    SA6    LINEBUF+1   (LINEBUF+1) = UPPER 30 BITS OF INSTRUCTION 
          BX6    X3 
          =A7    A6+1        (LINEBUF+2) = LOWER 30 BITS OF INSTRUCTION 
          =A6    A7+1        (LINEBUF+3) = RELOCATION FIELD 
          SA5    OL=PB
          RJ     POL         PRINT OBJECT LIST
          EQ     RADRTN 
 RAD=PSI  SPACE  4,10 
**        PROCESS I. PSEUDO INSTRUCTION.
* 
*         USED IN CONJUCTION WITH THE PSEUDO INSTRUCTION JUMP TABLE 
*         AT IPSUD. 
*         THE DECISION WHETHER TO FORCE UPPER BEFORE THE
*         INSTRUCTION IS MADE HERE DEPENDING ON THE PARCEL COUNT. 
*         (X3) = 6/IJ,48/0,6/GH 
*         (B2) = (PARCEL) 
*         (B3) = (PARCEL) - 2 
*         (X0) = MASK FOR GHIJ
  
 RAD=PSI  BSS    0
          LX3    PB.GHL 
          SB4    X3          IJ 
          =X7    -X3
          SA7    RADC        INDICATES PSEUDO INST
          BX5    -X0*X5      MASK OFF GHIJ FROM INSTRUCTION 
          JP     B4+OCPSUD   JUMP TO I.PSUEDO INSTRUCTION PROCESSOR 
 FI=BCI   SPACE  4,10 
 FI=BCI   BSS    0           BEGIN CCG TYPE INSTRUCTIONS
          MX6    1
          SA6    BCI         (BCI) = 1S59 
          EQ     RADRTN 
 FI=DATA  SPACE  4,10 
 FI=DATA  BSS    0           READ AND PROCESS *DATA* INFORMATION
  
*         FLUSH PARTIAL WORD AND SAVE ORG.
  
          RJ     BNW         BEGIN NEW WORD 
          SA1    ORG
          BX6    X1 
          SA6    ORGD 
          SHRINK T=DATS,0 
          LX5    -PB.BIASP
          MX0    -PB.BIASL
          BX5    -X0*X5      NUMBER OF DATA WORDS FOLLOWING 
          ALLOC  T.DATS,X5
          SB6    X1          (T.DATS) 
          RJ     RMI         READ MULTIPLE PB WORDS 
          RJ     POL         PRINT OBJECT LIST
          RJ     DDS         DUMP T.DATS
          SA1    ORGD 
          SX7    3
          SHRINK T=DATS,0 
          BX6    X1 
          SA7    PARCEL      START OF NEW WORD
          SA6    ORG         RESTORE ORG
          RJ     DTX         INITIALIZE TEXT TABLE
          EQ     RADRTN 
  
 ORGD     BSS    1
 FI=ECI   SPACE  4,10 
 FI=ECI   BSS    0           END CCG TYPE INSTRUCTIONS
          MX6    0
          SA6    BCI         (BCI) = 0
          EQ     RADRTN 
 FI=BSS   SPACE  4,10 
 FI=BSS   BSS    0           PROCESS I.BSS INSTRUCTION
          RJ     RBS         RELOCATE  BSS  PSEUDO INSTRUCTION
          RJ     ESL         ENTER STMT LABEL IN 57 TABLE 
          EQ     RADRTN 
 FI=BOS   SPACE  4,10 
 FI=BOS   BSS    0           PROCESS I.BOS INSTRUCTION
 .T       IFEQ   TEST,ON
          SA2    FI=BRLI
          MX1    -PB.BIASL
          LX5    -PB.BIASP
          BX6    -X1*X5      (LINES) = NEW LINE NUMBER
          IX2    X6-X2
          SA6    LINES
          LX5    PB.BIASP 
          NZ     X2,BOS.1    IF NOT AT BREAKPOINT LINE
 BRLI3    BREAK 
 BOS.1    BSS 
 .T       ENDIF 
  
          RJ     CLE         CREATE LINE TABLE ENTRY
          RJ     POL         PRINT * LINE    NNN* 
          EQ     RADRTN 
 FI=CPL   SPACE  4,10 
 FI=CPL   BSS    0           *CPL.* TABLE ORDINAL 
          RJ     BNW         FORCE UPPER
          MX0    -PB.TAGL 
          MX6    -PB.ORDL 
          LX5    -PB.TAGP 
          BX2    -X0*X5      TAGI = TAG[INSTRUCTION]
          BX3    X6*X2       PFXI = PFX[TAGI] 
          LX5    PB.TAGP
          NZ     X3,"BLOWUP" IF PFXI .NE. K=SYM 
          ERRNZ  K=SYM
          SA1    T.SYM
          =B7    X1+WB.W
          LX0    X2,B1
          IX2    X0+X2       STIND = 3 * TAGI 
          ERRNZ  3-Z=SYM
          SA1    X2+B7       WBI = T.SYM(STIND) + WB.W
          =A3    A1-WB.W+WC.W      WCI
          MX0    -WC.CLENL
          LX3    -WC.CLENP
          BX6    -X0*X3      CLENI = CLEN[WCI]
          LX3    WC.CLENP-1-WC.CTYPP
          AX3    59          SIGN EXTEND WC.CTYP
          HX1    WB.FPNO
          AX1    -WB.FPNOL   FPNOI = FPNO[WBI]
          =X1    X1-1        FPNOI = FPNOI - 1
          ERRMI  18-WB.FPNOL
 .T       IFEQ   TEST,ON,1
          MI     X1,"BLOWUP" IF FPNOI .LT. 0
          BX3    -X3*X6      L = WC.CLEN IFF WC.CTYP .EQ. 0, ELSE = 0 
          LX3    30 
          MX6    1
          BX1    X1+X3
          BX1    X1+X6       ADD IN SIGN BIT
          =X2    0           INDICATE NO RELOCATION 
          BX0    X1          SAVE (X0) = (X1) 
          RJ     STX         STORE INTO TEXT
          RJ     FBP         FORMAT BINARY DISPLAY CODE AND PRINT 
          EQ     RADRTN 
 FI=EMI   SPACE  4,10 
 FI=EMI   BSS    0           END OF QUICK MODE CODE, EXIT RAD 
          RJ     BNW         STORE LAST WORD INTO TEXT TABLE
          EQ     EXIT.
  
  
*         FOR  RJ6, RJ3, JPI, UJP  PSEUDO INSTRUCTIONS, RETAIN
*         PSEUDO STATUS UNTIL FORCE UPPER, AFTER COMMENCES. 
*         (X5) = INSTRUCTION WITHOUT GHIJ 
 FI=JPI   SPACE  4,10 
 FI=JPI   BSS    0           PROCESS  I.JPI PSEUDO
          LX5    -PB.BJRP 
          MX1    -PB.IL 
          BX4    -X1*X5      BI = BJR [INSTRUCTION] 
          LX5    PB.BJRP
          LX4    PB.GHIJP+PB.IL    POSITION THE *B-BOX* 
          BX5    X1*X5       GET RID OF BJR FIELD 
          IX5    X5+X4
          SX2    200B 
          SB3    B3+2        WORTH TWO PARCELS
          EQ     UJP.10 
 FI=LOO   SPACE  4,10 
 FI=LOO   BSS    0           TURN ON /OFF OBJECT LISTING
          MX6    -PB.BIASL
          AX5    PB.BIASP 
          BX6    -X6*X5 
          SA6    WO.LOO      (WO.LOO) = BIAS [INSTRUCTION]
          EQ     RADRTN 
 FI=OTR   SPACE  4,10 
 FI=OTR   BSS    0           PROCESS  I.OTR PSEUDO
          SX2    6102B
          LX2    -PB.GHIJL
          BX5    X5+X2       REPLACE GHIJ WITH OPCODE EQUIVALENT
          LX7    X5 
          =X6    B1 
          SA6    RADC        CHANGE INDICATOR FROM PSEUDO TO LONG 
          SA7    OL=PB       SET MODIFIED INSTRUCTION 
          MX0    PB.GHIJL 
          BX1    -X0*X5 
          LX1    PB.GHIJL+PB.TAGL 
          SA2    S=LENP      ORDINAL TO LENP ENTRY IN T.SYM 
          BX3    X1-X2
          NZ     X3,RAD40    IF NOT  *SB0  B2-LENP.*  INSTRUCTION 
          LX6    X2,B1
          IX7    X6+X2       STIND = 3 * ORDINAL
          SA2    T.SYM
          IX6    X2+X7
          SA3    X6+WC.W     WCI = T.SYM(STIND) 
          LX3    -WC.RAP
          MX7    -PB.BIASL
          BX3    -X7*X3      BIASI = RA[WCI]
          BX1    X0*X5
          LX3    PB.BIASP 
          IX5    X1+X3
          BX6    X5 
          SA6    OL=PB
          EQ     RAD40       PROCESS LIKE A LONG INSTRUCTION
 FI=RJ3   SPACE  4,10 
 FI=RJ3   BSS    0           PROCESS  I.RJ3 PSEUDO
          SX2    100B 
          SB3    B3+2        WORTH TWO PARCELS
          EQ     UJP.10 
 FI=LD0   SPACE  4,10 
 #DAL     IFEQ   .DAL,0      IF NO LEVEL 0 POSSIBLE 
 FI=LD0   EQU    "BLOWUP" 
 FI=ST0   EQU    "BLOWUP" 
 FI=SB0I  EQU    "BLOWUP" 
  
 #DAL     ELSE
 FI=LD0   BSS    0           LOAD INSTRUCTION FOR SUB0
          =X2    1400B       LCM LOAD INSTRUCTION 
 LD0.10   MX0    -PB.H2L
          BX6    X5 
          AX5    PB.H2P 
          BX0    -X0*X5      IJ 
          BX1    X0+X2       (014IJ/ 015IJ) 
          =X5    53000B 
          LX0    3
          BX5    X5+X0       (53IJ0)
          RJ     BSZ         MAKE AN SUB0 ENTRY 
          LX5    -15
          MX6    0
          LX7    X5          (OL=PB) = ACTUAL INSTRUCTION 
          SA6    RADC        INDICATE SHORT INSTRUCTION 
          =B3    B3+3        THIS INSTRUCTION TAKES 15 BITS 
          SA7    OL=PB
          EQ     RAD40       PROCESS AS 15 BIT INSTRUCTION
 FI=ST0   SPACE  4,10 
 FI=ST0   BSS    0
          =X2    1500B       LCM STORE INSTRUCTION
          EQ     LD0.10 
 FI=SB0I  SPACE  4,10 
 FI=SB0I  BSS    0           OUTPUT A SUB0 INDEX WORD 
          SB4    BN=SUB0
          SB6    FP.SUB0P 
          EQ     SUBI.10
 #DAL     ENDIF 
 FI=SUBI  SPACE  4,10 
 FI=SUBI  BSS    0           OUTPUT A SUBI WORD 
          SB4    BN=SUB 
          SB6    FP.SUBP
 SUBI.10  BSS    0
          RJ     BNW         FORCE UPPER
          HX5    PB.TAG 
          AX5    -PB.TAGL    TAGI = TAG[INSTRUCTION]
 .T       IFEQ   TEST,ON,1
          MI     X5,"BLOWUP" IF TAGI .LT. 0 
          SA2    T.SYM
          LX0    X5,B1
          IX0    X5+X0       STIND = 3 * TAGI 
          ERRNZ  3-Z=SYM
          =B7    X2+WB.W
          SA1    X0+B7       WBI = T.SYM(STIND) + WB.W
          MX0    -WB.FPNOL
          AX1    WB.FPNOP 
          BX1    -X0*X1      FPNOI = FPNO[WBI]
          SB7    X1-1        FPNOI = FPNOI - 1
          ERRMI  18-WB.FPNOL
          SA3    T.FPO
          SA2    X3+B7       FPOI = T.FPO(FPNOI)
          AX2    B6 
          MX0    -FP.SUBL 
          BX2    -X0*X2      EXTRACT SUB FIELD
 .T       IFEQ   TEST,ON,1
          MI     X2,"BLOWUP" IF SUBFWA .LT. 0 
          SA4    F.LBT+B4    SUBBLK = T.LBT(BN=SUB) 
          HX4    LB.ORG 
          AX4    -LB.ORGL    SUBORG = ORG[ T.LBT(BN=SUB)] 
          IX4    X4+X2       SUBFWA = SUBFWA + SUBORG 
          PX1    X4,B7       12/2000B+(FPNO-1), 30/0, 18/SUBORG 
          =X2    2           INDICATE LOWER ADDRESS RELOCATION
          BX0    X1          SAVE (X0) = (X1) 
          RJ     STX         OUTPUT THE SUB INDEX WORD
          RJ     FBP         FORMAT BINARY AND PRINT
          EQ     RADRTN 
 FI=UJP   SPACE  4,10 
 FI=UJP   BSS    0           PROCESS  I.UJP PSEUDO
          SA1    S=ENTRY
          BX2    X5 
          HX2    PB.TAG 
          AX2    -PB.TAGL    EXTRACT OPERAND ORDINAL
          IX1    X1-X2
          NZ     X1,UJP.5    IF NOT MAIN ENTRY (OF SUBROUTINE)
          =X1    1
          LX1    PB.BIASP+17
          BX5    X5+X1       MAKE A "BLOWUP" STYLE ENTRY
  
 UJP.5    SX2    400B        EQ CODE
          SB3    B3+2        THIS INSTRUCTION IS WORTH TWO PARCELS
  
 UJP.10   LX2    -PB.GHIJL
          BX5    X5+X2
          LX6    X5          (OL=PB) = MODIFIED INSTRUCTION 
          SA6    OL=PB
          RJ     BNW         FORCE UPPER IF NECESSARY 
          RJ     REL         RELOCATE ADDRESS 
          SA2    BINREL 
          SA1    BINWORD
          BX6    X1 
          SA0    X2          SAVE (A0) = LOWER 18 BITS OF (BINREL)
          SX0    B3          SAVE (X0) = (B3) 
          SA6    TEMP        SAVE (TEMP) = BINARY WORD
          RJ     STX         STORE IN TEXT TABLE, FORCE UPPER AFTER 
          SA1    TEMP 
          SB3    X0          RESTORE (B3) 
          SB7    A0 
          EQ     RAD85
 FI=RJ6   SPACE  4,10 
 FI=RJ6   BSS    0           PROCESS  RJ WITH TRACE PSEUDO INST 
          SX2    100B 
          MX1    -PB.BIASL
          LX2    -PB.GHIJL
          BX5    X5+X2       (OL=PB) = MODIFIED INSTRUCTION 
          LX1    PB.BIASP 
          BX6    -X1*X5      LINE NUMBER = BIAS [INSTRUCTION] 
          BX7    X1*X5       (PB.BIAS) = 0, FOR BST 
          BX5    X1*X5
          LX6    -PB.BIASP
          SA6    SAVETR      (SAVETR) = LINE NUMBER 
          SA7    OL=PB
          RJ     BNW         BEGIN NEW WORD (FORCE UPPER) 
          RJ     REL         RELOCATE THE RJ
          SA4    SAVETR      LINE NUM 
          SA3    OL=PB
          SX2    7776B
          IX2    X4-X2
          MX6    0           NO SPECIAL LINE/SEQUENCE PROCESSING
          MI     X2,RJ6.10   IF LINE/SEQUENCE NUMBER .LT. 4095
          LX6    X4          INDICATE SPECIAL LINE/SEQUENCE PROCESSING
          SX4    7777B       RESET TO FLAG NOT REALLY LINE NUMBER 
  
 RJ6.10   SA6    SAVETR 
          LX4    PB.BIASP 
          =X2    2           INDICATE LOWER PGM REL 
          SA1    BINWORD
          BX7    X4+X3       ADD LINE NUM BACK IN TO LISTING
          LX4    -PB.BIASP+18 
          BX1    X1+X4       ADD LINE NUM BACK IN TO BINARY 
          BX0    X1 
          SA7    A3 
          RJ     STX         STORE IN *TEXT* TABLE
          RJ     FBP         FORM BINARY AND PRINT
          SA3    SAVETR 
          ZR     X3,RADRTN   IF NO LINE/SEQUENCE NUMBER TO PROCESS
          SA1    RADD 
          LX3    PB.BIASP 
          BX6    X1+X3
          SA6    RADE 
          =X6    2
          SA6    RADF        INDICATE FUNNY RNI 
          EQ     RADRTN 
 FI=USE   SPACE  4,10 
 FI=USE   BSS    0           PROCESS I.USE PSEUDO 
          RJ     BNW         BEGIN NEW WORD 
          RJ     DTX         DUMP TEXT. 
          BX7    X5 
          RJ     PUSE        GO SWITCH  ORG  AND  PARCEL
          RJ     DTX         INITIALIZE NEW  ORG,PARCNT IN TEXT 
          RJ     POL         PRINT OBJECT LISTING 
          EQ     RADRTN 
 FI=ZERO  SPACE  4,10 
 FI=ZERO  BSS    0           OUTPUT A ZERO WORD 
          RJ     BNW         FORCE UPPER
          MX1    0
          BX2    0           INDICATE NO RELOCATION 
          RJ     STX
          MX0    0
          RJ     FBP         FORMAT BINARY AND PRINT
          EQ     RADRTN 
  
  
 RADA     BSSZ   1           STORAGE FOR PACKED 15 BIT INSTRUCTIONS 
 RADB     BSS    1           STORAGE FOR READW INPUT
 RADC     BSSENT 1           STORAGE FOR INSTRUCTION TYPE 
 RADD     VFD    12/6100B,48/0     SB0 TEMPLATE 
 RADE     BSS    1           SB0+LINE/SEQ NO. 
 RADF     BSSZ   1           FUNNY RNI INDICATOR
 SAVETR   EQU    TEMP        SAVE TRACE BACK LINE NUM DURING RELOCATION 
          TITLE  ASSEMBLER SUPPORTING ROUTINES
 BNW      SPACE  4,10 
**        BNW - BEGIN NEW WORD. 
* 
*         ENTRY  (B2) = CURRENT PARCEL. 
*                (B3) FLAGS WHETHER FORCE UPPER OR NOT -- 
*                       IF (B3) .GT. 0 , EXIT.
* 
*         EXIT   OLD WORD STORED IN TEXT TABLE AND NEW WORD BEGUN.
*                (B2) UPDATED.
*                (LINEBUF) = ORIGIN COUNTER, OR BLANK.
* 
*         CALLS  ROL, STX.
  
  
 BNW      SUBR
          GT     B3,B0,BNW8  IF NO NEED TO PAD
          SA3    =460006100046000B
          SB3    B2-2 
          MX7    PB.INSTL 
          SX2    -B3         = 2 - (PARCEL) 
          SA1    BINWORD
          LX2    4           = 32 - 16*P
          SB7    X2+B3       = 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 THE CURRENT TEXT TABLE 
          SB2    3           INDICATE EMPTY WORD NOW
 BNW8     RJ     ROL         SET ORIGIN FOR OL
          EQ     EXIT.
 BST      SPACE  4,10 
**        BST -  BUILD  *SUB*  TABLE. 
* 
*         COMPILE AN ADDRESS SUBSTITUTION ENTRY INTO (T.SUB), IN
*         (SB.) FORMAT.  CALLED BY *REL* WHEN A MACHINE INSTRUCTION IS
*         GENERATED WITH A Q-FIELD REFERING TO A FORMAL PARAMETER.
* 
*         ENTRY  (B2) = PARCEL COUNT. 
*                (B5) = FORMAL PARAMETER NUMBER.
*                (OL=PB) = BIAS IN (PB.BIAS) FIELD. 
* 
*         EXIT   *SUB* ELEMENT STORED INTO  T.SUB.
*                (X5) = CURRENT  *SUB*  TABLE ELEMENT.
* 
*         KEEPS  B2,B3,B4 
  
  
 BST      SUBR   =           ENTRY/EXIT.
 BST.EQ   BSSENT 0
          SB7    B5-B1
          SA1    T.FPI
          SA2    X1+B7       FPI = T.FPI(FPIND - 1) 
          SA3    T.SUB
          SB6    X3 
          LX2    -FP.SUBP 
          MX6    -FP.SUBL 
          BX6    -X6*X2      EXTRACT FP.SUB 
          SB7    X6          SUBIND = ORG[FPI]
          =X6    1
          IX7    X2+X6
          LX7    FP.SUBP
          SA7    A2          ORG[FPI] = ORG+1 [FP.] 
  
*         CREATE POS[FP.] FROM PARCEL COUNT.
  
          SX0    B2-B1       = PARCEL -1
          SX1    B2-B1
          LX0    4
          IX5    X0-X1       SHIFT = 15 * (PARCEL - 1)
          LX2    12 
          SX1    X5-1        SHCNT = (-1,  14,  OR 29)
          AX1    59          SIGN EXTEND SHCNT
          SX4    B1 
          BX4    X1*X4       (1, 0, OR 0) 
          SX5    X5+2000B    (2000B,  2017B,  OR 2036B) 
          IX5    X5-X4       POSI = (1777B,  2017B,  OR 2036B)
  
*         COMPLEMENT POSI IF DELAY. 
  
          SA1    DELAY
          SA3    ORG
          PX7    X3,B5       DELI = (12/2000B+FPNO, 48/ORG) 
          SA7    A1          (DELAY) = DELI 
          BX1    X1-X7       IF (DELAY ) .EQ. DELI, (X1) = 0
          MX0    0
          BX4    -X1
          IX6    X0+X4
          BX4    X1+X6       =0 IF DELAY,  -0 IF NOT
          LX5    SB.POSP
          ERRNZ  48-SB.POSP 
          MX2    12 
          BX2    -X4*X2      12 BIT MASK IF DELAY 
          BX5    X5-X2
  
*         FORM REST OF [SB.] WORD.
  
          SA1    OL=PB
          MX0    -PB.BIASL
          LX3    SB.ORGP
          BX5    X5+X3
          LX1    -PB.BIASP
          BX1    -X0*X1      BIASI = BIAS[INSTRUCTION]
          LX1    SB.BIASP 
          BX6    X1+X5
          SA6    B6+B7       T.SUB(SUBIN) = (POS,BIASI,ORD)[SB.]
          EQ     EXIT.
 BSZ      SPACE  4,10 
**        BSZ -  BUILD SUB0 TABLE.
*                MAKE A SUB0 TABLE ENTRY, FORMATTED AS SZ. .
* 
*         ENTRY  (X1) = LCM LOAD/ STORE INSTRUCTION 
*                (X5) = SHORT INSTRUCTION 
*                (X6) = I.LD0/ I.ST0 PSEUDO INSTRUCTION 
*         EXIT   (X5) = UNCHANGED 
*                (TAGSUB0) = SYMTAB ORD OF F.P. BEING SUB0ED. 
*         USES
  
  
 BSZ      SUBR               ENTRY/EXIT.
 #MD      IFNE   .DAL,0 
          HX6    PB.TAG 
          AX6    -PB.TAGL    TAGI = TAG[ INSTRUCTION] 
          SA6    TAGSUB0     (TAGSUB0) = TAGI 
          SA2    T.SYM
          SB4    X2+WB.W
          LX3    X6,B1
          SB4    X3+B4
          MX0    -WB.FPNOL
          SA2    X6+B4       WBI = T.SYM(STIND) + WB.W
          SA3    T.FPI
          ERRNZ  3-Z=SYM
          AX2    WB.FPNOP 
          BX0    -X0*X2      FPNOI = FPNO[WBI]
          SB4    X0-1        FPNOI = FPNOI - 1
          ERRMI  18-WB.FPNOL
          SA2    X3+B4       FPI = T.FPI(FPNOI) 
          LX2    -FP.SUB0P
          =B7    X2+1        SUB0IND = SUB0[FPI]
          ERRNZ  18-FP.SUB0L
          =X6    1
          IX7    X6+X2
          LX7    FP.SUB0P 
          SA7    A2          SUB0[FPI] = (SUB0+1) [FP.] 
  
*         CREATE A SUB0 ENTRY.
  
          SA2    PARCEL 
          SX0    X2 
          LX0    4
          IX6    X0-X2       PARCEL* 15 
          SX6    X6+2036B 
 .T       IFEQ   TEST,ON,1
          MI     X6,"BLOWUP"
          SX3    X6-2074B 
          MI     X3,BSZ4     IF SHIFT COUNT LESS THAN 60
          SX6    X6-74B 
  
 BSZ4     LX6    SZ.POSP-SZ.SLIP
          BX1    X1-X5       LCM INSTR .XOR. 53IJ0
          BX6    X6+X1
          LX6    SZ.SLIP
          SA3    ORG
          PL     X2,BSZ10    IF CURRENT WORD NOT FULL 
          =X3    X3+1        SUBBING NEXT WORD
  
 BSZ10    SA4    T.SUB0 
          LX3    SZ.ORGP
          BX6    X3+X6
          SA6    X4+B7       (POS,SLI,ADDR) [T.SUB0(SUB0IND)] = [SZ.] 
          EQ     EXIT.
 #MD      ELSE
          EQ     "BLOWUP" 
 #MD      ENDIF 
 CAB      SPACE  4,10 
**        CAB - COPY ADJUSTED BITS. 
* 
*         COPIES SELECTED BITS FROM AN INPUT WORD, AND MERGES THEM, 
*         SHIFTED AS DIRECTED, INTO AN OUTPUT WORD. 
* 
*         ENTRY  (A1,X1) = BIT SELECT LIST, AS SETUP BY CABS MACRO. 
*                (X2) = OUTPUT WORD.
*                (X5) = INPUT WORD. 
* 
*         EXIT   (X2) = BITS MERGED PER SELECT LIST.
* 
*         USES   A1,3.  X0-1,3-4,6-7.  B2,7.
  
  
 CAB      SUBR   =           ENTRY/EXIT...
          MX0    -6 
          SX7    B1 
  
 CAB4     LX1    6
          BX6    -X0*X1      (B2) = 60 - INBIT
          IX1    X1-X6
          SB2    X6 
          LX1    6
          BX3    -X0*X1      (B7) = OUTBIT
          IX1    X1-X3
          SB7    X3 
          LX6    X5,B2       MOVE INBIT TO BOTTOM 
          BX3    X7*X6
          LX6    X3,B7       POSITION ISOLATED OUTBIT 
          BX2    X6+X2       MERGE OUTBIT INTO OUTWORD
          NZ     X1,CAB4     IF MORE FIELDS IN THIS SELECT WORD 
          SA1    A1 
          BX6    -X0*X1 
          ZR     X6,EXIT.    IF LAST WORD NOT FULL
          SA1    A1+B1
          NZ     X1,CAB4     IF NEW WORD NOT TERMINATOR 
          EQ     EXIT.
 CABS     SPACE  4,10 
**        CABS - CONSTRUCT ADJUSTED BIT SELECT LIST.
* 
* TAG     CABS   FI,FO,(BN1,BN2,...,BNN)
* 
*         WHERE  FI = PREFIX FOR INPUT FIELD. 
*                FO = PREFIX FOR OUTPUT FIELD.
*                BN(J) = BIT NAME TO BE COPIED, WHEN SAME IN BOTH WORDS.
*                      = BNI/BNO,  WHEN SUFFIXES DIFFER.
*                BNI = BIT NAME IN FI.
*                BNO = BIT NAME IN FO.
  
  
 CABS     MACRO  FI,FO,BL 
          IRP    BL 
 A        MICRO  1,,/BL// 
 B        MICCNT A
 C        MICRO  B+2,,,BL,
          IFC    EQ,/"C"//,1
 C        MICRO  1,,/"A"/ 
          VFD    6/60-FI."A"P,6/FO."C"P 
          IRP 
          VFD    11/0,*P/0
          ENDM
 CLI      SPACE  4,10 
**        CLE -  CREATE LINE TABLE ENTRY
* 
*         ENTRY  (X5) = PB INSTRUCTION
*         EXIT   AN ENTRY MADE TO T.LNT 
*         USES   A1,X1,X6 
  
  
**        DEFINE 6700 TABLE FORMAT (LN.) .
  
          DESCRIBE LN.,60 
 LAB      DEFINE 18          LABEL IN BINARY
          DEFINE 6           0
 LN       DEFINE 18          LINE NUMBER IN BINARY
 RA       DEFINE 18 
  
  
 CLE      SUBR   =           ...ENTRY/EXIT... 
 CLE.EQ   BSSENT 0
          RJ     BNW         FORCE UPPER
          SA1    ORG
          MX6    -PB.BIASL
          LX5    -PB.BIASP
          BX6    -X6*X5 
          LX5    PB.BIASP 
          LX1    LN.RAP 
          LX6    LN.LNP 
          BX6    X1+X6
          ADDWD  T.LNT
          EQ     EXIT.
DDS       SPACE  4,10 
**        DDS - DUMP DATA STATEMENTS. 
* 
*         CALLED FROM *FI=DATA* TO DUMP DATA STATEMENTS TO TEXT.
* 
*         ENTRY  T.DATS FORMATTED AS DA., DB. . 
* 
*         CALLS  ALLOC,MOVE,DTX,OTB 
  
          DESCRIBE DC.,60 
 LINK     DEFINE 1           INDICATE GROUP FULL
          DEFINE 23 
 PTR      DEFINE 18          IFF DC.LINK=1, POINT TO NEXT GROUP 
 CNT      DEFINE 18          WORD COUNT THIS GROUP
  
  
 DDS      SUBR   0           ENTRY/EXIT.
          SB4    B0          IND = 0
          SHRINK T=PTXT,B4
          SHRINK T=PTXTR,X6 
          ADDWD  T.PTXT      INITIALIZE COUNT 
          ADDWD  T.PTXTR     INITIALIZE COUNT 
  
*         PROCESS NEXT DATA GROUP.
*         (B4) = IND
  
 DDS10    SA1    T.DATS 
          SA2    T=DATS 
          SA5    X1+B4       DAI = T.DATS(IND)
          SB2    X2 
          SB3    B2-B4
          MX1    -DA.BIASL
          ZR     B3,DDS90    IF TABLE EXHAUSTED 
 .T       IFEQ   TEST,ON,1
          MI     B3,"BLOWUP" IF IND .GT. TABLE LENGTH 
          LX5    -DA.BIASP
          BX4    -X1*X5      BIASI = BIAS[DAI]
          LX5    DA.BIASP-DA.ORDP 
          MX2    -DA.ORDL 
          BX1    -X2*X5      ORDI = ORD[DAI]
 .T       IFEQ   TEST,ON,3
          MX0    -PB.ORDL 
          BX6    X0*X1       PFXI = PFX[ORDI] 
          NZ     X6,"BLOWUP" IF PFXI .NE. K=SYM 
          ERRNZ  K=SYM
          LX2    X1,B1
          IX1    X1+X2       STIND = 3 * ORDI 
          ERRNZ  3-Z=SYM
          SA2    T.SYM
          =B7    X2+WC.W
          SA2    X1+B7       WCI = T.SYM(STIND) + WC.W
          MX1    -WC.RAL
          MX7    -WC.RBL
          LX2    -WC.RAP
          BX1    -X1*X2      RAI = RA[WCI]
          LX2    WC.RAP-WC.RBP
          BX7    -X7*X2      RBI = RB[WCI]
          AX7    1           BLKORD = RBI / 2 
          ERRNZ  2-Z=BLKS 
          ZR     X7,DDS20    IF PROGRAM RELATIVE
          SX7    X7+B1       BLKORD = BLKORD + 1
  
 DDS20    MX0    -DA.WCL
          SX6    B1 
          =A3    A2-WC.W+WB.W      WBI
          LX3    -WB.MATP 
          BX3    X6*X3       MATI = MAT[WBI]
          SB7    X3          REMEMBER (B7) = WB.MAT 
          LX5    DA.ORDP-DA.WCP 
          BX0    -X0*X5      WDC = WC[DAI]
          BX3    X5 
          LX5    DA.WCP-DA.RPP
          LX3    DA.WCP-1-DA.CHP
          BX5    X6*X5       RPI = RP[DAI]
          SB3    X5+B1       HEADWD = RPI + 1 
          PL     X3,DDS50    IF NOT CHARACTER DATA
  
*         CHARACTER DATA - BUILT PTEXT/ PTEXTR TABLE. 
*         (B7) = WB.MAT 
*         (X4) = BIASI
*         (X1) = RAI
*         (X2) = WCI
*         (X7) = BLKORD 
*         (B3) = HEADWD 
  
          BX6    X0 
          CW     X3,X0       WDC = WDC / 10 
          SX0    X3+B3       WDC = WDC + HEADWD 
          SX7    X7+B1       BLKORD = BLDORD + 1
          LX7    BT.RBP 
          LX5    BT.RPP 
          BX7    X7+X5
          ZR     B7,DDS85    IF ELEMENT NOT MATERIALIZED
          BC     X3,X6       WDC = WDC * 6
          LX3    BT.LENP
          BX7    X7+X3
          WC     X3,X1       RAI = RAI * 10 
          BX1    X3 
          IX4    X4+X1       RAI = BIASI + RAI
          WX1    X4,X2       CONVERT RAI TO FWA AND BCPI
          BC     X3,X2       BCPI = BCPI * 6
          LX1    BT.FWAP
          LX3    BT.BCPP
          BX1    X1+X3
          BX7    X7+X1
          SA7    A5          (DAI) =  (LEN,BCP,RP,RB,FWA) [BT.] 
          SA1    T.PTXT 
          ZR     X5,DDS80    IF NO REPLICATION
  
*         CHARACTER DATA WITH REPLICATION.
  
          SA4    A5+B1       DBI = DAI + 1
          MX3    -DB.CNTL 
          MX2    -DB.INCL 
          LX4    -DB.CNTP 
          BX3    -X3*X4      CNTI = CNT[DBI]
          SX7    B1 
 .T       IFEQ   TEST,ON,2
          IX1    X3-X7
          MI     X1,"BLOWUP" IF CNTI .LE. 0 
  
          IX3    X3+X7       CNTI = CNTI + 1
          LX3    BT.RCPP
          LX4    DB.CNTP-DB.INCP
          BX4    -X2*X4      INCI = INC[DBI]
          BC     X2,X4       INCI = INCI * 6
          LX2    BT.RIPP
          BX7    X3+X2
          SA7    A4          (DBI) = (INCI,CNTI)[BT.] 
          SA1    T.PTXTR
          EQ     DDS80
  
*         NON CHARACTER DATA. 
*         (B7) = WB.MAT 
  
 DDS50    SB4    B4+X0       IND = IND + WCI
          SB4    B4+B3       IND = IND + HEADWD 
          ZR     B7,DDS10    IF NOT MATERIALIZED
          LX5    59 
          LX7    BT.RSP 
 .T       IFEQ   TEST,ON,3
          BX2    X4 
          AX2    24 
          NZ     X2,"BLOWUP" IF BIAS TOO LARGE
          IX6    X4+X1       RAI = RAI + BIASI
 .T       IFEQ   TEST,ON,1
          MI     X6,"BLOWUP" IF RAI .LT. 0
          SX3    B1 
          LX3    BT.RLXP
          BX6    X6+X7
          AX5    -0          -0 MASK IF REPL
          SA6    ORG
          IX6    X6+X3       BLKS = BLKS + 1
          BX7    X5*X6
          SA7    BT.XREP+1   (BT.XREP+1) = ORG, IFF REPLICATION 
          RJ     DTX         INITIALIZE TEXT TABLE
          PL     X5,DDS70    IF NO REPLICATION
          SA5    A5+B1       DBI = DAI + 1
          MX1    -BT.KL 
          LX5    -DB.INCP 
          BX2    -X1*X5      K = INC[DBI] 
          ERRMI  DB.INCL-BT.KL
          MX1    -BT.CL 
          SA3    BT.XREP+1
          LX2    BT.KP
          LX5    DB.INCP-DB.CNTP
          BX1    -X1*X5      C = CNT[DBI] 
          ERRMI  DB.CNTL-BT.CL
          BX7    X3+X2       ADD IN K FILED 
          SA7    A3          (BT.XREP+1) = (K,RS,AS) [BT.]
          LX2    -BT.KP 
          LX1    BT.CP
          BX6    X0          B = WCI
          LX6    BT.BP
          BX6    X6+X1
          CLAS=  X4,BT,(RS,AS)
          BX4    X4*X7       RD = RS,(RELOCATION BASE OF SOURCE)
          IX1    X4+X2       AD = AS + K
          BX6    X6+X1
          SA6    A7+B1       (BT.XREP+2) = (C,B,RD,AD) [BT.]
  
*         OUTPUT DATA WORDS.
*         ENTRY  (X0) = NO. OF WORDS TO OUTPUT
*                A5 _ NEXT DATA WORD
  
 DDS70    SA5    A5+B1
          BX2    0           INDICATE NO RELOCATION 
          SX0    X0-1 
          LX1    X5 
          RJ     STX         OUTPUT A WORD
 .T       IFEQ   TEST,ON,1
          MI     X0,"BLOWUP"       IF WORD COUNT ILL
          NZ     X0,DDS70    IF MORE WORDS TO DO
  
          SA1    BT.XREP+1
          ZR     X1,DDS10    IF NO REPLICATION
          RJ     DTX         FLUSH ANY PARTIAL TEXT TABLE 
          WLGO   BT.XREP,BT.XREPL 
          EQ     DDS10
  
*         ALLOCATE ENTRY FOR PTEXT/ PTEXTR TABLE. 
*         (X0) = WCI
*         A1 _ T.PTXT/ T.PTXTR
  
 DDS80    SB2    X0          REMEMBER (B2) = (X0) 
          =B3    0           INITIALIZE HEADER POINTER
  
 DDS81    SA2    X1+B3       FETCH CURRENT HEADER 
          SBIT   X2,DC.LINKP
          PL     X2,DDS82    IF NO CHAIN, THIS GROUP
          LX2    DC.LINKL+DC.LINKP-DC.PTRP
          SB3    X2          EXTRACT POINTER TO NEXT HEADER 
          ERRNZ  18-DC.PTRL 
          EQ     DDS81
  
 DDS82    LX2    DC.LINKL+DC.LINKP
          IX7    X0+X2
          SX3    BT=MXWC
          IX3    X3-X7
          PL     X3,DDS83    IF ROOM IN GROUP FOR THIS ENTRY
          SA3    A1+N.TABLE 
          CLAS=  X7,DC,(LINK) 
          LX3    DC.PTRP     LINK TO NEW GROUP HEADER 
          BX7    X7+X2
          BX7    X7+X3
          SA7    A2          UPDATE HEADER
          BX6    X0          CURRENT COUNT WILL BE NEXT HEADER
          ADDWD  A1          ADD NEW HEADER 
          SX0    B2          RESTORE COUNT
          EQ     DDS84
  
 DDS83    SA7    A2          UPDATE HEADER
  
 DDS84    ALLOC  A1,X0
          SX3    B7-B2       FWATO = LWA(TABLE) - WCI 
          SA1    T.DATS 
          SX2    X1+B4       FWAFR = FWA(T.DATS) + IND
          MOVE   B2,X2,X3    COPY WCI WORDS FROM T.DATS TO TABLE
          SX0    B2          RESTORE (X0) 
  
 DDS85    SB4    B4+X0       IND = IND + WCI
          EQ     DDS10
  
*         FLUSH *PTEXT* AND *PTEXTR* TABLES.
  
 DDS90    RJ     DTX         FLUSH ANY PARTIAL TEXT 
          MX6    0
          ADDWD  T.PTXT      ADD DUMMY HEADER TO FLAG EOT 
          SA5    T.PTXT 
          RJ     OTC         OUTPUT TABLE TO BINARY 
          SHRINK T=PTXT,0 
          MX6    0
          ADDWD  T.PTXTR     ADD DUMMY HEADER TO FLAG EOT 
          SA5    T.PTXTR
          RJ     OTC         OUTPUT TABLE TO BINARY 
          SHRINK T=PTXTR,0
          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.
* 
*         5600 TABLES 
* 
*         5600 TABLE CONSISTS OF DIMENSION INFORMATION TABLE AND SYMBOL 
*         TABLE INFORMATION.
*         DIMENSION INFORMATION IS FORMATTED WAY AS NAMELIST RUN-TIME 
*         DIMENSION TABLE, THREE WORDS PER ENTRY. 
*         LOADER SYMBOL TABLE IS ALSO A THREE WORD ENTRY, FORMATTED AS
*         (WA., S2., S3.) 
* 
*         ENTRY  NONE 
*         CALLS  OTB,STX,ORD,FST
  
  
 DFD      SUBR   0
  
  
**        PROCESS 5700 (LINE NUMBER) TABLE. 
  
          SA1    WO.57
          SA5    T.LNT
          ZR     X1,DFD20    IF 5700 TABLE NOT REQUESTED
          SA0    BT.LSTN
          MX0    0           NO BT.LTB BIT FOR THIS 
          RJ     OTB         OUTPUT 5700 TABLE
  
*         OUTPUT 5600 (SYMBOL) TABLE. 
*         FIRST, DUMP DIMENSION INFORMATION.
  
 DFD20    SA5    WO.56
          ZR     X5,EXIT.    IF (5600) TABLE NOT REQUIRED 
          SA1    S=SA1       SA1ORD = (S=SA1) 
          SA2    T.SYM
          SB2    X1+WC.W
          LX3    X1,B1
          IX2    X2+X3       STINDS = 3 * SA1ORD
          ERRNZ  3-Z=SYM
          SA1    X2+B2       WCSA1 = T.SYM(STINDS) + WC.W 
          SA5    BT.LSYL
          MX0    -MO.PTYPL+1
          SA4    MOD
          MX7    -WC.RAL
          CLAS=  X3,BT,(DST)
          LX4    -MO.PTYPP-1
          LX1    -WC.RAP
          BX7    -X7*X1 
          LX7    BT.SA1P
          BX0    -X0*X4      PROG-UNIT TYPE = PTYP[MOD] / 2 
          BX7    X7+X3
          LX0    BT.TYP 
          BX6    X5+X0
          IX6    X6+X7
          SA6    A5+B1       (BT.LSYM) = (DST,TYP,SA1) [BT.]
          ERRNZ  BT.LSYL+1-BT.LSYM
          MX7    1           DUMP ALL DIM ENTRIES 
          LX7    1+DH.MATP
          RJ     ORD         COLLECT RUN-TIME DIM INFO IN SCRATCH TABLE 
          SA5    T.SCR
          SA0    BT.LSYM
          MX0    0           NO LTB BIT SET 
          RJ     OTB         OUTPUT TABLE TO BINARY 
  
  
**        FORM LOADER SYMBOL TABLE. 
*         IT IS ACCUMULATED IN A SRATCH TABLE (T.SCR) BEFORE DUMPED TO
*         BINARY IN CHUNKS OF (7777) WORDS. 
  
  
          ERRNZ  Z=SYM-BT=LSYML 
          SHRINK T=SCR,0
          SA1    BT.LSYM
          SA4    T=SYM
          CLAS=  X2,BT,(DST)
          BX6    -X2*X1 
          SA6    A1          DST[BT.LSYM] = 0 
          ALLOC  T.SCR,X4-Z=SYM 
          RJ     FST         FORM SYMBOL TABLE
  
*         DUMP SYMBOL TABLE TO BINARY.
  
          SA5    T.SCR
          SA0    BT.LSYM     (A0) -> HEADER WORD
          MX0    1
          LX0    1+BT.LTBP
          RJ     OTB
          EQ     EXIT.
  
 DIT      SPACE  4,10 
**        DIT - DUMP IDENTIFICATION 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*) 
* 
*         USES   ALL BUT *A0*.
*                (T.SCR) FOR BUILDING SOME SCRATCH TABLES.
*         CALLS  ALLOC(ALC), DLC, PIT, WLGO(WLF). 
  
  
 DIT      SUBR   0           ENTRY/EXIT...
          RJ     PIT         PUMPS OUT IDNT TABLE 
          SA3    MOD
          SBIT   X3,MO.BLKP 
          MI     X3,DIT10    IF BLOCK DATA
          RJ     DLC         DUMP LOADSET CONTROL 
  
**        PIDL - PROGRAM IDENTIFICATION AND LENGTH TABLE. 
*                ALSO CONTAINS THE LOCAL COMMON BLOCK TABLE.
  
 DIT10    SA2    T=BLKS 
          AX4    X2,B1
          ERRNZ  2-Z=BLKS 
          SHRINK T=SCR,0
          ALLOC  T.SCR,X4+1  ALLOCATE (T=BLKS/Z=BLKS)+1 WORDS FOR *PIDL*
          SA3    IDENT
          SA5    SUM.LBT
          SB7    X2          PLEN = LEN[T.SCR]
          LX4    BT.WCP 
          SA2    CO.DBPM
          =X7    BT=PIDL
          LX7    BT.CNP 
          LX2    1+BT.PMDTP  SET BT.PMDT BIT IF PMDMP REQUESTED 
          BX7    X7+X2
          BX6    X5+X3
          BX7    X7+X4
          SA7    X1          *PIDL* HEADER WORD 
          =A6    A7+1        *PIDL* PROGRAM NAME WORD 
          SA5    T.BLKS 
          =A4    X5+CA.W     CAI = (T.BLKS) + CA.W
          =B4    Z=BLKS 
          =B3    2           PIND = 2, (ACCOUNT FOR HEADER WORDS) 
          MX0    CA.BNAML 
          MX7    -CB.BLENL
  
*         PROCESS NEXT ENTRY OF T.BLKS. 
*         (A4) _ CAI
*         (X0) = CA.BNAM MASK 
*         (X1) = T.SCR
*         (X7) = CB.BLEN MASK 
*         (B3) = PIND 
*         (B4) = Z=BLKS 
*         (B7) = PLEN 
  
 DIT20    GE     B3,B7,DIT60 IF NO MORE BLOCKS
          SA4    A4+B4       CAI = NEXT CA ENTRY OF T.BLKS
          =A5    A4-CA.W+CB.W      CBI = CB ENTRY 
          BX4    X4*X0
          BX3    -X7*X5      BLENI = BLEN[CBI]
          MX6    -3 
          SBIT   X5,CB.LCMP 
          PL     X5,DIT50    IF NOT LCM/ECS 
  
*         ECS/LCM BLOCKS..  USE  LENGTH = BLENI/8 -- ROUNDED UP.
  
          BX5    -X6*X3      GRAB REMAINDER 
          AX3    3           BLENI = BLENI / 8
          ZR     X5,DIT40    IF DIVISION EXACT
          =X6    1
          IX3    X3+X6       BLENI = BLENI + 1
 DIT40    CLAS=  X5,BT,(TYP) POSITION ECS/LCM BIT 
          BX3    X3+X5
 DIT50    BX6    X4+X3
          SA6    X1+B3       T.SCR(PIND) = 42/NAME,1/TYPE,17/LENGTH 
          =B3    B3+1        PIND = PIND + 1
          EQ     DIT20
  
 DIT60    WLGO   X1,B7       OUTPUT *PIDL* TABLE
          SA3    MOD
          BX6    0
          SBIT   X3,MO.BLKP 
          SHRINK T=SCR,X6    REMOVE THE ALLOCATION
          MI     X3,EXIT.    IF  *BLOCKDATA*, EXIT... 
  
**        DUMP *ENTR* TABLE.
  
          SA5    T=ENT
          LX0    X5,B1
          SB5    X5          SAVE (B5) = LENGTH OF ENTRY POINT TABLE
          ALLOC  T.SCR,X0    ROOM TO BUILD THE *ENTR* TABLE 
          SA4    BT.ENTR
          =B7    X2+1        (B7) = LENGTH OF SCRATCH TABLE 
          LX2    BT.WCP 
          BX6    X4+X2
          SA3    T.SYM
          =X0    1
          SA5    T.ENT
          =B4    X3+WC.W     (B4) = FWA SYMTAB + WORD WC OFFSET 
          LX0    BT.RLP 
          SA6    X1          *ENTR* CONTROL WORD
          SA4    X5          (A4) = FWA ENTRY PTS.
  
 DIT70    SX5    X4          ISOLATE SYMORD 
          ERRNZ  EP.ORDP
          ERRNZ  EP.ORDL-18 
          LX2    X5,B1
          IX7    X5+X2
          ERRNZ  3-Z=SYM
          SA3    X7+B4       FETCH (X3) = SYMTAB WORD WC
          =B5    B5-1 
          BX7    X4-X5       ISOLATE NAME 
          ERRNZ  EP.NAMEL-42
          ERRNZ  EP.NAMEP-18
          LX3    -WC.RAP
          SX6    X3 
          =A7    A6+1 
          BX6    X0+X6       INDICATE PROGRAM-RELATIVE ADDRESS
          =A4    A4+1 
          =A6    A7+1 
          NZ     B5,DIT70    IF MORE ENTRY POINTS 
  
          WLGO   X1,B7
          SHRINK T=SCR       REMOVE THE ALLOCATION
          EQ     EXIT.
 DLC      SPACE  4,10 
**        DLC - DUMP LOADSET CONTROL. 
* 
*         WRITES LDSET HEADER AND DIRECTIVES FOR -- 
*                (A)  LIB=
*                (B)  COMMON=      FOR SAVE STATEMENT 
*                (C)  PRESET= + MAP=     FOR POST-MORTEM DUMP.
*         LDSET(COMMON=BLK1/.../BLKN) FOR EACH COMMON BLOCK 
*                (AND SPECIAL LOCAL BLOCK S$A$V$E) ASSOCIATED WITH SAVE.
*                IF UNIVERSAL SAVE IS ON, OUTPUT *LDSET COMMON (ALL)* 
*                ONLY.
* 
*         EXIT   LDSET DIRECTIVES DUMPED TO BINARY. 
* 
*         USES   ALL. 
*                (T.SCR)
*         CALLS  ALLOC, WLF 
  
  
 DLC      SUBR               ENTRY/EXIT...
  
*         FIRST, ALLOCATE (T.SCR) WITH (MORE THAN) ENOUGH ROOM TO 
*         BUILD ALL THE LDSET DIRECTIVES. 
*                = 1 + (BT.LIBL) + (T=BLKS)/2 + (BT.DBPML)
*         KEEPS  (A6) -> LAST OCCUPIED WORD.
*                (B6) -> T.SCR
  
          SA2    T=BLKS 
          BX6    0
          AX7    X2,B1
          ERRNZ  2-Z=BLKS 
          SHRINK T=SCR,X6 
          SB5    X7          CLEN = LEN(T.BLKS) / Z=BLKS
          SX0    X7+1+BT.DBPML+BT.LIBL
          ALLOC  T.SCR,X0    ALLOCATE ENOUGH WORDS FOR IT 
          SB6    X1 
  
          SA2    BT.LIB 
          BX6    X2 
          SA6    X1+B1       MOVE *LDSET(LIB=...)* INTO TABLE 
 .1       DUP    BT.LIBL-1
          SA2    A2+B1
          BX6    X2 
          SA6    A6+B1
 .1       ENDD
  
  
*         CONSTRUCT *LDSET(COMMON) SUB-DIRECTIVE. 
  
          SA4    USAVE
          SA5    SAVE 
          BX6    X4+X5
          ZR     X6,DLC40    IF NO SAVE DECLARATIONS
          SA6    A6+B1       SPACE OVER (BT.CMN) SUB-HEADER 
          SB2    A6          (B2) = FWA COMMON SEGMENT
          NZ     X4,DLC30    IF UNIVERSAL SAVE
  
*         EXPLICIT SAVE... FOR EACH COMMON BLOCK, CBI, WHICH HAS
*         SAVE[CBI] = 1, ADD NAME[CBI] TO (T.SCR).
  
          SA5    T.BLKS 
          =A4    X5+CB.W     CBI = FWA(T.BLKS) + CB.W 
          =B4    Z=BLKS 
          SB5    B5-B1       FIRST ENTRY IN T.BLKS IS NOT USED. 
          MX0    CA.BNAML 
  
*         PROCESS NEXT ENTRY OF T.BLKS. 
*                (A4) -> CBI
*                (A6) -> LAST OCCUPIED WORD 
*                (X0) = CA.BNAM MASK
*                (B4) = Z=BLKS
*                (B5) = CLEN
  
 DLC20    SA4    A4+B4       CBI = NEXT CB ENTRY OF T.BLKS
          =A2    A4-CB.W+CA.W      CAI = CA ENTRY 
          SB5    B5-B1
          HX4    CB.SAVE
          BX6    X0*X2       NAME = BNAM[CAI] 
          PL     X4,DLC28    IF NOT SAVE[CBI] 
          SA6    A6+B1
 DLC28    GT     B5,DLC20    IF MORE BLOCKS TO EXAMINE
  
 DLC30    SX2    BT=CMN 
          SX6    A6-B2       (X6) = NUMBER OF EXPLICIT BLOCKS ADDED 
          LX2    BT.CNP 
          LX6    BT.WCP 
          BX7    X6+X2       ADD IN WC TO HEADER WORD 
          SA7    B2 
  
*         OUTPUT *LDSET PREST* AND *LDSET MAP* DIRECTIVES FOR PMDMP.
  
 DLC40    SA4    CO.DBPM
          ZR     X4,DLC60    IF POST MORTEM DUMP NOT REQUESTED
          SB2    BT.DBPML 
          SA4    BT.DBPM
 DLC45    BX6    X4          MOVE PMD WORD INTO (T.SCR) 
          SB2    B2-B1
          SA6    A6+B1
          SA4    A4+B1
          GT     B2,DLC45    IF MORE PMD STUFF TO MOVE
  
*         ALL NECESSARY DIRECTIVES IN PLACE.  COMPUTE LENGTH, 
*         MANUFACTURE HEADING, AND WRITE OUT THE LOADER TABLE.
  
 DLC60    SX2    A6-B6       (X2) = LWA - FWA = WORDS, EXCLUDING HEADER 
          SX3    BT=LDSET 
          SB7    X2+B1       (B7) = W.C., INCLUDING HEADER
          LX2    BT.WCP 
          LX3    BT.CNP 
          BX7    X2+X3
          SA7    B6 
          WLGO   B6,B7       WRITE LOADSET DIRECTIVES 
          SHRINK T=SCR,0
          EQ     EXIT.
 DLF      SPACE  4,30 
**        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. 
*         BASIC IDEA STOLEN FROM *DLAST* IN *COMPASS VER 2.0*.
*         CALLS  SRT, WLF.
* 
*         KEEPS  A0 
  
  
 DLF      SUBR   =           ENTRY/EXIT...
  
*         PROCESS *LINK* TABLE. 
  
 SNAP=K   IFNE   TEST        DUMP *LINK* TABLE
          SA3    CO.SNAP
          LX3    1RK
          PL     X3,DLF10S   IF LINK TABLE SNAP NOT SELECTED
          DUMPT  LINK 
 DLF10S   BSS    0
 SNAP=K   ENDIF 
  
          SX6    A0 
          SA6    DLFA        PRESERVE A0
          SA2    T=LINK 
          SA1    T.LINK 
          SA3    NREXT
          IX4    X1+X3
          IX1    X2-X3       (X1) = LENGTH FOR SORT 
          ZR     X1,DLF60    IF NO EXTERNALS
          MI     X1,"BLOWUP" IF NREXT .LT. (T=LINK) 
          SB7    X4          (B7) = FWA FOR SORT
          CALL   SST         SHELL SORT TABLE 
  
          SA1    T.LINK 
          SA2    T=LINK 
          SA3    T.SYM
          SA4    NREXT
          IX5    X2-X4       LINK LENGTH
          SA0    X3          A0 = FWA NAME TAB
          IX0    X1+X4
          SB7    X5          B7 = (LEN LINK)
          SA5    X0 
          SB4    X1          (B4) = FWA PHYSICAL TABLE
          SB6    30 
          SA6    X1          PRESET STORE ADDR
          MX1    WA.SYML
          MX0    30 
          SB5    -B1
          SB2    -B1
  
 DLF10    AX2    X5,B6       ISOLATE EXT NO 
          SB3    X2 
          SB2    B2+B1
          BX7    -X0*X5      ISOLATE 30/OUTPUT STUFF
          EQ     B3,B5,DLF30 IF SAME AS LAST EXT
          SA3    B3+A0       FETCH EXT NAME 
          SB5    B3 
          LX6    30 
          ZR     B2,DLF20    IF NO HANGING HALF-WORD
          SA6    A6+B1
 DLF20    BX6    X1*X3       ISOLATE NAME 
          SB2    B0 
          SA6    A6+B1       STORE NEW NAME 
          BX6    0
 DLF30    SB7    B7-B1
          LX4    X6,B6
          BX6    X7+X4
          SA5    A5+B1
          ZR     B2,DLF40    IF LOWER BYTE
          SA6    A6+B1
          SB2    -B1
          BX6    0
 DLF40    NZ     B7,DLF10    IF TABLE NOT EXHAUSTED 
          LX6    30 
          MI     B2,DLF50    IF NO HANGING HALF-WORD
          SA6    A6+B1
 DLF50    SX7    A6-B4       RESULTANT SIZE OF LINK TABLE 
          SA1    T.LINK 
          =B7    X7+1 
          SX4    BT=LINK
          LX7    BT.WCP 
          SB6    X1 
          LX4    BT.CNP 
          BX6    X4+X7       FORM *LINK* CONTROL WORD 
          SA6    B6 
          WLGO   B6,B7       WRITE OUT THE LINK TABLE 
  
 DLF60    SA1    NREXT
          SHRINK T=LINK,X1
  
*         PROCESS *FILL* TABLE. 
  
          SA1    T=FILL 
          SA2    T.FILL 
          SB6    X1 
          BX6    0
          EQ     B6,B1,DLF120      IF EMPTY FILL TABLE
          SB7    X2          ZERO THE DUMMY WORD SO SORT WONT MOVE IT 
          SA6    X2 
          CALL   SST
  
          SA1    T.FILL 
          SA2    T=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
  
 DLF70    BX6    X6+X3
          SB5    30 
          SA6    A6+B1
 DLF80    GE     B3,B4,DLF100      IF TABLE EXHAUSTED 
          AX2    X1,B2
          SB3    B3+B1
          BX4    X7-X2
          ZR     X4,DLF90    IF SAME BLOCK AS PREVIOUS
          SB3    B3-B1       SET TO RE-PROCESS LAST ENTRY 
          BX1    X2 
          LX7    X2 
  
 DLF90    BX3    -X0*X1      ISOLATE FILL BYTE
          SA1    B3 
          ZR     B5,DLF70    IF LOWER 
          LX6    X3,B2
          SB5    B2-B5       INDICATE NEXT IS LOWER 
          EQ     DLF80
  
 DLF100   NZ     B5,DLF110
          SA6    A6+B1       STORE HANGING HALF-WORD
 DLF110   SX4    BT=FILL
          SX3    A6-B6
          LX4    BT.CNP 
          =B7    X3+1 
          LX3    BT.WCP 
          BX6    X4+X3       MANUFACTURE CONTROL WORD 
          SA6    B6 
          WLGO   B6,B7
  
*         PROCESS *XFILL* TABLE 
  
 DLF120   SA2    T=XFIL 
          SA1    T.XFIL 
          SB7    X2 
          SB6    X1          B6 = FWA TABLE 
          EQ     B7,B1,DLF130      IF EMPTY *XFILL* TABLE, EXIT...
          SX4    BT=XFILL 
          SX3    B7-B1
          LX4    BT.CNP 
          LX3    BT.WCP 
          BX6    X4+X3       MANUFACTURE CONTROL WORD 
          SA6    B6 
  
 SNAP=X   IFNE   TEST        DUMPT *XFILL* TABLE
          SA3    CO.SNAP
          LX3    1RX
          PL     X3,DLF120S 
          DUMPT  XFIL 
 DLF120S  BSS    0
 SNAP=X   ENDIF 
  
          WLGO   B6,B7
          SHRINK T=XFIL,1 
 DLF130   SA1    DLFA 
          SA0    X1          RESTORE A0 
          EQ     EXIT.
  
 DLFA     BSS    1           PRESERVE A0 HERE 
 DTX      SPACE  4,30 
**        DTX -  DUMP *TEXT* TABLE. 
* 
*         IF TABLE IS EMPTY, NO WRITE WILL TAKE PLACE, BUT THE TABLE
*         WILL BE RESET TO INDICATE *EMPTY* AND (ORG).
* 
*         DTX CANNOT MOVE TABLES. 
* 
*         USES   A1-A4,A6,A7  B2,B3,B5-B7 
*         CALLS  WLF. 
  
  
 DTX      SUBR               ENTRY/EXIT...
          SA1    BT.TXWC
          SX7    X1-15
          SX6    BT=XTEXT 
          ZR     X1,DTX10    IF EMPTY TABLE AVOID.. 
          =A3    A1+1 
          LX7    2
          SA2    A3+B1       BT.TXRB WORD 
          SX1    X1+B1
          LX6    BT.CNP 
          SB7    X1+B1
          SB3    X7          SHIFT FOR PARTIAL TABLE RELOC BYTES
          LX1    BT.WCP 
          BX3    X6+X3
          SB6    A3 
          IX6    X3+X1
          AX7    X2,B3
          SA6    A3 
          SA7    A2 
          WLGO   B6,B7
 DTX10    SA1    ORG
          =X2    1
          BX7    0
          LX2    BT.RLXP
          SA7    BT.TXRB
          IX6    X1+X2       ADJUST INTERNAL BLOCK ORDINAL TO LOADER
*                            BLOCK NUMBER 
          SA6    A7-B1
          SA7    A6-B1
          EQ     EXIT.
 ESL      SPACE  4,10 
**        ESL -  ENTER STMT LABEL IN 57 TABLE 
* 
*         ENTRY  (A5) _ PB INSTRUCTION
* 
*         CALLS  DXB
* 
*         USES   X - ALL  A - 1,2,3,6  B - 2,3,4,5,7
  
 ESL      SUBR   =           ...ENTRY/EXIT... 
 ESL.EQ   BSSENT 0
          SA5    A5          X5 = PB INSTRUCTION
          BX1    X5 
          MX0    -PB.PFXL 
          LX1    -PB.PFXP 
          BX0    -X0*X1      ISOLATE TAG PREFIX 
          NZ     X0,EXIT.    IF NOT SYMTAB TAG
          SA2    T.SYM
          LX1    PB.PFXP-PB.ORDP
          MX0    -PB.ORDL 
          BX1    -X0*X1      ISOLATE SYMTAB *WB* ORDINAL
          SB4    X1 
          LX1    1
          SB4    X1+B4       CONVERT TO INDEX 
          ERRNZ  3-Z=SYM
          =B4    B4-WA.W+WB.W 
          SA2    X2+B4       *WB* OF POSSIBLE LABEL 
          CLAS=  X1,WB,(CGS)
          BX1    X1*X2
          CLAS=  X3,WB,(LAB,SDEF) 
          BX4    X3*X2
          BX3    X4-X3
          BX1    X1+X3
          NZ     X1,EXIT.    IF NOT A LABEL 
          =A2    A2-WB.W+WA.W      *WA* 
          MX0    -WA.STLL 
          LX2    -WA.STLP 
          BX2    -X0*X2      ISOLATE STMT LABEL 
          LX2    -CHAR       RIGHT JUSTIFY
          MX0    CHAR 
 ESL10    LX2    -CHAR
          BX3    X0*X2
          NZ     X3,ESL10    IF MORE OF THE LABEL 
          LX2    CHAR        LEFT JUSTIFY 
          BX5    X2 
          =B7    1           DECIMAL BASE ASSUMED 
          CALL   DXB         CONVERT TO BINARY
          IFEQ   TEST,ON,1
          NZ     X4,"BLOWUP" IF ERROR IN CONVERSION 
          SA1    T.LNT
          SA3    T=LNT
          IX1    X1+X3
          =X1    X1-1        X1 = ADDRESS OF LAST T.LNT ENTRY 
          SA1    X1 
          LX6    LN.LABP
          BX6    X1+X6
          SA6    A1          FILL IN LABEL FIELD
          EQ     EXIT.
 FBP      SPACE  4,10 
**        FBP -  FORMAT BINARY AND PRINT. 
* 
*         ENTRY  (X0) = BINARY WORD TO BE FORMATTED.
*                (OL=PB) = PRE-BINARY INSTRUCTION FOR OBJECT LIST.
* 
*         EXIT   (LINBUF+1 .. +2) = FORMATTED BINARY. 
* 
*         CALLS  POL, WOD.
  
  
 FBP      SUBR   =
*         EQ     EXIT.
 FBP.EQ   BSSENT 0
          BX1    X0 
          CALL   WOD         CONVERT BINARY TO DPC
          SA5    OL=PB
          SA6    LINEBUF+1
          =A7    A6+1 
          RJ     POL         PRINT OBJECT LISTING 
          EQ     EXIT.
 FLA      SPACE  4,10 
**        FLA - FORMAT LABELS ASSIGNED. 
* 
*         ENTRY  (X4) = LENGTH OF (T.LA). 
* 
*         EXIT   ............ 
  
  
 FLA      SUBR   0           ENTRY/EXIT...
          SA1    T.LA 
          SA5    X1          FETCH (X5) = FIRST TABLE ENTRY 
          SA0    X4          (A0) = NUMBER OF ASSIGN-ED LABELS
          SHRINK A4 
 FLA2     SA3    T.SYM
          LX1    X5,B1
          =B7    X3+WB.W
          MX7    1
          IX6    X1+X5       (X6) = INDEX OF LABEL SYMTAB ENTRY 
          SA4    X6+B7
          MX0    -WC.RAL
          =A3    A4-WB.W+WC.W 
          HX4    WB.SDEF
          LX3    -WC.RAP
          BX4    X7*X4       (X4) = (WB.SDEF) BIT IN SIGN 
          BX6    -X0*X3      (X6) = UNRELOCATED ADDRESS OF LABEL
          BX1    X4+X6
          MX2    0           INDICATE NO RELOCATION 
          RJ     STX         STORE WORD IN TEXT TABLE 
          RJ     POL         PRINT OBJECT LISTING 
          SB4    A0-B1
          SA5    A5+1 
          SA0    A0-B1       DECREMENT UNPROCESSED LENGTH 
          GT     B4,FLA2     IF MORE LABELS TO DO 
          EQ     EXIT.
 S2.      SPACE  4,30 
**        BINARY OUTPUT LOADER SYMBOL TABLE DEFINITIONS.
* 
*         WORD ONE -  WA. FORMAT. 
*         WORD TWO -  S2. FORMAT. 
*         WORD THREE - S3. FORMAT.
  
          DESCRIBE S2.,60,,WB.W 
          DEFINE 12          0
 PNT      DEFINE 12          DIMENSION OFFSET 
 ARY      DEFINE 1           ARRAY
          DEFINE 11 
 SUB      DEFINE             SUBROUTINE 
 NLST     DEFINE             NAMELIST GROUP NAME
 ENT      DEFINE             ENTRY POINT
 PARM     DEFINE             SYMBOLIC CONSTANT
 1REF     DEFINE             STRAY NAME 
 MAT      DEFINE             VARIABLE MATERIALIZED
 LAB      DEFINE 1           THIS ENTRY IS LABEL
 DEF      DEFINE 1           DEFINED
 EQV      DEFINE 1           MEMBER OF EQUIVALENCE CLASS
 FUN      DEFINE 1           USED AS FUNCTION 
 EXT      DEFINE 1           EXTERNAL SYMBOL
 CGS      DEFINE 1           COMPILER GENERATED SYMBOL
 FP       DEFINE 1           FORMAL PARAMETER 
 LEV      DEFINE 1           LEVEL 0 AND LCM
 LCM      DEFINE 1           VARIABLE RESIDES IN ECS/LCM
 TYP      DEFINE 6           VARIABLE TYPE
 SIZ      DEFINE 3           LENGTH - 3 OF SYMBOL ENTRY 
  
          DESCRIBE S3.,60,,WC.W 
          DEFINE 3
 RB       DEFINE 9           LOADER BLOCK NUMBER
 CL       DEFINE 1           CONSTANT LENGTH BIT
 CLEN     DEFINE 17          CHARACTER LENGTH 
          DEFINE 2
 BCP      DEFINE 4           BEGINNING CHARACTER POSITION 
 RA       DEFINE 24          RELATIVE ADDRESS FIELD 
 FST      SPACE  4,10 
**        FST - FORMAT SYMBOL TABLE.
* 
*         RE-FORMAT AND COPY COMPILER SYMBOL TABLE (T.SYM) INTO 
*         SCRATCH AREA (T.SCR), IN PREPARATION FOR 5600 TABLE 
*         GENERATION. 
* 
*         ENTRY  (SAVVD) = ADDRESS (WC.RA) OF *VD.*.
* 
*         EXIT   (T.SCR) = CID/PMD FORMAT SYMBOL TABLE
*                (T.DIM) = [DH.RA] HAS CID/PMD OFFSETS
* 
*         USES   ALL. 
*         CALLS  ADA, CAB.
  
  
 FST      SUBR   0           ENTRY/EXIT...
          SX7    B1          CID WANTS 1-ORIGIN 
          MX4    1           COUNT ALL DIM ENTRIES
          CALL   ADA         ASSIGN DIM-TABLE ADDRESSES 
          SA1    T.SCR
          SA2    T.SYM
          SA3    T=SYM
          SB6    X3          SYMLEN = LEN(T.SYM)
          SB4    X1-Z=SYM+WB.W     STOAD = FWA(T.SCR) - Z=SYM + WB.W
          =B3    Z=SYM
          =A5    X2+WB.W     SKIP FIRST ENTRY 
  
*         (A5) _ LAST WB. ENTRY.
*         (B4) _ LAST T.SCR ENTRY TO STORE INTO 
*         (B3) = Z=SYM
*         (B6) = SYMLEN 
  
 FST10    SA5    A5+B3       WBI = WB ENTRY OF T.SYM
          SB6    B6-B3       SYMLEN = SYMLEN - Z=SYM
          MX0    WA.SYML
          LE     B6,EXIT.    IF END OF (T.SYM)
          BX4    X5 
          HX4    WB.LAB 
          MI     X4,FST80    IF LABEL 
          SB4    B4+B3       STAD = STAD + Z=SYM
          LX0    WA.SYML+WA.SYMP
          =A4    A5-WB.W+WA.W      WAI = WA ENTRY OF T.SYM
          BX7    X0*X4
          =A7    B4-S2.W+WA.W      T.SCR(STAD-1) = SYM[WAI] 
  
*         CONSTRUCT S2. ENTRY OF (5600) TABLE.
  
          SA1    FSTA 
          MX2    0           S2W = 0
          RJ     CAB         COPY ADJUSTED BITS 
  
*         TRANSFORM (WB.MODE) VIA CID MODE VECTOR.
*         TRANSFORM (WB.PNT) PER ADA, SINCE DIM ENTRIES ARE SHRUNK
*                FOR 5600 TABLE OUTPUT. 
*         SET LEV[S2.] = 1 IF LCM .AND. LEVEL 0.
*         (X2) = S2. BUILD WORD 
  
          BX4    X5 
          BX3    X5 
          HX3    WB.VAR 
          AX3    59 
          LX5    -WB.MODEP
          LX4    -WB.PNTP 
          MX0    -WB.MODEL
          MX6    -WB.PNTL 
          BX0    -X0*X5      MODEI = MODE[WBI]
          SA1    T.DIM
          BX6    -X6*X4      DHI = PNT[WBI] 
          BX6    X3*X6       ZERO IF NOT VARIABLE 
          SB2    X1 
          SA3    X6+B2       FETCH DIM HEADER 
          MX1    -DH.RAL
          LX3    -DH.RAP
          BX1    -X1*X3      PNTI = RA[DHI] 
          SB5    X0          REMEMBER (B5) = MODEI
          LX1    S2.PNTP
          BX2    X2+X1
          LX4    WB.PNTP-1-WB.LEVP
          SA3    CIDMOD 
          MX6    -4 
          LX0    2
          SB7    X0 
          AX3    B7 
          BX3    -X6*X3 
          LX3    S2.TYPP
          BX6    X2+X3
          LX5    WB.MODEP-1-WB.LCMP 
          PL     X4,FST30    IF NOT LEVELED 
          MX0    -WB.LEVNL
          LX4    1+WB.LEVP-WB.LEVNP 
          BX1    X5 
          AX1    59          SIGN EXTEND LCM BIT
          BX7    -X0*X4      LEVNOI = LEVN[WBI] 
          BX1    -X1         = 0 IF LCM / (-0) IF NOT 
          BX1    X7+X1       = LEVNOI .OR. 0 / LEVNOI .OR. (-0) 
          NZ     X1,FST30    IF NOT (LCM) .AND. (LEVEL 0) 
          CLAS=  X3,S2,(LEV)
          BX6    X6+X3
 FST30    SA6    B4          T.SCR(STAD) = [S2.]
  
*         CONSTRUCT S3. WORD. 
*         DETERMINE LOADER RB FROM RB[WC.]. 
*         COPY CLEN[WC.] AND BCP[WC.] IF NOT F.P. . 
*         (B5) = MODEI
  
          =A4    A5-WB.W+WC.W      WCI = WC ENTRY OF T.SYM
          SBIT   X5,WB.FPP/WB.LCMP
          MX2    0
          BX6    X2 
          SA6    FSTB        FLAG NOT FP
          MI     X5,FST70    IF FP
  
 FST40    LX4    -WC.RBP
          LX5    WB.FPP-WB.COMP 
          PL     X5,FST50    IF NOT COMMON
          MX0    -WC.RBL
          BX6    -X0*X4      RBI = RB[WCI]
          ERRNZ  2-Z=BLKS 
          AX6    1           RBI = RBI / Z=BLKS 
          =X2    X6+1        RBI = RBI + 1
  
 FST50    =X2    X2+1        RBI = RBI + 1
          LX2    S3.RBP 
          SB5    B5-M.CHAR
          MX6    -WC.BCPL 
          NZ     B5,FST60    IF NOT TYPE CHARACTER
          LX4    WC.RBP-WC.BCPP 
          BX1    -X6*X4      BCPI = BCP[WCI]
          BX7    X4 
          MX3    -WC.CLENL
          LX4    WC.BCPP-WC.CLENP 
          LX1    S3.BCPP
          BX2    X1+X2
          BX6    -X3*X4      CLENI = CLEN[WCI]
          =X0    1
          LX7    WC.BCPP-WC.CTYPP 
          BX7    X0*X7       CTYPI = CTYP[WCI]
          BX0    X0-X7       =1 IFF CTYPI .EQ. 0
          LX6    S3.CLENP 
          LX0    S3.CLP 
          BX6    X6+X0
          BX2    X2+X6
          ZR     X7,FST60    IF CTYP[WCI] .EQ. 0
          SA1    SAVVD       RA OF *VD.* = (SAVVD)
          MX0    -S3.CLENL
          BX1    -X0*X1      RAVD = RA[WCV], TRUNCATED TO S3.CLENL
          LX1    S3.CLENP 
          IX2    X2+X1       CLEN[S3.] = CLEN[S3.] + RAVD 
  
*         COPY RA[WC.] TO RA[S3.].
*         (X2) = S3. BUILD WORD 
  
 FST60    SA4    FSTB 
          ZR     X4,FST65    IF NOT DUMMY ARGUMENT
  
*         FOR DUMMY ARGUMENTS, RA[S3.] = FPNO[WBI]-1
  
          =X7    1
          IX6    X4-X7       FPNO[WBI]-1
          LX6    S3.RAP 
          BX6    X2+X6
          =A6    B4-WB.W+WC.W 
          EQ     FST10
  
 FST65    MX7    -WC.RAL
          =A4    A5-WB.W+WC.W 
          AX4    WC.RAP 
          BX6    -X7*X4      RAI = RA[WCI]
          LX6    S3.RAP 
          BX6    X2+X6
          =A6    B4-WB.W+WC.W      T.SCR(STAD+1)= (BCP,CLEN,CL,RA) [S3.]
          EQ     FST10
  
 FST70    MX0    -WB.FPNOL
          BX6    X5 
          LX6    1+WB.FPP-WB.FPNOP
          BX6    -X0*X6      FPNOI = FPNO[WBI]
          LX6    S3.RAP 
          SA6    FSTB        FLAG FP
          EQ     FST40
  
 FST80    SA4    T=SCR
          SX6    X4-Z=SYM 
          SA6    A4+         DECREMENT 5600 TABLE LENGTH FOR LABEL
          EQ     FST10
  
          LIST   G           **** DEBUG ****
 FSTA     CABS   WB,S2,(SUB,SDEF/DEF,EQV,FUN,EXT,CGS,FP,LCM,ARY,MAT,NLST
,,ENT,PARM,1REF)
  
 FSTB     BSS    1           DUMMY ARGUMENT FLAG
          LIST   *
 KAP      SPACE  4,30 
**        KAP -  COMPILE AP-LISTS.
* 
*         RELOCATES AND RE-FORMATS *T.APL* INTO BINARY LOADER TEXT. 
*         USES   ALL
*         CALLS  DTX, REL, STX. 
  
  
 KAP      SUBR   0           ENTRY/EXIT.
          BX6    0
          SA6    BINWORD     (BINWORD) = 0
          SA6    A6+B1       (BINREL) = 0 
          SX7    IA.BIASP-PB.BIASP
          MX6    -IA.BIASL
          SA7    RELPOS 
          SA6    RELMASK
          SA2    T=APL
          ALLOC  T.PTXTR,X2 
          RJ     DTX         RESET TEXT TABLE 
          MX6    0
          SA0    X6          STOIND = 0 
          SA6    KAPA        (KAPA) = IND = 0 
  
*         A0 -> NEXT STORE INDEX INTO SCRATCH TABLE (T.PTXTR) FOR 
*         OBJECT LISTING. 
  
 KAP10    SA4    T=APL
          SA2    T.APL
          SA1    KAPA        IND = (KAPA) 
          IX6    X4-X1       = LEN(T.APL) - IND 
          ZR     X6,EXIT.    IF END OF T.APL
 .T       IFEQ   TEST,ON,1
          MI     X6,"BLOWUP" IF SOMETHING HORRIBLE
          =X7    X1+1 
          IX2    X2+X1
          SA7    A1          (KAPA) = IND + 1 
          SA1    X2          API = T.APL(IND) 
          =X2    0           INDICATE NO RELOCATION 
          BX5    X1 
          ZR     X1,KAP50    IF +/- 0 
          BX4    X1 
          MX0    -IA.BIASL
          MX3    -IA.TAGL 
          HX1    IA.CRH 
          LX4    -IA.TAGP 
          BX3    -X3*X4      TAGI = TAG[API]
          LX4    IA.TAGP-IA.BIASP 
          BX6    -X0*X4      BIASI = BIAS[API]
          MI     X1,KAP80    IF RELATIONAL HEADER 
  
*         SET TYP[OA.] = MODE[API], AND LCM[OA.] = LCM[WBI].
  
          MX7    -IA.MODEL
          LX4    IA.BIASP-IA.MODEP
          BX7    -X7*X4      TYPE = MODE[API] 
          SA2    COMMOD 
          LX7    2
          MX4    -4 
          SB7    X7 
          AX2    B7 
          BX7    -X4*X2 
          LX7    OA.TYPP
          SA7    BINWORD     TYP[BINWORD] = TYPE
  
          MX2    0           FPI = 0
          MX4    -PB.ORDL 
          BX4    X4*X3       PFXI = PFX[TAGI] 
          ERRNZ  K=SYM
          NZ     X4,KAP12    IF PFXI .NE. K=SYM 
          SA2    T.SYM
          LX7    X3,B1
          IX4    X7+X3       STIND = 3 * TAGI 
          ERRNZ  3-Z=SYM
          IX2    X2+X4
          =A2    X2+WB.W     WBI = T.SYM(STIND) + WB.W
          CLAS=  X4,WB,(LCM)
          BX7    X4*X2       LCMI = LCM[WBI]
          HX2    WB.LAB 
          BX4    X2 
          LX2    WB.LABP-WB.FPP 
          MI     X4,KAP14    IF LABEL 
          SA4    A7          BINWORD
          LX7    OA.LCMP-WB.LCMP
          BX7    X7+X4
          SA7    A4          LCM[BINWORD] = LCMI
  
*         FOR TAGI = *S=RD*, REPLACE BIAS[API] BY 
*                RA[T.DIM(BIASI) + DH.W] BEFORE RELOCATION. 
  
          SA4    S=RD 
          IX4    X4-X3
          MX0    -IA.BIASL
          NZ     X4,KAP15    IF TAGI .NE. S=RD
          SA3    T.DIM
          =B3    X3          +DH.W
          SA4    X6+B3       DHI = T.DIM(BIASI) + DH.W
          LX5    -IA.BIASP
          BX5    X0*X5       CLEAR BIAS FIELD 
          LX4    -DH.RAP
          BX0    -X0*X4      BIASI = RA[DHI], TRUNCATED TO IA.BIASL 
          BX5    X5+X0       BIAS[API] = BIASI
          LX5    IA.BIASP 
          EQ     KAP15
  
 KAP12    SX4    X4-K.GL
          NZ     X4,KAP15    IF NOT GENERATED LABEL 
  
 KAP14    SA4    LABMOD 
          LX4    OA.TYPP
          BX7    X4 
          SA7    BINWORD     TYPE[APLIST] = LABMOD
          EQ     KAP20
  
 KAP15    BX4    X1 
          LX1    IA.CRHP-IA.STP 
          LX4    IA.CRHP-IA.CHARP 
          MI     X1,KAP25    IF ST
          PL     X4,KAP20    IF NON CHARACTER 
  
  
**        HANDLE CHARACTER APLIST HERE. 
* 
*         IF NOT FP, COPY (CLEN, BCP) FROM T.CAC(BIASI) ENTRY 
*         AND REPLACE BIAS[IO1] WITH RA [T.CAC(BIASI)] BEFORE 
*         RELOCATION. 
*         (X6) = BIASI
  
  
          MI     X2,KAP40    IF F.P.
          MX0    -IA.BIASL
          SA3    T.CAC
          MX1    -WC.BCPL 
          MX7    -WC.CLENL
          SB3    X3 
          LX5    -IA.BIASP
          BX5    X0*X5       CLEAR BIAS FIELD 
          SA3    X6+B3       CACI = T.CAC(BIASI)
          BX2    X3 
          LX3    -WC.RAP
          LX2    -WC.BCPP 
          BX4    -X0*X3      BIASI = RA[CACI], TRUNCATED TO IA.BIASL
          BX5    X5+X4       REPLACE BIAS FIELD 
          BX1    -X1*X2      BCPI = BCP[CACI] 
          LX5    IA.BIASP 
          LX2    WC.BCPP-WC.CLENP 
          BX0    -X7*X2      CLENI = CLEN[CACI] 
          LX1    OA.BCPP
          SA3    BINWORD
          LX0    OA.LENP
          BX4    X1+X0
          BX6    X3+X4
          SA6    A3          (LEN,BCP) [BINWORD] = (CLENI,BCPI) [OA.] 
  
*         RELOCATE THE ADDRESS. 
  
 KAP20    =B2    1           INDICATE LOWER ADDRESS RELOCATION
          MX0    PB.GHIJL 
          LX5    PB.TAGP-IA.TAGP
          BX5    -X0*X5      CLEAR (GHIJ) FIELD 
          RJ     REL         RELOCATE THE ADDRESS 
 KAP25    SA2    BINREL 
          SA1    BINWORD
          EQ     KAP50
  
  
**        FOR CHARACTER FP ITEMS, SET ARG[OA.] = FPNO[WBI] - 1, 
*         SUBS[OA.] = BIAS[API], AND FP[OA.] = 1. 
* 
*         (X2) = WBI, HIGH SHIFTED TO WB.FP 
*         (X6) = BIAS[API]
  
 KAP40    MX7    -WB.FPNOL
          MX3    1
          BX3    X3*X2       FPI = FP[WBI]
          LX2    1+WB.FPP-WB.FPNOP
          LX3    1+OA.FPP 
          BX7    -X7*X2      FPNOI = FPNO[WBI]
          MX4    -OA.SUBSL
          BX6    -X4*X6 
          ERRMI  IA.BIASL-OA.SUBSL
          LX6    OA.SUBSP 
          BX6    X6+X3       ADD IN FP BIT
          SA4    BINWORD
          =X7    X7-1        FPNOI = FPNOI - 1
          LX7    OA.ARGP
          BX1    X6+X7
          BX1    X1+X4
          =X2    0           INDICATE NO RELOCATION 
 KAP50    BX6    X1 
          SB3    A0 
          SA3    T.PTXTR
          SA6    X3+B3       T.PTXTR(STOIND) = BINARY EQUIVALENT
          =A0    A0+1        STIND = STIND + 1
          RJ     STX         STORE INTO TEXT
          EQ     KAP10
  
  
**        OUTPUT CHARACTER RELATIONAL HEADER WORD.
*         (X2) = 0
*         (X3) = TAGI 
*         (X6) = BIASI
  
 KAP80    LX6    OA.RITEP 
          LX3    OA.LEFTP 
          ERRNZ  IA.LEFTP-IA.TAGP 
          ERRNZ  IA.RITEP-IA.BIASP
          BX1    X3+X6
          MX2    0           INDICATE NO RELOCATION 
          EQ     KAP50
  
 KAPA     EQU    TEMP        SAVED T.APL INDEX
 KIO      SPACE  4,10 
*         KIO - COMPILE I/O AP-LIST ITEMS.
* 
*         RELOCATES AND REFORMATS *T.IOA* INTO BINARY LOADER TEXT 
*         DEFINED AS OA. .
*         USES:  ALL
*         CALLS: DTX,STX,REL,MFE
*         CELLS  KIOA 
  
  
 KIO      SUBR   0           ENTRY/EXIT.
          SX6    IA.BIASP-PB.BIASP
          SA6    RELPOS 
          BX7    0
          SA7    BINWORD
          SA7    A7+B1
          SA7    KIOB        IND = 0
          RJ     DTX         SET ORIGIN IN TEXT TABLE 
          SA1    T=IOA
          SA0    B0          STIND = 0         /* (T.PTXTR) INDEX 
          AX0    X1,B1
          ERRNZ  2-Z=IOA     TWO WORDS PER ENTRY
          ALLOC  T.PTXTR,X0 
  
*         PROCESS NEXT ENTRY FROM T.IOA.
*         (A0) = NEXT STORE ADDRESS FOR SCRATCH TABLE (T.PTXTR).
  
 KIO10    SA5    T=IOA
          SA2    T.IOA
          SA1    KIOB        IND = (KIOB) 
          =X3    Z=IOA
          IX7    X5-X1       = LEN(T.IOA) - IND 
          IX6    X1+X3
          ZR     X7,EXIT.    IF END OF T.IOA
 .T       IFEQ   TEST,ON,1
          MI     X7,"BLOWUP" IF SOMETHING HORRIBLE
          SA6    A1          (KIOB) = IND + Z=IOA 
          IX4    X2+X1
          SA4    X4          IO1 = T.IOA(IND) 
          =A3    A4+1        IO2 = IO1 + 1
          LX1    X4 
          =X2    0
          ZR     X4,KIO110   IF +/- 0 
          BX5    X4 
          BX6    X3 
          SA6    KIOA        (KIOA) = IO2 
          MX7    -IA.MODEL
          LX1    -IA.MODEP
          LX4    -IA.VARP 
          BX2    -X7*X1      TYPE = MODE[IO1] 
          SB3    X2          REMEMBER (B3) = TYPE 
          SX0    B1 
          LX1    IA.MODEP-IA.IOCP 
          BX3    X0*X1       LST = IOC[IO1] 
          LX3    OA.LSTP
          NZ     X3,KIO12    IF CONTROL ITEM
          LX2    2
          MX6    -4 
          SB4    X2 
          SA2    FCLMOD 
          AX2    B4 
          BX2    -X6*X2 
          BX7    -X4*X0      VARI = .NOT. VAR[IO1]
          LX7    OA.VARP
          BX3    X3+X7       VAR[BINLIST] = VARI
 KIO12    LX2    OA.TYPP
          BX6    X2+X3
          MX7    -IA.TAGL 
          LX4    IA.VARP-IA.TAGP
          LX1    IA.IOCP-IA.CHARP 
          BX3    -X7*X4      TAGI = TAG[IO1]
          BX2    X0*X1       CHARI = CHAR[IO1]
          SB4    X2          REMEMBER (B4) = CHARI
          LX4    IA.TAGP-IA.BIASP 
          MX7    -IA.BIASL
          BX7    -X7*X4      BIASI = BIAS[IO1]
          MX2    -PB.ORDL 
          BX1    X2*X3       PFXI = PFX[TAGI] 
          ERRNZ  K=SYM
          LX4    IA.BIASP-1-IA.STP
          MX2    0           INDICATE NON FP
          NZ     X1,KIO15    IF PFXI .NE. K=SYM 
          SA2    T.SYM
          LX1    X3,B1
          IX1    X1+X3       STIND = 3 * TAGI 
          ERRNZ  3-Z=SYM
          IX2    X2+X1
          =A2    X2+WB.W     WBI = T.SYM(STIND) + WB.W
          CLAS=  X1,WB,(LCM)
          BX1    X2*X1       LCMI = LCM[WBI]
          HX2    WB.FP
          LX1    OA.LCMP-WB.LCMP
          BX6    X6+X1       ADD IN LCM BIT 
 KIO15    SA6    BINWORD     (LCM,LST,TYPE)[BINWORD] = (LCMI,IOC,TYPE)
          MI     X4,KIO18    IF ST
  
*         FOR NON-CHARACTER FP ITEMS, 
*         SET    ARG[OA.] = FPNO[WBI] - 1,
*                SUBS[OA.] = BIAS[IO1], 
*                FP[OA.] = FP[WBI]. 
*         (X7) = BIASI
*         (A6,X6) = BINWORD 
  
          NZ     B4,KIO20    IF CHARACTER 
          PL     X2,KIO40    IF NOT FP
          MX4    1
          BX4    X4*X2       FPI = FP[WBI]
          LX4    1+OA.FPP 
          MX1    -WB.FPNOL
          LX2    1+WB.FPP-WB.FPNOP
          BX1    -X1*X2      FPNOI = FPNO[WBI]
          MX5    -OA.SUBSL
          BX7    -X5*X7 
          ERRMI  IA.BIASL-OA.SUBSL
          LX7    OA.SUBSP 
          BX4    X4+X7
          =X5    X1-1        FPNOI = FPNOI - 1
          LX5    OA.ARGP
          BX1    X4+X5
          BX6    X1+X6
 KIO18    BX2    X6 
          HX2    OA.LST 
          SA6    BINWORD
          PL     X2,KIO85    IF NOT CONTROL ITEM
          CLAS=  X0,OA,(IND)
          SX1    B3-IC.STR
          ZR     X1,KIO19    IF ENCODE/DECODE STRING
          SX1    B3-IC.BUF
          ZR     X1,KIO19    IF BUFFER I/O FWA/LWA
          CLAS=  X0,OA,(VAR)
  
 KIO19    BX6    X0+X6
          ZR     X3,KIO85    IF TAGI .EQ. 0 
          SA6    A6          VAR[BINWORD] = 1 
          EQ     KIO85
  
*         CHARACTER I/O AP-LIST.
*         IF NOT FP, COPY (BCP,CLEN) FROM T.CAC(BIAS[IO1]) ENTRY
*         AND REPLACE BIAS[IO1] WITH RA [T.CAC(BIAS[IO1])] BEFORE 
*         RELOCATION. 
*         (X7) = BIASI
*         (A6,X6) = BINWORD 
  
 KIO20    PL     X2,KIO30    IF NOT FP
          EQ     "BLOWUP"    CHAR I/O AP SHOULD NOT BE FP 
  
 KIO30    SA1    T.CAC
          SB5    X1 
          MX0    -IA.BIASL
          LX5    -IA.BIASP
          BX5    X0*X5       CLEAR BIAS FIELD 
          SA4    X7+B5       CACI = T.CAC(BIASI)
          MX1    -WC.CLENL
          MX7    -WC.BCPL 
          BX2    X4 
          LX4    -WC.RAP
          LX2    -WC.CLENP
          BX4    -X0*X4      BIASI = RA[CACI], TRUNCATED TO IA.BIASL
          BX5    X5+X4       REPLACE BIAS FIELD 
          LX5    IA.BIASP 
          BX0    -X1*X2      CLENI = CLEN[CACI] 
          LX0    OA.LENP
          LX2    WC.CLENP-WC.BCPP 
          BX2    -X7*X2      BCPI = BCP[CACI] 
          LX2    OA.BCPP
          BX2    X2+X0
          BX6    X6+X2
          SA6    BINWORD     (CLEN,BCP)[BINWORD] = (CLENI,BCPI)[OA.]
  
*         JUMP TO APPROPRIATE I/O PROCESSOR.
*         (B3) = TYPE 
  
  
 KIO40    SA4    BINWORD
          MX7    -OA.ADRL 
          MX1    PB.GHIJL 
          LX5    PB.TAGP-IA.TAGP
          BX5    -X1*X5      CLEAR (GHIJ) FILED 
          SA7    RELMASK
          BX2    X4 
          HX2    OA.LST 
          PL     X2,KIO=LIS  IF NOT CONTROL ITEM
  
 .T       IFEQ   TEST,ON
          ZR     B3,"BLOWUP" IF CONTROL CODE .EQ. 0 
          SX0    B3-IC=LEN-1
          PL     X0,"BLOWUP" IF CONTROL CODE TOO BIG
 .T       ENDIF 
  
          JP     B3+IOCAD-1 
 KIO=     SPACE  4,10 
**        KIO=   I/O CONTROL ITEM PROCESSORS. 
* 
*         ENTRY  A4 - BINWORD 
*                A2 _ WBI 
*                (X3) = TAGI. 
*                (X5) = IO1.
  
 KIO=     BSS    0
          EQ     "BLOWUP"    CODE NOT IMPLEMENTED 
 KIO=END  SPACE  4,4
 KIO=END  BSS    0
 KIO=ERR  BSS    0
 KIO=MOD  BSS    0
 KIO=NML  BSS    0
 KIO=RCL  BSS    0
 KIO=SKP  BSS    0
          MX7    -18
          =B2    1           INDICATE LOWER PARCEL RELOCATION 
          SA7    RELMASK
          RJ     REL
          SA1    BINWORD
          SA2    BINREL 
          EQ     KIO110 
 KIO=BUF  SPACE  4,4
 KIO=BUF  BSS    0
          SB6    OA.LENP     LENGTH SHOULD BE *1* 
          EQ     KIO60
 KIO=FMTA SPACE  4,10 
 KIO=FMTA BSS    0
          CLAS=  X1,OA,(TYP)
          =X6    IC.FMT 
          LX6    OA.TYPP
          BX4    -X1*X4      CLEAR MODE FIELD 
          BX4    X4+X6
          CLAS=  X1,OA,(IND)
          BX6    X4+X1       ADD IN IND BIT FOR ASSIGN
          SA6    A4          (MODE,IND)[BINWORD] = (IC.FMT,1)[OA.]
          EQ     KIO80
 KIO=FMT  SPACE  4,4
 KIO=ACC  BSS    0
 KIO=BFL  BSS    0
 KIO=BLK  BSS    0
 KIO=EXS  BSS    0
 KIO=DIR  BSS    0
 KIO=FIL  BSS    0
 KIO=FMD  BSS    0
 KIO=FOR  BSS    0
 KIO=NAM  BSS    0
 KIO=NMD  BSS    0
 KIO=NXT  BSS    0
 KIO=NUM  BSS    0
 KIO=OPE  BSS    0
 KIO=SEQ  BSS    0
 KIO=STA  BSS    0
 KIO=UNF  BSS    0
 .T       IFEQ   TEST,ON,1
          ZR     X3,"BLOWUP" IF TAGI .EQ. 0 
          CLAS=  X7,OA,(VAR)
          BX6    X7+X4
          SA6    A4          VAR[BINWORD] = VARI[OA.] 
          EQ     KIO80
 KIO=FMT  SPACE  4,10 
 KIO=FMT  BSS    0
 .T       IFEQ   TEST,ON,1
          ZR     X3,"BLOWUP" IF TAGI .EQ. 0 
          SA1    A2          WBI
          SBIT   X1,WB.LABP 
          CLAS=  X7,OA,(VAR)
          PL     X1,KIO=FMT1 IF NOT FORMAT LABEL
          MX7    -WB.FMTLL
          LX1    WB.LABL+WB.LABP-WB.FMTLP 
          BX7    -X7*X1      EXTRACT FORMAT LENGTH
          LX7    OA.LENP
  
 KIO=FMT1 BX6    X7+X4
          SA6    A4 
          EQ     KIO80
 KIO=REC  SPACE  4,10 
 KIO=REC  BSS    0
 KIO=IOS  BSS    0
 KIO=UNT  BSS    0
          SB6    OA.VARP
 KIO60    BSS    0
          MX2    0           INDV = 0 
          ZR     X3,KIO70    IF TAGI .EQ. 0 
          =X2    1           INDV = 1 
 KIO70    LX2    X2,B6
          BX6    X4+X2
          SA6    A4          IND[BINWORD] = INDV
  
*         RELOCATE THE ADDRESS. 
  
 KIO=CNT  BSS    0
 KIO=STR  BSS    0
 KIO=LIS  BSS    0
 KIO80    =B2    1           INDICATE LOWER PARCEL RELOCATION 
          RJ     REL
 KIO85    SA1    BINWORD
          SA2    BINREL 
          SA5    KIOA        IO2 = (KIOA) 
          ZR     X5,KIO110   IF (IO2) .EQ. 0
  
*         PROCESS THE LENGTH WORD. (IO2)
*         (X5) = IO2
  
 KIO90    LX5    -IA.TAGP 
          MX2    OA.LENL
          LX2    OA.LENL+OA.LENP
          BX7    -X2*X1      LEN[BINWORD] = 0 
          MX0    -IA.TAGL 
          BX3    -X0*X5      TAGI = TAG[IO2]
          MX0    0           IND = 0
          MX6    -OA.LENL 
          ZR     X3,KIO100   IF TAGI .EQ. 0 
          SX0    1           IND = 1
 KIO100   =B2    3           INDICATE UPPER PARCEL RELOCATION 
          LX0    OA.INDP
          BX7    X7+X0       ADD IN IND BIT 
          MX3    PB.GHIJL 
          LX5    PB.TAGP
          BX5    -X3*X5      CLEAR (GHIJ) FIELD 
          SA6    RELMASK
          SA7    A1          IND[BINWORD] = IND 
          RJ     REL
          SA1    BINWORD
          SA2    BINREL 
  
 KIO110   SA3    T.PTXTR
          SB3    A0 
          BX6    X1 
          =A0    A0+1        STIND = STIND + 1
          SA6    X3+B3       T.PTXTR(STIND) = BINARY WORD 
          RJ     STX         STORE THE TEXT WORD
          EQ     KIO10
  
 KIOA     EQU    TEMP        SAVED SECOND WORD OF I/O AP
 KIOB     EQU    TEMP+1      SAVED T.IOA INDEX
 KNG      SPACE  4,10 
**        KNG - KOMPILE NAMELIST GROUP DEFINITIONS. 
  
  
**        DEFINE NAMELIST DEFINITION BINARY OUTPUT FORMATS. 
  
          DESCRIBE   NA.     GROUP DEFINITION HEADER
 GNAM     DEFINE WA.SYML     GROUP NAME, L FORMAT 
 NMEM     DEFINE 18          NUMBER OF GROUP MEMBERS
  
          DESCRIBE   NB.     MEMBER HEADER
 MNAM     DEFINE WA.SYML     MEMBER NAME, L FORMAT
 DADR     DEFINE 18          IF ARRAY, ADDR OF RUN-TIME DIM TABLE.
                             IF VARIABLE, =0. 
  
          DESCRIBE   NC.     MEMBER APLIST -- SAME AS STANDARD I/O APL. 
 TEMP     DEFINE 60          *****  TEMP  ***** 
  
  
  
 KNG      SUBR   0           ENTRY/EXIT...
  
*         ISSUE RUN-TIME ARRAY DIMENSION INFO TABLES. 
  
          RJ     DTX         INITIALIZE TEXT TABLE
          MX7    0           SELECT ONLY MATERIAL DIM ENTRIES 
          RJ     ORD         OUTPUT RUN-TIME DIM TABLE
  
*         ISSUE NAMELIST GROUP DEFINITIONS. 
  
          SA1    S=RD 
          SA2    T.SYM
          MX6    -PB.BIASL
          LX3    X1,B1
          IX7    X3+X1
          MX0    0
          ERRNZ  Z=SYM-3
          SA6    RELMASK
          SA6    SUBFLG      INHIBIT *SUB*
          SB2    X7+WC.W
          SA1    X2+B2       T.SYM WORD C FOR *RD.* ENTRY 
          MX3    -WC.RAL
          LX1    -WC.RAP
          BX6    -X3*X1 
          SA6    KNGB        (KNGB) = SAVE LOCAL COPY OF R-T DIM RA 
          PX7    X0 
          SA7    KNGA        INITIALIZE LOOP RESTART PARAMS 
  
*         (KNG10)  PROCESS A NAMELIST GROUP.
  
 KNG10    SA1    KNGA 
          UX6,B2 X1          (B2) = T.NLST ORD OF GRP-NAME (=0) 
  
 .T       IFEQ   TEST,ON
          NZ     B2,"BLOWUP" IF NOT GRP-NAME REQUEST
 .T       ENDIF 
  
          SB3    X1          (B3) = T.NLST INDEX OF FWA GROUP 
          RJ     SNR         SET NAMELIST REGISTERS 
          MI     B3,KNG90    IF NO MORE GROUPS
          SX3    B3          SAVE RESTART PARAMS
          PX6    X3,B2
          SA6    KNGA 
          =A1    A1+WA.W-WB.W 
          MX0    NA.GNAML 
          SX3    B4          NUMBER OF GROUP MEMBERS
          HX1    WA.SYM 
          BX1    X0*X1
          LX3    NA.NMEMP 
          =X2    0           (X2) = NO RELOC
          ERRNZ  NA.GNAMP-WA.SYMP 
          IX1    X1+X3       (X1) = 42/ GRP-NAME, L FORMAT,  18/ NR MEMS
          RJ     STX         ISSUE GROUP DEFINITION HEADER
  
*         (KNG20)  PROCESS A NAMELIST GROUP MEMBER. 
  
 KNG20    SA1    KNGA 
          UX6,B2 X1 
          SB3    X1 
          ZR     B2,KNG10    IF NO MORE MEMBERS IN CURRENT GROUP
          RJ     SNR         SET NAMELIST REGISTERS 
          SX7    A1 
          SX3    B3          SAVE RESTART PARAMS
          PX6    X3,B2
          SA6    KNGA 
          SA7    KNGC        SAVE ADDRESS OF WB WORD
          =A3    A1+WA.W-WB.W      EXTRACT MEMBER NAME
          MX0    NB.MNAML 
          HX3    WA.SYM 
          BX6    X0*X3
          ERRNZ  NB.MNAMP-WA.SYMP 
          IX1    X6+X2       MERGE ADDR OF RUN-TIME DIM INFO
  
*         SEND MEMBER INFO TO BINARY OUTPUT FILE. 
  
          MX0    1
          =X2    0           (X2) = PRESET NO RELOC 
          LX0    NB.DADRP+NB.DADRL
          BX6    X0*X1       EXTRACT  *SIMPLE VAR*  FLAG BIT
          =A3    KNGB 
          BX1    -X0*X1      CLEAR FLAG IF SET
          NZ     X6,KNG32    IF SIMPLE VARIABLE 
          IX1    X1+X3       RELOCATE RUN-TIME DIMTAB ADDRESS 
          =X2    2           (X2) = LOWER PARCEL, PROGRAM RELOCATION
 KNG32    RJ     STX         ISSUE MEM-NAME, DIMTAB ADDR
  
*         ISSUE MEMBER I/O APLIST WORD. 
*         (X5) = SYMORD OF MEMBER.
  
          SA2    KNGC 
          SA1    X2          WBI = WB WORD OF MEMBER
          RJ     PAW         PREPARE I/O APLIST WORD
          SA1    BINWORD
          SA2    BINREL 
          RJ     STX
          EQ     KNG20       LOOP FOR NEXT MEMBER 
  
*         (KNG90)  HERE WHEN ALL GROUPS DONE. 
  
 KNG90    BX6    0
 OCLB     EQU    TEMP+1      SAVED T.CLW INDEX
          SA6    SUBFLG 
          EQ     EXIT.
  
  
  
 KNGA     EQU    TEMP        RESTART INFO - 12/CURR ORD,48/IX GROUP FWA 
 KNGB     =      KNGA+1      LOCAL COPY OF  WC.RA  FOR *RD.*
 KNGC     =      KNGB+1      MEM-NAME, RUN-TIME DIMTAB ADDR 
 KNGD     =      KNGC+1      LOCAL COPY OF WC.RA FOR *VD.*
 OCL      SPACE  4,10 
**        OCL - OUTPUT CHARACTER LENGTH ARRAYS. 
* 
*                CALLED AFTER *KIO* TO REFORMAT T.CLW INTO BINARY 
*                FORM DEFINED AS LO. .
*                BINARY IS SAVED IN A SCRATCH TABLE FOR LISTING.
* 
*         ENTRY  (ORG) AND TEXT TABLE SET UP. 
* 
*         USES   ALL, T.CLWB
* 
*         CALLS  REL,STX
* 
*         CELLS  OCLA,OCLB,OCLC 
  
  
**        LO. - FORMAT OF CHARACTER LENGTH ARRAYS.
*         *OCL* TRANSLATES T.CLW INTO THIS BINARY FORM. 
  
  
          DESCRIBE LO.,60 
 LCMC     DEFINE 1           LCM BIT FOR COUNT (NOT USED) 
 FPC      DEFINE 1           FP BIT FOR COUNT  (NOT USED) 
 INDC     DEFINE 1           =1 IF LO.CNT IS ADDRESS
          DEFINE 9
 LEN      DEFINE 18          NO. OF CHARS IN EACH CHAR ARRAY ELEMENT
          DEFINE 2
 INDL     DEFINE 1           =1 IF LO.LEN IS ADDRESS
          DEFINE 3
 CNT      DEFINE 24          NO. OF ELEMENTS TO BE PROCESSED
  
  
 OCL      SUBR   0           ENTRY/EXIT.
          SA3    T=CLW
          SA0    0           (A0) = STIND = STORE INDEX FOR T.SCR 
          AX0,X3,B1 
          SX6    A0 
          SA6    OCLB        (OCLB) = INDEX = 0 
          ALLOC  T.CLWB,X0   ALLOCATE (T=CLW)/2 SPACES
  
*         PROCESS NEXT ENTRY FROM T.CLW.
  
 OCL10    SA2    T=CLW
          SA1    T.CLW
          SA4    OCLB        INDEX = (OCLB) 
          =X3    Z=CLW
          IX7    X4-X2
          IX6    X4+X3
          ZR     X7,EXIT.    IF END OF T.CLW
          IX2    X1+X4
          SA3    X2          CL1 = T.CLW(INDEX) 
          =A5    A3+1        CL2 = CL1 + 1
          SA6    A4          (OCLB) = INDEX + Z=CLW 
  
*         PROCESS COUNT WORD - CL2. 
  
          MX0    -IA.TAGL 
          BX6    X3 
          SA6    OCLA        (OCLA) = CL1 
          LX5    -IA.TAGP 
          =X7    0           INDC = 0 
          BX2    -X0*X5      TAGI = TAG[CL2]
          ZR     X2,OCL20    IF TAGI .EQ. 0 
          SX7    B1          INDC = 1 
 OCL20    =B2    1           INDICATE LOWER PARCEL RELOCATION 
          MX6    -LO.CNTL 
          SA6    RELMASK
          LX7    LO.INDCP 
          MX3    PB.GHIJL 
          SA7    BINWORD     INDC[BINWORD] = INDC 
          LX5    PB.TAGP
          BX5    -X3*X5      CLEAR (GHIJ) FIELD 
          RJ     REL
  
*         PROCESS LENGTH WORD - CL1.
  
          SA5    OCLA        CL1 = (OCLA) 
          MX0    -IA.TAGL 
          LX5    -IA.TAGP 
          BX2    -X0*X5      TAGI = TAG[CL1]
          =X7    0           INDL = 0 
          LX5    PB.TAGP
          ZR     X2,OCL30    IF TAGI .EQ. 0 
          SX7    1           INDL = 1 
 OCL30    =B2    3           INDICATE UPPER PARCEL RELOCATION 
          SA2    BINWORD
          LX7    LO.INDLP 
          BX7    X2+X7
          MX6    -LO.LENL 
          MX3    PB.GHIJL 
          BX5    -X3*X5      CLEAR (GHIJ) FIELD)
          SA7    A2          INDL[BINWORD] = INDL 
          SA6    RELMASK
          RJ     REL
          SA1    BINWORD
          SA2    BINREL 
          SA3    T.CLWB 
          SB3    A0 
          BX6    X1 
          =A0    A0+1        STIND = STIND + 1
          SA6    X3+B3       T.CLWB(STIND) = BINARY WORD
          RJ     STX         STORE INTO TEXT WORD 
          EQ     OCL10
  
 OCLA     EQU    TEMP        SAVED SECOND WORD OF CHARACTER LENGTH WORD 
 ORD      SPACE  4,10 
**        ORD -  OUTPUT RUN-TIME DIMENSION TABLE. 
* 
*         ENTRY  (X7) = 0      IF OUTPUT ENTRIES FOR DH.MAT ON ONLY.
*                     = DH.MAT IF OUTPUT ALL DIMENSION ENTRIES. 
*                (SAVVD) = WC.RA OF *VD.* 
*         USES   ALL, T.SCR 
*         CALLS  DTX,STX
*         CELLS  ORDA 
  
  
 ORD      SUBR   0           ENTRY/EXIT.
          SA7    ORDA 
          MX6    0
          SA0    0           (A0) = CURRENT T.DIM PROCESSING INDEX
          SHRINK T=SCR,X6 
 ORD10    SA1    T=DIM
          SA2    T.DIM
          SB2    A0 
          SB3    X1 
          GE     B2,B3,EXIT. IF END OF T.DIM, EXIT. 
          SA1    X2+B2       (X1) = NEXT ARRAY DIM HEADER 
          SA3    ORDA 
          CLAS=  X4,DH,(MAT)
          BX4    X4*X1       MATI = MAT[DIM HEADER] 
          BX2    X1 
          HX2    DH.DIM 
          AX2    -DH.DIML 
          IX0    X2+X2       (X0) = 2 * NR DIMS 
          BX7    X4+X3       MATI .OR. (ORDA) 
          NZ     X7,ORD20    IF DIM INFO TO BE ISSUED FOR ARRAY 
          =B2    X0+1 
          SA0    A0+B2       ADVANCE INDEX TO NEXT ARRAY HEADER 
          EQ     ORD10
  
 ORD20    CLAS=  X2,DH,(VD,AS,DIM)
          BX1    X2*X1
          =X2    0           (X2) = NO RELOCATION 
          =A0    A0+1        ADVANCE INDEX TO 1ST DIMENSION / SAVE
          SB2    X0 
          SX5    A0+B2       SAVE INDEX OF NEXT ARRAY HEADER (OR E-O-T) 
          RJ     WWB         ISSUE HEADER 
 ORD40    SA2    T.DIM
          =B2    A0+1 
          SA4    X2+B2       D2I = UB/LB WORD OF T.DIM
          =A3    A4-D2.W+D1.W      D1I = SPAN WORD OF T.DIM 
          =A0    B2+1        ADVANCE TO NEXT DIM
          BX1    X3 
          MX6    1
          HX1    D1.SPAN
          SA2    SAVVD       RAVD = (SAVVD) 
          BX7    X6*X1       RELOC BIT FOR SPAN 
          LX7    4           (UPPER PARCEL RELOCATION)
          AX1    59          SIGN EXTEND TD[SPAN] 
          BX1    X1*X2       BASERA = RAVD IFF TD[SPAN] .EQ. 1
          BX2    X4 
          HX2    D2.LB
          LX4    -D2.LBP-DM.INFP-DM.INFL
          IX3    X3+X1       SPANI = SPANI + BASERA 
          SA1    A2          RAVD = (SAVVD) 
          AX2    59          SIGN EXTEND TD[LB] 
          AX4    -DM.INFL    LBI = LB[D2I], SIGN EXTENDED 
          BX1    X2*X1       BASERA = RAVD IFF TD[LB] .EQ. 1
          IX4    X4+X1       LBI = LBI + BASERA 
          BX2    X6*X2       RELOC BIT FOR LB 
          LX2    1+DM.TDP 
          MX1    -DM.INFL 
          BX4    -X1*X4      TRUNCATE LBI TO DI.INFL
          BX4    X4+X2       ADD IN TD BIT
          LX2    -DM.TDP+1   (LOWER PARCEL RELOC FOR LB)
          BX2    X2+X7       RELOC BYTES FOR LB AND SPAN
          LX3    30 
          BX1    X3+X4       30/SPAN,30/LB
          RJ     WWB         ISSUE DIMENSION INFO WORD
          SB2    A0 
          SB3    X5 
          LT     B2,B3,ORD40 IF ANOTHER DIMENSION 
          EQ     ORD10       LOOP FOR NEXT ARRAY
  
 ORDA     EQU    TEMP+2      SAVED DH.MAT BIT 
 OSB      SPACE  4,10 
**        OSB -  OUTPUT  SUB  BLOCKS FOR  *SUB* / *SUB0*  OBJECT
*         TABLE TEXTS.
*         ENTRY- A4 -> FWA OF SUB TABLE (T.SUB / T.SUB0)
*                (X7) = LOCAL BLOCK ORDINAL (BN=) OF SUB BLOCK
*         EXIT - OBJECT TABLE FLUSHED TO LGO. 
*         CALLS - PUSE,DTX
  
  
 OSB      SUBR               ENTRY/EXIT.
          SA5    A4+N.TABLE 
          ZR     X5,EXIT.    IF NO SUB TABLE TO DUMP
  
*         ISSUE A *USE* PSEUDO TO SWITCH ORG SUB BLOCK. 
  
          SA2    CBI
          BX6    X2 
          LX7    PB.BIASP 
          SA6    SAVCBI      SAVE CURRENT BLOCK INDEX 
          RJ     PUSE        SWITCH ORG PARCEL COUNTS TO SUB BLOCK
          SX0    X5 
          SA0    X4-1        TABI = FWA OF TABLE - 1
          RJ     DTX         DUMP TEXT TABLE
  
*         DUMP NEXT TABLE ENTRY TO THE TEXT.
*         (A0) = TABI 
*         (X0) = LENTAB 
  
 OSB10    SX0    X0-1 
          =A0    A0+1        TABI = TABI + 1
          SA1    A0          TABLE ENTRY = (TABI) 
          MI     X0,OSB30    IF END OF TABLE
          =X2    2           INDICATE PROGRAM RELOCATION BYTE 
          NZ     X1,OSB20    IF NOT ZERO
          SX2    0           NO RELOCATION FOR ZERO WORD
 OSB20    RJ     STX         STORE INTO TEXT
          EQ     OSB10
  
*         RESTORE TO ORG IN USE BEFORE SUB BLOCK. 
  
 OSB30    SA4    SAVCBI      PICK UP OLD INDEX TO LBT 
          LX4    PB.BIASP 
          BX7    X4 
          RJ     PUSE        SWITCH ORG, PARCEL COUNTS BACK TO ORIGINAL 
          EQ     EXIT.
 OTB      SPACE  4,10 
**        OTB -  OUTPUT TABLE TO BINARY.
* 
*         ENTRY  (A5,X5) = FWA OF TABLE TO BE DUMPED
*                (A0) _ HEADER WORD 
*                (X0) = LAST TABLE ENTRY BIT TO BE SET (BT.LTB) 
* 
*         EXIT   TABLE WRITTEN TO BINARY FILE, SIZE SHRUNK TO ZERO. 
* 
*         CALLS  WLF
  
  
 OTB      SUBR   0           ENTRY/EXIT.
          ERRMI  1-FUDGE
  
 OTB10    SA2    A5+N.TABLE  LEN = LEN(TAB) 
          MX7    0           NEWLEN = 0 
          BX4    X0          LTB = LTB BIT
          SX1    X2-BT=MXWC 
          ZR     X2,EXIT.    IF NO MORE ENTRIES 
          MI     X1,OTB20    IF TABLEN .LT. MAXWC 
          SX2    BT=MXWC     LEN = MAXLEN 
          BX7    X1          NEWLEN = LEN - MAXLEN
          MX4    0           LTB = 0
  
 OTB20    IX6    X5+X2       FWA(TAB) = FWA(TAB) + LEN
          SB4    X2 
          LX2    BT.WCP 
          SA7    A2          LEN(TAB) = NEWLEN
          SA3    A0 
          BX7    X3+X2
          BX7    X7+X4       ADD IN BT.LTB
          SA7    X5-1 
          BX5    X6          ADJUST FWA 
          WLGO   A7,B4+B1 
          EQ     OTB10
 OTC      SPACE  4,10 
**        OTC -  OUTPUT TABLE (COUNTED) TO BINARY.
* 
*         ENTRY  (A5,X5) = FWA OF TABLE TO BE DUMPED
* 
*         EXIT   TABLE WRITTEN TO BINARY FILE 
* 
*         CALLS  WLF
  
  
 OTC      SUBR   0           ENTRY/EXIT.
  
 OTC10    SA2    X5          FETCH GROUP HEADER 
          ZR     X2,EXIT.    IF NO MORE ENTRIES 
          HX2    DC.CNT 
          AX2    -DC.CNTL    EXTRACT GROUP SIZE 
          IX6    X5+X2       FWA(TAB) = FWA(TAB) + LEN
          SB4    X2 
          LX2    BT.WCP 
          SA3    BT.PTEXT 
          BX7    X3+X2
          SA7    X5          BT.PTEXT HEADER
          =X5    X6+1        ADJUST FWA 
          WLGO   A7,B4+B1 
          EQ     OTC10
 PAW      SPACE  4,10 
**        PAW -  PREPARE AP-LIST WORD FOR NAMELIST GROUP MEMBER.
* 
*         ENTRY  (X5) = T.SYM ORDINAL FOR NAME
*                 A1,(X1) = WB.W WORD OF NAME 
*         EXIT   (BINWORD) = AP-LIST WORD 
*                (BINREL) = RELOCATION BYTE FOR THE AP-LIST WORD
*         CALLS  REL
*         USES   ALL
  
  
 PAW      SUBR               ENTRY/EXIT.
          MX7    -WC.RAL
          SA7    RELMASK     SET MASK FOR *REL* 
          =A3    A1-WB.W+WC.W      = WCI
          BX4    X3 
          MX0    -WB.MODEL
          LX1    -WB.MODEP
          LX3    -WC.BCPP 
          BX6    -X0*X1      MODEI = MODE[WBI]
          SA2    FCLMOD 
          MX7    -4 
          LX6    2
          SB7    X6 
          AX2    B7 
          BX2    -X7*X2 
          BX6    X2          TYPI[OA] = FCLMOD (MODEI)
          LX6    OA.TYPP
          =X7    1
          MX0    -WC.BCPL 
          BX0    -X0*X3      BCPI = BCP[WCI]
          LX1    WB.MODEP-WB.FPP
          LX3    WC.BCPP-WC.CTYPP 
          BX2    X7*X1       FPI = FP[WBI]
          BX3    X7*X3       CTYPI = CTYP[WCI]
          LX1    WB.FPP-WB.LCMP 
          SB2    X2          REMEMBER (B2) = FPI
          BX7    X7*X1       LCMI = LCM[WBI]
          LX7    OA.LCMP
          LX2    OA.FPP 
          BX2    X2+X7
          BX6    X6+X2
          NZ     B2,PAW20    IF FORMAL PARAMETERS 
          HX4    WC.CLEN
          AX4    -WC.CLENL   CLENI = CLEN[WCI]
 .T       IFEQ   TEST,ON,1
          MI     X4,"BLOWUP" IF CLENI .LT. 0
          LX0    OA.BCPP
          LX3    OA.INDP     IND[OA.] = CTYPI 
          BX3    X3+X0
          LX4    OA.LENP
          BX6    X6+X3
          IX6    X6+X4
          SA6    BINWORD     (BINWORD) =(LCMI,FPI,MODEI,BCPI,CLENI)[OA.]
  
*         RELOCATE ADDRESS FOR NAME.
*         (X5) = SYMORD OF NAME.
  
          =B2    1           INDICATE LOWER PARCEL RELOCATION 
          LX5    PB.TAGP
          RJ     REL
          SA1    BINWORD
          HX1    OA.IND 
          MX7    -OA.LENL 
          PL     X1,EXIT.    IF IND[BINWORD] .EQ. 0 
  
*         WHEN CTYP[WCI] .EQ. 1, SET LEN[BINWORD] = RELEN,
*         WHERE  RELLEN IS (S=VD) RELOCATED USING CLEN[WCI] AS BIAS.
*         INDIRECT BIT HAS ALREADY BEEN SET.
  
          SA5    S=VD 
          LX1    OA.INDP+1-OA.LENP
          BX6    X7*X1
          BX3    -X7*X1      CLENI = LEN[BINWORD] 
          LX6    OA.LENP
          SA6    A1          LEN[BINWORD] = 0 
          SA7    RELMASK     (RELMASK) = OA.LENL MASK 
          LX3    PB.BIASP 
          LX5    PB.TAGP
          BX5    X5+X3
          =B2    3           INDICATE UPPER PARCEL RELOCATION 
          ERRNZ  30-OA.LENP 
          RJ     REL
          EQ     EXIT.
  
*         FORMAL PARAMETERS.
*         (X6) = PARTIAL (BINLIST) WORD.
  
 PAW20    MX0    -OA.ARGL 
          LX1    WB.LCMP-WB.FPNOP 
          BX0    -X0*X1      FPNOI = FPNO[WBI]
          =X0    X0-1        FPNOI = FPNOI - 1
 .T       IFEQ   TEST,ON,1
          MI     X0,"BLOWUP" IF FPNOI .LT. 0
          MX7    0
          LX0    OA.ARGP
          BX6    X6+X0
          SA6    BINWORD     ARG[BINWORD] = FPNOI 
          SA7    BINREL      INDICATE NO RELOCATION 
          EQ     EXIT.
 PIT      SPACE  4,30 
**        PIT - PUMPS OUT IDNT (77) TABLE.
  
  
 PIT      SUBR   0           ENTRY/EXIT.
          SA1    TL.DATE
          SA2    IDENT
          SB2    CHAR 
          LX6    X1,B2
          BX7    X2 
          SA3    TL.TIME
          SA6    BT.IDNT+2
          SA7    A6-1 
          SA7    BT.XFR1
          LX6    X3,B2
          SA6    A6+1 
          SA1    CP.MODL
          SA2    TL.PTYP
          LX6    X1 
          BX7    X2 
          SA6    BT.IDNT+BT.IDNTU 
          SA7    BT.IDNT+BT.IDN8
  
*         NOTE -- THE FOLLOWING CODE DEPENDS UPON ARG=COMMON/FIXED
*                 BEING ILLEGAL, AND CAUGHT DURING INITIALIZATION.
  
          SA1    CO.ARGC
          SA2    CO.ARGF
          LX1    1
          LX2    2
          IX2    X1+X2
          SA1    X2+PITA
          LX6    X1 
          SA6    BT.IDNT+BT.IDNTB 
  
 #DAL     IFNE   .DAL,0 
          SA1    LEVEL2 
          SA2    BT.IDNT+7   HARDWARE REQUIREMENTS
          MX0    CHAR 
          LX0    8*CHAR 
          BX2    -X0*X2 
          SX0    1R 
          ZR     X1,PIT1     IF NO LCM NECESSARY
          SX0    1RL
  
 PIT1     LX0    7*CHAR 
          BX6    X2+X0       INSERT LCM FLAG AS NECESSARY 
          SA6    A2 
 #DAL     ENDIF 
  
          WLGO   BT.IDNT,L.77+1 
          EQ     EXIT.
  
 PITA     DIS    1,ARG=UNSPEC  ARG=-COMMON/-FIXED 
          DIS    1,ARG=COMMON  ARG= COMMON/-FIXED 
          DIS    1,ARG=FIXED   ARG=-COMMON/ FIXED 
 POL      SPACE  4,10 
*         POL - PRINT OBJECT LISTING. 
* 
*         ENTRY  (X5) = INSTRUCTION 
*         EXIT   NONE 
* 
*         CALLS PIK 
  
 POL      SUBR   =           ENTRY/EXIT.
 POL.EQ   BSSENT 0
          SA2    WO.LOO 
          SA1    LINEBUF
          ZR     X2,EXIT.    IF NO OBJECT LISTING REQUESTED 
          MI     X1,POL10    IF NOT BEGINNING OF WORD 
          PIA    ,A1         CONVERT ORGIN TO DPC 
 POL10    CALL   PIK
          SA1    =10H 
          BX6    X1 
          SETMEM LINEBUF,5,X6      BLANK FILL LINEBUF 5 WORDS 
          EQ     EXIT.
*CALL,COMFUSE 
          TITLE  SUPPORTING ROUTINES
 RBS      SPACE  4,10 
**        RBS -  RELOCATE  BSS  PSEUDO INSTRUCTION
*         ENTRY  (B2) = (PARCEL)
*                (B3) = (PARCEL) - 2
*                (X5) = INSTRUCTION 
* 
*         CALLS  BNW. 
  
 RBS      SUBR   0           ENTRY/EXIT 
          RJ     BNW         FORCE UPPER
          MX1    -PB.BIASL
          LX5    -PB.BIASP
          SA3    ORG
          BX1    -X1*X5      ISOLATE NO OF WORDS TO BE RESERVED 
          IX6    X1+X3
          LX5    PB.BIASP 
          SA6    A3          INCREMENT ORIGIN 
          ZR     X1,RBS1     IF ORG NOT BUMPED
          RJ     DTX         FLUSH TEXT TABLE 
  
 RBS1     RJ     POL
          EQ     EXIT.
 REL      SPACE  4,30 
**        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.)
*                (RELPOS) = POSITION OF BIAS FIELD IN (X5)
*                (XFIL) = SPECIAL XFILL RELOCATION INDICATOR
* 
*         EXIT   (B5) = FPNO[WBI], FOR *BST*
*                INSTRUCTION AND RELOCATION HAVE BEEN OR-ED INTO BINWORD
*                            AND BINREL.
*                *LINK* AND *FILL* TABLE ENTRIES MADE AS NECESSARY. 
*                A *SUB* ENTRY MADE INTO T.SUB, IF F.P. AND (SUBFLG)
*                            .GE. 0.
* 
*         USES:  A1-A3,A5-A7   B3,B5,B6,B7  X0-X7 
*         CALLS  ADW, BST 
*         *WARNING*          DO NOT DESTROY (B4)
  
  
 REL      SUBR               ENTRY/EXIT...
          =B5    0           INITIALIZE FOR *BST* 
          SA3    RELMASK
          SA1    RELPOS 
          SB3    X1 
          BX6    X5 
          LX6    -PB.TAGP 
          MX2    PB.GHIJL 
          MX0    -PB.TAGL 
          BX2    X2*X5       GHIJ PORTION OF INSTRUCTION
          BX7    0           INDICATE NO RELOCATION 
          =X4    0           INDICATE NO SPECIAL RELOCATION 
          BX6    -X0*X6      TAGI = TAG [INSTRUCTION] 
          AX5    B3          SHIFT TO BIAS FIELD
          BX3    -X3*X5      BIASI = BIAS[INSTRUCTION]
          LX2    PB.GHIJL+18          X2 = (30/0, 12/GHIJ, 18/0)
          ZR     X6,REL60    IF TAGI .EQ. 0 
          MX0    -PB.ORDL 
          BX5    X0*X6       PFXI = PFX[TAGI] 
          =X7    2           INDICATE NOMINAL RELOCATION
          SB3    B2-B1       DECREMENT PARCEL COUNT 
          LX7    B3 
          ZR     X5,REL10    IF PFXI .EQ. 0 (SYMBOL TABLE ORDINAL)
          ERRNZ  K=SYM
  
*         RELOCATE TAG FOR AUXILIARY TABLE (T.AUS), WHERE 
*                AUX= ( GL,API,IOI,LCA).
*         (X6) = TAGI 
  
          AX5    P=PFX       ISOLATE PREFIX 
 .T       IFEQ   TEST,ON
          SB7    X5-K=END 
          PL     B7,"BLOWUP"       IF PFXI .GE. K=END 
 .T       ENDIF 
          SA5    RELTAB+X5-1
          SA1    X5          T.AUX = ORIGIN OF AUX. TABLE 
          BX6    -X0*X6      ORDI = ORD [TAGI]
          SB7    X6 
          SA1    X1+B7       AUXI = T.AUX(ORDI) 
          LX1    -WC.RAP
          SX6    X1          RAI = RA[AUXI], TRUNCATED TO 18 BITS 
          EQ     REL60
  
*         RELOCATE A SYMBOL TABLE TAG.
*         FIND ADDRESS AND BLOCK NUMBER IN WC WORD OF SYMTAB. 
*         A NON-ZERO BLOCK NUMBER MEANS COMMON.  FOR THOSE, PREPARE 
*         X4 FOR ADDING TO FILL/LINK TABLE. 
*         (X6) = ORDI 
  
 REL10    SA1    T.SYM
          SA5    S=BU 
          IX5    X5-X6
          LX0    X6,B1
          IX0    X0+X6       STIND = 3 * ORDI 
          IX1    X0+X1
          ERRNZ  3-Z=SYM
          NZ     X5,REL15    IF ORDI .NE. (S=BU)
          SA1    ORG
          SA3    =400000B 
          =X4    0           NO SPECIAL RELOCATION
          IX6    X1+X3       *BLOWUP* ADDRESS = (ORG) + 400000B 
          EQ     REL65
  
 REL15    =A1    X1+WB.W     WBI = T.SYM(STIND) 
          BX5    X1 
          LX1    59-WB.LABP 
          MI     X1,REL30    IF STATEMENT LABEL 
          LX1    WB.LABP-WB.EXTP
          MI     X1,REL50    IF EXTERNAL LINKAGE SYMBOL 
          LX1    WB.EXTP-WB.FPP 
          PL     X1,REL20    IF NOT F. P. 
          MX4    -WB.FPNOL
          LX1    1+WB.FPP-WB.FPNOP
          BX4    -X4*X1 
          =B5    X4          SAVE FPNO FOR INDEX IN *BST* 
          =X7    0           INDICATE NO RELOCATION 
 REL20    CLAS=  X4,WB,(COM)
          BX4    X4*X5
 REL30    =A1    A1-WB.W+WC.W      FETCH SYMTAB ADDRESS WORD
          MX6    -WC.RAL
          LX1    -WC.RAP
          BX6    -X6*X1      ISOLATE (X6) = BLOCK-RELATIVE ADDRESS
          ZR     X4,REL60    IF LOCAL SYMBOL (NOT IN /COMMON/ BLOCK)
          MX4    -WC.RBL
          LX1    WC.RAP-WC.RBP
          BX4    -X4*X1      ISOLATE (X4) = INDEX IN (T.BLKS) OF RB 
          AX4    1
          ERRNZ  2-Z=BLKS 
          SX4    X4+2        SET (RB) = BLOCK NUMBER FOR LOADER 
          SBIT   X5,WB.LCMP 
          MX7    1
          BX0    X7*X5       ISOLATE LCM BIT
          SX1    T.FILL 
          BX4    X4+X0       MERGE LCM BIT INTO SPECIAL RELOC INDICATOR 
          SX7    B0          INDICATE NOT PROGRAM-RELATIVE
          LX1    BT.RLP 
          BX4    X4+X1
          EQ     REL60
  
*         PROCESS EXTERNAL LINKAGE SYMBOL.
*         (X0) = STIND
  
 REL50    SX1    T.LINK 
          LX1    BT.RLP 
          SX6    B0 
          BX4    X1+X0       SET SPECIAL RELOCATION = EXTERNAL
          SX7    B0 
  
**        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, THEN NO SPECIAL ACTION.
*                     " 0, THEN COMMON OR EXTERNAL RELOCATABLE. 
*                            (ORD = BLOCK NUMBER OR TAG ORDINAL)
*                            (WHICH = WHICH TABLE TO ENTER.)
*                (X6) = PARTIAL ADDRESS 
*                (X7) = RELOCATION ALREADY COMPUTED.
  
 REL60    SA1    RELPOS 
          SB3    X1+60-PB.BIASL-PB.BIASP
          LX3    B3,X3
          AX3    B3,X3       SIGN EXTEND BIAS 
          IX6    X3+X6       (X6) = FINAL ADDRESS 
 REL65    SA1    BINWORD
          SA3    RELMASK
          =X5    B2-1 
          BX6    -X3*X6      TRIM BIAS TO FIT IN RESULT FIELD SIZE
  
*         CALCULATE SHIFT COUNT BY WHICH INSTRUCTION WILL BE POSITIONED 
*         IN *BINWORD*. 
  
          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,REL90    IF NO SPECIAL RELOCATION 
          PL     X4,REL80    IF NOT (LCM) RELOCATION
  
*         MAKE *XFILL* TABLE ENTRY -- 
  
          SX2    X4          ISOLATE BLOCK ORDINAL
          NZ     X2,REL70    IF NOT PROGRAM BLOCK 
          SX2    X2+B1       ADD 1 FOR PROGRAM BLOCK NUMBER 
 REL70    SA1    ORG
          SX7    B3          LOW-ORDER BIT POSITION OF ADDRESS FIELD
          LX1    6
          BX6    X1+X7
          LX6    6
          SA3    RELMASK
          BX3    -X3
          CX3    X3 
          BX6    X6+X3
          LX6    9
          BX6    X6+X2
          LX6    9
          SX7    B1 
          BX6    X6+X7       30/(ORG), 6/0, 6/(RELSIZ), 9/ORD, 9/1
          ADDWD  T.XFIL 
          EQ     REL90
  
*         MAKE LINK/FILL TABLE ENTRY -- 
  
 REL80    SX2    X4          ISOLATE BLOCK/EXTERNAL INDEX 
          ERRNZ  18-BT.RLP
          SA1    ORG
          AX4    BT.RLP 
          LX5    BT.RLL-4 
          SX5    X5+1S11+1   X5 = 1/1, 2/(PARCEL)-1, 9/1
          LX5    BT.RLP 
          LX2    30 
          BX6    X5+X1
          IX6    X2+X6       = 30/ORD, 12/(X5), 18/(ORG)
          ADDWD  X4 
  
 SNAP=K   IFNE   TEST        DUMP *LINK* TABLE
          SA3    CO.SNAP
          LX3    1RK
          PL     X3,REL8S    IF LINK TABLE SNAP NOT SELECTED
          DUMPT  LINK 
 REL8S    BSS    0
 SNAP=K   ENDIF 
  
 REL90    EQ     B5,B0,EXIT. IF NO   *SUB*  TO MAKE 
          RJ     BST         GO MAKE A  *SUB* 
          EQ     EXIT.
  
 RELTAB   BSS    0           VECTOR OF ADDRESS TABLES FOR TAG PREFIXES
          LOC    1
 K=GL     CON    T.GL 
 K=AP     CON    T.API
 K=IO     CON    T.IOI
 K=LC     CON    T.LCA
 K=END    BSS                VERIFY VECTOR SYNCHRONIZATION
          LOC    *O 
  
 RELMASK  BSS    1           COMPLEMENT MASK OF BIAS FIELD SIZE 
 RELPOS   BSS    1           POS OF BIAS FIELD IN (X5) PASSED TO *REL*
 RNI      SPACE  4,30 
**        RNI - READ NEXT INSTRUCTION.
* 
*         READS NEXT PRE-BINARY INSTRUCTION FROM FILE F.PB .
* 
*         EXIT   (X5) = INSTRUCTION WORD. 
*                (RADB) = (X5). 
*                (OL=PB) = (X5).
  
  
 RNI      SUBR   =           ENTRY/EXIT.
          READW  F.PB,RADB,1     READ NEXT (PB.) WORD 
 .T       IFEQ   TEST,ON,1
          NZ     X1,"BLOWUP" IF REACHED EOR/EOF/EOI 
          SA5    RADB        FETCH WORD 
          BX7    X5 
          SA7    OL=PB
          EQ     EXIT.
 RMI      SPACE  4,10 
**        RMI - READ MULTIPLE WORD VERSION OF RNI.
* 
*         ENTRY  B6 = FWA OF AREA TO BE READ INTO.
*                X5 = NUMBER OF WORDS TO READ 
* 
*         EXIT   NONE 
  
 RMI      SUBR
          SB7    X5 
          READW  F.PB,B6,B7 
 .T       IFEQ   TEST,ON,1
          NZ     X1,"BLOWUP" IF PREMATURE EOR 
          EQ     EXIT.
 ROL      SPACE  4,10 
**        ROL -  STORE ORIGIN COUNTER IN LINEBUF IF BEGINNING OF WORD.
* 
*         ENTRY  (B2) = PARCEL COUNT
* 
*         USES   A-1,2,6
*                X-1,2,6
*                B-7
  
 ROL      SUBR   0           ENTRY/EXIT.
          SA1    =10H 
          SA2    ORG
          SB7    B2-3 
          BX6    X1 
          NZ     B7,ROL10    IF NOT BEGINNING OF NEW WORD 
          BX6    X2 
 ROL10    SA6    LINEBUF
          EQ     EXIT.
 SMW      SPACE  4,10 
**        SMW - STORE MULTIPLE WORDS. 
* 
*         SMW DUMPS A COMPILER TABLE INTO THE OBJECT FILE AS
*         BINARY INFORMATION (I.E., NO RELOCATION IS DONE). 
* 
*         ENTRY  (A1, X1) = TABLE TO BE DUMPED. 
*                ORIGIN SET.
*                TEXT TABLE INITIALIZED.
* 
*         EXIT   TABLE SHRUNK TO ZERO.
* 
*         USES   ALL. 
*         CALLS  STX. 
  
  
 SMW      SUBR   0           ENTRY/EXIT...
          SA3    A1+N.TABLE 
          ZR     X3,EXIT.    IF EMPTY TABLE 
          SA0    X3          (A0) = LENGTH OF TABLE 
          SA5    X1          FETCH (A5, X5) = TABLE ENTRY 
          SHRINK A3 
 SMW4     MX2    0           INDICATE NO RELOCATION 
          BX1    X5 
          RJ     STX         STORE WORD IN TEXT TABLE 
          SB4    A0-B1
          SA5    A5+1        FETCH NEXT ENTRY 
          SA0    A0-B1       DECREMENT UNPROCESSED LENGTH 
          GT     B4,SMW4     IF TABLE NOT EXHAUSTED 
          EQ     EXIT.
 SNR      SPACE  4,10 
**        SNR - SET NAMELIST REGISTERS. 
* 
* 
*         ENTRY  (B2) = T.NLST ORD OF REQUEST (0=GRP-NAME, 1-N=MEM-NAM).
*                (B3) = T.NLST INDEX TO FWA CURRENT GROUP.
* 
*         EXIT   (B2) = (B2)+1 IF GROUP HAS ANOTHER MEMBER. 
*                     = 0 IF NO MORE MEMBERS. 
*                (B3) = UNCHANGED IF GROUP HAS ANOTHER MEMBER.
*                     = T.NLST INDEX TO FWA NEXT GROUP IF (B2) = 0. 
*                     = -1 IF NO MORE GROUPS (END OF T.NLST). 
*                (B4) = NR MEMBERS IN CURRENT GROUP.
*                (A1,X1) = T.SYM WORD B FOR REQUESTED NAME. 
*                (X5) = T.SYM ORDINAL OF REQUESTED NAME.
*           FOR GROUP MEMBERS ONLY, ALSO RETURNS ...
*                (A2) -> (ONLY IF ARRAY) T.DIM HEADER FOR MEMBER NAME.
*                (X2) = IF ARRAY, BLOCK-REL ADDR OF RUN-TIME DIMTAB,
*                     = IF SIMPLE VARIABLE, = 4S15. 
* 
*         USES   A1-3,   X0-4,   B2-7.
* 
*         CALLS  NONE.
  
  
 SNR      SUBR   =           ENTRY/EXIT...
 SNR2     SA1    T=NLST 
          SA2    T.NLST 
          =B2    B2+1        *(B2) = ORDINAL NEXT MEMBER
          SB5    X1          (B5) = LEN (T.NLST)
          LE     B5,B0,SNR5  IF T.NLST EMPTY
          MI     B3,SNR5     IF NO MORE GROUPS
          GE     B3,B5,SNR5  IF IX[GRP-HDR] BEYOND END OF T.NLST
          SB6    X2          (B6) = (T.NLST)
          SA1    X2+B3       GROUP HEADER 
          MX0    -NG.NMEML
          LX1    0-NG.NMEMP 
          BX2    -X0*X1 
          SB4    X2          *(B4) = NR GROUP MEMBERS 
  
 .T       IFEQ   TEST,ON
          =B7    B2-1 
          GT     B7,B4,"BLOWUP"    IF REQUEST BEYOND END OF GROUP 
 .T       ENDIF 
  
*         COMPUTE LEFT SHIFT COUNT NEEDED TO POSITION REQUESTED ORDINAL 
*         TO BITS 14-0.  COUNT = MOD(ORD+2,4) * 15. 
  
          =X1    B2+1        ORD+2
          MX2    -2 
          BX3    -X2*X1      MOD(ORD+2,4) 
          SX1    X3 
          LX3    4
          IX2    X3-X1       *15
          SB7    X2          SHIFT COUNT
  
*         COMPUTE T.NLST INDEX OF REQUESTED ORDINAL.
*         INDEX = (ORD+1)/4 + INDEX FWA GROUP.
  
          SX1    B2 
          AX1    2
          SX2    B3+X1       INDEX
  
 .T       IFEQ   TEST,ON
          SX3    B5 
          IX3    X2-X3
          PL     X3,"BLOWUP" IF INDEX BEYOND END OF T.NLST
 .T       ENDIF 
  
          SA1    B6+X2       T.NLST WORD CONTAINING REQUESTED ORD 
          =B6    X2+1        (B6) = INDEX TO NEXT T.NLST WORD 
          SA2    T.SYM
          LX1    B7          SHIFT ORD TO BITS 14-0 
          ERRNZ  NG.ORDL-NG.NMEML  IF (X0) MASK LENGTH ERROR
          BX5    -X0*X1      *(X5) = T.SYM ORDINAL OF REQUESTED NAME
          =B7    X5+WB.W
          LX1    X5,B1
  
          SB7    B7+X1       ORD*3 + WB.W 
          SA1    X2+B7       *(A1,X1) = T.SYM WORD B FOR REQUESTED NAME 
          MX2    1
          LX2    NB.DADRP+NB.DADRL
  
          NE     B2,B1,SNR3  IF PROCESSING MEMBER 
  
 .T       IFEQ   TEST,ON
          BX3    X1 
          SBIT   X3,WB.NLSTP
          PL     X3,"BLOWUP" IF NOT GROUP NAME
          LX3    WB.NLSTP+1-WB.PNTP-WB.PNTL 
          AX3    -WB.PNTL 
          SB7    X3 
          NE     B7,B3,"BLOWUP"    IF GROUP-NAME ORDINAL MISMATCH 
 .T       ENDIF 
  
          BX3    X1 
          SBIT   X3,WB.MATP 
          MI     X3,SNR4     IF ANY I/O STATEMENT REFERENCED GROUP NAME 
          =X1    B4+1        GROUP LEN (IN T.NLST) = (NR MEM - 1)/4 + 1 
          AX1    2
          =B6    X1+1 
          =B2    0           (B2) = RESET FOR NEW GROUP HEADER
          SB3    B3+B6       (B3) = ADVANCE TO NEW GROUP ORD
          EQ     SNR2        RESTART
  
 SNR3     BX3    X1 
          SBIT   X3,WB.ARYP 
          PL     X3,SNR4     IF NOT ARRAY 
          SA2    T.DIM
          BX3    X1 
          SB7    X2 
          HX3    WB.PNT 
          AX3    -WB.PNTL 
          SA2    B7+X3       *(A2) = ADDR OF T.DIM HEADER 
          HX2    DH.RA
          AX2    -DH.RAL     *(X2) = ADDR OF RUN-TIME DIM INFO
 SNR4     LE     B2,B4,EXIT. IF ANOTHER MEMBER
          =B2    0           *(B2) = NO MORE MEMBERS
          SB3    B6          *(B3) = INDEX TO FWA NEXT GROUP IN T.NLST
          LT     B3,B5,EXIT. IF ANOTHER GROUP 
 SNR5     =B2    0           *(B2) = NO MORE MEMBERS
          =B3    -1          *(B3) = END OF T.NLST
          EQ     EXIT.
 STX      SPACE  4,30 
**        STX -  STORE *TEXT* TABLE ENTRY.
* 
*         STX CANNOT MOVE TABLES. 
* 
*         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-A4,A6,A7  B1-B3,B5-B7 
*         CALLS  DTX. 
  
  
 STX      SUBR               ENTRY/EXIT...
          SA3    BT.TXWC
          BX6    X1 
          SA1    BT.TXRB
          SX7    3
          SA6    OL=BIN 
          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    X2          CAPTURE (ORIGIN) FOR LISTING 
          SA6    LINEBUF
          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,30 
**        WLF -  WRITE *LGO* FILE.
* 
*                ALL BINARY OUTPUT MUST BE DONE THRU THIS ROUTINE.
*         PLEASE USE THE MACRO FORM, *WLGO*, TO INSURE CORRECT CALLING
*         SEQUENCE. 
* 
*         WLF CANNOT MOVE TABLES. 
* 
*         ENTRY  (B6) = FWA DATA
*                (B7) = WORD COUNT
*         USES   ALL BUT A5,X5,X0,A0
*         KEEPS  B4          *TEMP* 
*         CALLS  FA=WTW.
  
  
 WLF      SUBR   =           ENTRY/EXIT.
 WLF.EQ   BSSENT 0
          SX6    B4          SAVE (B4)
          SA6    GT1
          WRITEW F.LGO,B6,B7  WRITE IT OUT ON DISK
          SA1    GT1
          SB4    X1          RESTORE (B4) 
          EQ     EXIT.
 WWB      SPACE  4,10 
**        WWB -  WRITE ONE WORD TO TEXT /OR TO SCATCH TABLE 
*                (T.SCR). 
*         ENTRY  (X1) = WORD TO BE OUTPUT 
*                (X2) = RELOCTION BYTES 
*                (ORDA) = 0 IF WRITING TO TEXT
*                       = 1 IF WRITING TO SCRATCH TABLE 
*         CALLS  STX,ALLOC
*         CELLS  ORDC 
*         USES   ALL BUT A5,X5,A0,  T.SCR 
  
  
 WWB      SUBR   0           ENTRY/EXIT.
          SA4    ORDA 
          ZR     X4,WWB10    IF WRITING TO TEXT 
          BX6    X1 
          ADDWD  T.SCR
          EQ     EXIT.
  
 WWB10    RJ     STX         OUTPUT A WORD TO TEXT TABLE
          EQ     EXIT.
  
          PURGMAC WLGO
          SPACE  4,10 
          LIST   D
          END 
