*DECK     CGIA
          IDENT  CGIA 
 CGIA     TITLE  CGIA - CODE GENERATOR INTERNAL ASSEMBLER 
 B=CGIA   RPVDEF
*CALL     SSTCALL 
 CGIA     SPACE  3
**        CGIA - CODE GENERATOR INTERNAL ASSEMBLER. 
*                S.I. JASIK - CDC - OCTOBER 1976
* 
*         FUNCTIONS - 
*                CONVERT THE CG IL INTO RELOCATABLE BINARY
*                PRODUCE A OBJECT LISTING ( O-LIST SELECTED ) 
*         OR     PRODUCE A FILE OF BCD LINE IMAGES THAT CAN BE ASSEMBLED
*                BY *COMPASS*.
* 
**        INPUT TO *CGIA* CONSISTS OF THE FOLLOWING - 
* 
*         TEXT STREAM - A WORD ORIENTED STREAM OF OPCODES AND OPERANDS
*         WHICH IS SUBDIVIDED INTO 3 SECTIONS, THE INITIAL DECLARATIVES,
*         THE PROGRAM BODY WHICH IS MOSTLY MACHINE INSTRUCTIONS, AND
*         THE FINAL DECLARATIVES. 
* 
*         SYMBOL TABLE - CONTAINS THE NAMES OF THE REFERENCED SYMBOLS 
*         AND ADDRESS RELOCATION INFORMATION. BECAUSE *CGIA* IS A 1 PASS
*         ASSEMBLER ALL ADDRESS"S WILL HAVE BEEN DEFINED PRIOR TO 
*         CALLING IT. THE SYMTAB FORMAT IS A FUNCTION OF THE HOST 
*         COMPILER. 
* 
*         BLOCK TABLES -
*          COMMON BLOCK TABLE ( 60/0L_BLOCK-NAME,2/LVL,34/0,24/LENGTH ) 
*                            LVL = 2 OR 3 IMPLIES THE BLOCK IS ECS/LCM. 
*          LOCAL BLOCK TABLE ( 24/0,18/PC,18/LEN )
*                DO NOT INCLUDE ENTRIES FOR *SUB* BLOCKS HERE.
*         QUAL BLOCK NAME TABLE ( 42/0L_QUAL-NAME,18/6*N.CHARS IN NAME) 
*                THE FIRST 2 ENTRIES IN *QBT* ARE 0 AND * . 
* 
*         THE DECK *MACROS* CONTAINS THE LANGUAGE PROCESSOR ASSEMBLY
*         TIME MACRO DEFINITIONS IN A FORMAT DEFINED IN IT. 
 ILFMT    SPACE  3,14 
**        ASSEMBLER INPUT FILE FORMATS
* 
*         1) MACHINE INSTRUCTIONS 
*                SI. FORMAT FOR NON-TS MODE AND *TS* LONGFILE FORMAT
*                WHEN *CGIA* IS BEING ASSEMBLED FOR *TS*. 
*         2) PSEUDO INSTRUCTIONS
*                FORMAT IS THAT OF A TYPE IV *IL* INSTRUCTION - 
*                12/P(OC),18/CA,12/H2,18/IH       (  OC  CA,IH,H2 ) 
*                OPTIONAL DATA WORDS MAY FOLLOW . 
* 
*         3) MACROS 
*                THE MACRO CALL  * OC P1,P2,... * IS FORMATTED AS 
*                12/XOR(P(OC),7777B),24/P2,24/P1   ( OC \ 128 ) 
*                12/0,24/P4,24/P3 
*                12/0,24/P6,24/P5 
* 
*                THE NUMBER OF PARAMETERS IN A MACRO CALL MUST AGREE
*                WITH THE NUMBER IN THE DEFINITION. 
 PSEUDOS  SPACE  3,20 
*         PSEUDO INSTRUCTIONS AND HARDWIRED MACROS PROCESSED BY *CGIA*
* 
*         SY - SYMTAB ORDINAL 
*         WC - WORD COUNT 
*         A * PRIOR TO WC OR CA MEANS THAT THE FIELD IS 24 BITS.
* 
*         OPCODE CA,IH       OTHER PARAMETERS / COMMENTS
* 
*                            INITIAL GROUP ( MUST OCCUR FIRST ) 
*         LCC       WC       BCD STRING OF WC WORDS IN *C* FORMAT 
*         IDENT     SY
*         TITLE     WC       BCD STRING IN *H* OR *C* FORMAT
*         COMNT     WC       BCD STRING IN *H* FORMAT / GOES IN 77 TBL
*         LIB    ___         12/P(OC.LIB),48/0L_NAME
*         USBLK              / USEBLK TERMINATES THE INITIAL GROUP. 
*                            THE *USBLK* MACRO DEF IN *XXXMAC* CONTAINS 
*                            A *SST* DIRECTIVE AND IT DEFINES THE 
*                            ORDER OF THE FIXED LOCAL BLOCKS. 
* 
*         USE    BN,CLF      /  B = 0 - N FOR COMMON BLOCKS 
*                                  1S15+LOCAL-BLOCK-ORD FOR LOCAL BLOCKS
*                            CLF = 1 INDICATES CONDITIONAL LOADING
*         QUAL      QBO      / QBO = 0     FOR QUAL 0 
*                                    1 FOR QUAL * 
*                                    2 - N FOR QUAL BLKNAM
*         BSS    SY,*WC      /  SY BSS  *WC 
*         BOS    LN          LN = LINE NUMBER 
*                            H2 FIELD MAY CONTAIN LIST FLAGS
*                            H2 = 0 NO CHANGE 
*                                 1        LIST ON
*                                 2        LIST OFF 
*                            / CAUSES PRINTING OF A COMMENT'* LINE LN'
*         CON    SY,*CA      / FORMS CON SY+*CA 
* 
*         DATA   WC,CC       WC WORDS OF BINARY DATA FOLLOW 
*                            IF WC = 0 THEN *CC* IS THE DATA ITEM 
*         DIS       WC       WC WORDS OF BCD DATA FOLLOW IN *H* FORMAT. 
*         END    CA,SY       / CA = ORD(LABEL FIELD), SY = ORD(XFER)
*         HOL    CC,F        1 WORD OF BCD DATA IN H FORMAT FOLLOWS 
*                            CC = CHAR COUNT ( @ 10 ) , F = 1RH,1RL,1RR 
*         ORG    SY,*CA      / SEE *STD-MAC* FOR DEF OF *ORG* AND *REPI*
*         REPI   DLEN,RC,INC,DESTIN 
*                            SECOND WORD IS 24/,18/DESTIN,18/INC
* 
*         BMI                 / BEGIN *TS* FORMAT MACHINE INSTRUCTION 
*                            PROCESSING 
*         DCS    CC,I        AND 1 WORD FOLLOWS IN *L* FORMAT 
*                            / DEFINE CHAR STRING FOR USE AS A MACRO ARG
*                            MI   MICRO  1,CC, WORD 
*         VFDP   BN,LEN      1 WORD OF BCD DATA IN *L* FORMAT FOLLOWS.
*                            BN = POSITION COUNTER - 1
* 
*         NOT DESCRIBED - APL,IOM 
*         SUB    CA,FPN      / FPN = FORMAL PARAM NUMBER, CA = XIJ
*                            X = 0/1 FOR READ WRITE , I,J = ADDR,DATA 
*                            REGISTER NUMBERS 
* 
*         ENTRY AND EXT PSEUDOS ARE NOT NECESSARY SINCE THEY ARE PUT
*         OUT BY THE ASSEMBLER WHEN IT INITIALIZES THE SYMBOL TABLE.
 TABLES   TITLE  ASSEMBLER TABLE FORMATS
**        FORMAT OF WORD 3 OF *SYMTAB* DURING ASSEMBLY -
* 
*         AR. - ADDRESS RELOCATION WORD FORMAT
  
          DESCRIBE AR.       FOR ^EXTERNALS 
 RL       DEFINE 2           0 - ABS, 1 - PROG, 2 - COM, 3 - EXT
          DEFINE 13 
 QBN      DEFINE 12          QUAL BLOCK NUMBER
 RB       DEFINE 9           BLOCK NUMBER ( COMPILER VALUE )
 RA       DEFINE 24          PROGRAM RELATIVE ADDRESS 
  
          DESCRIBE AR.       FOR EXTERNALS
 RL       DEFINE 2           =3 
          DEFINE 22 
 XCI      DEFINE 18          EXTERNAL CHAIN INDEX 
 XLNK     DEFINE 18          XLINK CHAIN INDEX TO *XLT* 
 AD.      SPACE  2,10 
**        AD. - LBIT, CBT ADDRESS DEF WORD FORMAT 
  
          DESCRIBE AD.       AD(NPR,RB,ORGC)
          DEFINE 2
 NPR      DEFINE 10          NUMBER OF PARCELS REMAINING IN CURRENT WORD
 LCM      DEFINE 1           =1 IF BLOCK IS IN LCM/ECS
          DEFINE 13 
 CL       DEFINE 1
 RB       DEFINE 9           BLOCK NUMBER ( LOADER )
 ORGC     DEFINE 24          ORG COUNTER
  
 RBOC     DEQU   ORGC,33     RB AND ORGC FIELDS 
 CRBO     DEQU   ORGC,34     CL, RV AND ORGC FIELDS 
 BLKTBLS  SPACE  2,10 
**        PIDL - BLOCK NAME AND LENGTH TABLE
* 
*         42/0L_NAME,1/ECS,17/LEN OR LEN/8 IF ECS=1 
 LBT      SPACE  2,5
**        LBT - LOCAL BLOCK ADDRESS TABLE 
* 
*         42/,18/LEN WHICH IS CHANGED TO 42/,18/FWA BY *CG.RBT* 
 LBIT     SPACE  2,6
**        LBIT - LOCAL BLOCK INFO TABLE , 2 WORDS PER ENTRY FOR EACH
*         LOCAL BLOCK ( NOT INCLUDING *SUB* BLOCKS ) .
* 
*         AD WORD 12/P(PC),15/,9/RB,24/ORGC  ( RB = 1 ALWAYS )
*                45/DATA IN LAST PARTIAL WORD,11/0,4/LAST RELOC BYTE
 CBT      SPACE  2,5
**        CBT - COMMON BLOCK INFO TABLE , 2 WORDS PER ENTRY 
* 
*         AD WORD 12/P(PC),15/0,9/RB,24/ORGC
*                42/0,18/LOADER BLOCK NUMBER
 LAFT     SPACE  2,12 
**        LAFT - LINK AND FILL CHAIN TABLE
* 
*         12/,18/LBN OR EXT NUM,30/LINK OR FILL BYTE
*         LINK/FILL BYTE FORMAT IS 1/1,2/RELOC,9/RB,18/ORGC 
*         RELOC = 0/1/2 FOR L/M/U RELOCATION AND RB IS USUALLY = 1
 XFT      SPACE  2,5
**        XFT - XFILL BYTE TABLE
* 
*         6/0,24/ORGC,6/LOWBIT,6/LEN,9/RB OF ADDR,9/RB OF DESTIN ( =1 ) 
 XLT      SPACE  2,14 
**        XLT - XLINK BYTE TABLE ( MAX LENGTH = 777B )
* 
*         6/0,24/ORGC,6/LOWBIT,6/LEN,9/LINK TO PREV,9/RB OR DESTIN ( =1 
 FPIT     SPACE  2,6
**        FPT - FORMAL PARAMETER INFO TABLE,  1 WD/F.P. 
* 
*         24/0,18/SYMTAB INDEX,18/INDEX TO SUBTABLE IN *FPST* 
*         FPST HOLDS THE SUB WORDS OF THE F.P.S IN THE CORRECT ORDER. 
 LNT      SPACE  2,6
**        LNT - LINE NUMBER TABLE FOR *FID* 
* 
*         HEADER WORD - 12/5700B,12/WC,12/HC.ID,24/0
*         TABLE WORDS - 18/LABEL IN BINARY,6/0,18/LINE NUMBER,18/FWA
          SPACE  2
**        TABLE - DEFINE ORDER OF ASSEMBLER TABLES
  
          MACRO  TABLE,N
 Z$N      EQU    .T 
 O.N      EQU    O.BLK+.T 
 L.N      EQU    L.BLK+.T 
 .T       SET    .T+1 
          ENDM
 .T       SET    1
  
          TABLES (BLK,SYM,CBT,CUT)   AND *LBT* IN CRADLE
  
          IFNE   HC.FPAS,0,1
 FPST     TABLE 
          ECHO   1,Z=(LAFT,XFT,XLT,LNT,PIDL,LBIT,ENTR,LCC,LIB)
 Z        TABLE 
  
          EXT    F.SLST,F.LGO,F.CMPS,PBUF#
 PBUF     EQU    PBUF#
 MXB      SPACE  3,10 
**        MXB - VARIABLE MASK OPDEF 
* 
*         MXI    BJ          PRODUCES A MASK (BJ)+1 BITS LONG IN XI 
  
 MXB      OPDEF  I,J
          MX.I   1
          AX.I   B.J
          ENDM
 DECLS    TITLE  LOCAL STORAGE AND DECLARATIVES 
 OBSS     OPSYN  BSS         DEFUNCT MACRO
  
*         LOCAL STORAGE 
  
 BCDC     OBSS   1           "0 IF OL ! C  , < 0 IF C 
 CCB      DATA   2           COMPILER COMMON BLOCK BIAS 
*                            =3 IF //COM IN PIDL, ELSE =2 
 IL.LAF   OBSS   1           INIT LEN OF *LAF* ( (N.EXT+1)/2+1 )
 NAE      BSSZ   1           N. ASSEMBLY ERRORS 
          DATA   28L ASSEMBLY ERRORS IN PROGNAM 
 N.ENT    BSS    1           N. ENTRY POINTS ( SET BY CG.ASN )
 XCI      CON    0           EXTERNAL CHAIN INDEX 
 UBO      DATA   1S15,1S15   CURRENT LAST USE BLOCK ORDINALS
  
 NLF      DATA   0           NO LIST FLAG FOR FORCEING UPPER, ETC 
 LBUF.WC  OBSS   1           N.WORDS IN LBUF
 OBUF     OBSS   12  4+8     ADDRESS, OCTAL CODE, RELOC INFO  AND 
 LBUF     =      OBUF+4      BCD LINE IMAGE BUFFER
  
 MIW      BSSZ   2           MACRO INFO WORDS ( INDEX AND HEADER )
  
 L.MP     EQU    24          LENGTH OF A MACRO PARAMETER FIELD
 L.MRB    EQU    12          LENGTH OF A MACRO RELOC BYTE 
 L.IBUF   EQU    40B         LENGTH OF INPUT BUFFER 
  
 IBUF     OBSS   L.IBUF 
 IBUFL    OBSS   1           12/P(EOB),48/0  END OF BUFFER SENTINAL 
 EOBA     =      IBUF+L.IBUF-1  END OF BUFFER ADDRESS 
  
          ENTRY  F$SST
 F$SST    BSSZ   8           SET SYMBOL TABLE 
          SPACE  3,14 
*         EQU"S FOR EQUVIALENCED OPCODES
  
          MACRO  EQVOC,A,B
 OC.A     EQU    OC.B 
          RMT 
 .B       =      .A 
          RMT 
          ENDM
  
 END      EQVOC  EOQ         END OF SUBPROGRAM
 EOB      EQVOC  EOS         END OF INPUT BUFFER MARKER 
 EOM      EQVOC  DAR         END OF MACRO EXPANSION 
  
*         LOCAL BLOCK NAME TABLE
  
 LBNT     BSS    0
          ECHO   1,Z=("HC.FLB") 
          DATA   10H_Z
 N.LB     EQU    *-LBNT      NUMBER OF FIXED LOCAL BLOCKS 
 .XL      IFNE   HC.NXLB,0
 .X       SET    1
          DUP    HC.NXLB
 .1       DECMIC .X,3 
 .X       SET    .X+1 
          DATA   10HLBLK".1"
          ENDD
 .XL      ENDIF 
 LTCODES  SPACE  3,15 
**        LOADER TABLE CODES
  
 LT.IDT   =      7700B       IDENT OR PREFIX TABLE
 LT.LDSET =      7000B       LDSET
 LT.PIDL  =      3400B       PROGRAM ID AND LENGTH
 LT.ENTR  =      3600B       ENTRY POINTS 
 LT.XTXT  =      3700B       XTEXT ( USED INSTEAD OF TEXT ) 
 LT.REPI  =      4700B       XREPL
 LT.VFDP  =      3500B       VFDP 
 LT.XFIL  =      4100B       XFILL
 LT.FILL  =      4200B
 LT.LINK  =      4400B       LINK 
 LT.XLNK  =      4500B       XLINK
 LT.LNT   =      5700B       LINE NUMBER TABLE FOR *FID*
 LT.XFER  =      4600B       TRANSFER NAME
  
 LS.LIB   =      10B         LDSET LIB= 
 LS.USE   =      16B         LDSET USE= 
 IDT      SPACE  2,14 
**        IDENT  TABLE
  
 TMVM     MICRO  2,1,/"MDL"/    71   72   73   74   175  176
 TMVM     MICRO  5*"TMVM"-4,5,/6464 6464 6464 666X C5CX 767X /
  
 IDT      BSS    0
          LOC    0
          VFD    12/LT.IDT,12/16B,36/0
          DATA   7LPROGNAM
          DATA   20H MM/DD/YY  HH.MM.SS   DATE AND TIME 
          DATA   10H"OS.ID" 
          DATA   10H"LPNAME""VER" 
          VFD    30/5H"MODLVL",30/5L"TMVM"
          DATA   10H I             TYPE = RELOC, DEPENDENCIES = INT MULT
 CCO      BSSZ   3           CC OPTIONS 
 COMMNT   BSSZ   4           COMMENTS 
          LOC    *O 
 TT       SPACE  2,12 
*         TEXT TABLE
  
 TI       OBSS   1           TEXT INDEX ( 0 - 15 )
 TH       OBSS   1           12/LT.XTXT,12/WC,12/RB,24/ORGC 
 TR       OBSS   1           TEXT RELOCATION BYTES
 TD       OBSS   15          TEXT  DATA 
  
 AI       VFD    12/2003B,48/0     ADDR IN CURRENT BLOCK ( AD. FORMAT ) 
 CW       BSS    1           CURRENT TEXT WORD
  
 RBWORD   OBSS   3           ADDRESS RELOC INFO IN *AR.* FORMAT 
 IH       =      RBWORD+1    SYMTAB ORDINAL OF SYMBOL 
* IH+1                       0L_EXT-NAME IF RL = 3
 WB       OBSS   1           WORD B OF SYMTAB ENTRY 
 IH2      BSSZ   2           SYMTAB ORD OF H2 AND TRUC *CA* FOR *FMI* 
 GNIW     TITLE  BASIC I/O MACROS AND ROUTINES
**        GNIW - GET NEXT INPUT WORD FROM *IBUF*
  
 GNIW     MACRO 
          SX7    A5-EOBA
+         NZ     X7,*+1 
          RJ     FIB
          SA5    A5+B1
          ENDM
  
 FIB      ROUTINE 
          READW  F.SLST,IBUF,L.IBUF 
          SA5    IBUF-1 
          EQ     FIB
 WRTEXT   SPACE  3,8
**        WRTEXT - OUTPUT DATA TO A TEXT TABLE
* 
*         WRTEXT NP,RELOC    AND  (X4) = DATA RIGHT ADJUSTED
*                NP = NUMBER OF PARCELS OF DATA ( 0 - 4  )
*                RELOC - PRESENT ONLY IF NP = 4 AND LOWER RELOC SHOULD
*                BE ADDED. RELOCATION IS ADDED AUTOMATICALLY FOR NP = 2.
  
 WRTEXT   MACRO  NP,REL 
          R=     B3,NP
          IFEQ   NP,0,1 
          MX4    0
          RJ     APT
          IFC    NE,/REL//,2
          SA1    RBWORD 
          RJ     ATR
          ENDM
 WRLGO    SPACE  3,8
**        WRLGO - WRITE WORDS TO LGO FILE IF CO.B " 0 
*         ALL WRITES TO THE *LGO* FILE MUST USE THIS MACRO. 
* 
*         WRLGO  FWA,N.WORDS
  
 WRLGO    MACRO  F,L
          R=     B6,F 
          R=     B7,L 
          RJ     WWL
          ENDM
 WWL      SPACE  2
 WWL      BSSZ   1           =0 IF BINARY NOT YET WRITTEN 
          IF     DEF,/DEBUG/LGO,1 
          SNAP   *B6,,*B7,NOREGS
 WWL.P    WRITEW F.LGO,B6,B7
 WWL1     EQ     WWL
 SETXTH   SPACE  3,14 
**        SETXTH - SETUP XTEXT HEADER WORD
*         CALL -
*         SETXTH AIW,THWA 
*                AIW = X-REGISTER THAT *AI* IS IN 
*                THWA = A-REGISTER WITH ADDRESS OF *TH* OR BLANK
  
 SETXTH   MACRO  AIW,THWA 
          SB4    LT.XTXT-2000B
          MX7    -AD.CRBOL
          BX7    -X7*AIW
          PX6    B4,X7
          SA6    THWA TH
          ENDM
 TSMODE   SPACE  4,14 
**        TS MODE TABLE MANAGER INTERFACE 
 .TS      IFNE   HC.TS,0
  
**        ADW - ADD 1 WORD TO THE END OF A MANAGED TABLE
  
 ADW1     SA6    ADWA 
          RJ     ATS= 
          SA3    ADWA 
          BX6    X3 
          SA6    B7-B1
 ADW=     ROUTINE 
          BX6    X1 
          SX1    B1 
          EQ     ADW1 
  
 ADWA     BSS    1
 ATS      SPACE  3
**        ATS= - ALLOCATE TABLE SPACE 
  
 ATS1     SA1    =XFTAB=+A0 
          RJ     =XALC=      CALL TS TABLE MANAGER
          SA3    A2 
          BX0    X4 
          SA2    A1+
 ATS=     ROUTINE 
          BX4    X0 
          LX0    X1 
          EQ     ATS1 
  
 .TS      ENDIF 
 CGIA     TITLE  MAIN LOOP AND MACRO REFERENCE PROCESSING 
**        CGIA - CODE GENERATOR INTERNAL ASSEMBLER
  
 CG$IA    ENTRY. ** 
          SX7    IA.EX
          SA7    =XCG.MOX#   CG.MOX = IA.EX 
          MX6    0
          SA6    L.LIB       L.LIB = 0
          SA6    L.LAFT      L.LAFT = 0 
          ALLOC  LIB,2       ALLOC( LIB , 2 )  */ SPACE FOR HEADER WDS
          SA1    =XHO$C 
          SA2    =XHO$LO$O
          MX6    0           BCDC = 0 
          SA6    =XHO$CSN    HO$CSN = 0 
          ZR     X1,CGIA1    IF C = 0 
          SA6    HO$B        HO$B = 0      */ IN CASE HOST HASNT DONE IT
          MX6    1           BCDC = 1S59
          EQ     CGIA2
 CGIA1    ZR     X2,CGIA2    IF OL = 0
          SX6    1           BCDC = 1 
  
 CGIA2    SA6    BCDC 
          SA1    =XHO$B 
          NZ     X6,CGIA3    IF BCDC " 0   */ OL ! C SELECTED 
          SA3    APTA+1 
          BX7    X3          SET FOR NO OBJECT LIST 
          SA7    APT5 
          ZR     X1,CG$IA    IF B = 0 
 CGIA3    NZ     X1,CGIA4    IF B " 0 
          SA2    WWL1 
          BX7    X2          PLUG LGO WRITE ROUTINE 
          SA7    WWL.P
  
*         FLUSH, REWIND AND BEGIN READING THE *SLIST* FILE
  
 CGIA4    WRITER F.SLST,,R
          REWIND F.SLST 
          READ   F.SLST 
          SX6    1S10+OC.EOB
          LX6    48 
          SA6    IBUFL       SETUP END OF BUFFER SENTINAL 
  
**        EOB - END OF INPUT BUFFER, READ NEXT N WORDS INTO WORKING BUF 
  
          PROCESS EOB 
          READW  F.SLST,IBUF,L.IBUF 
          MI     X1,*+1S17         IF EOF ON INPUT
          SA2    L.LAFT 
          SA5    IBUF-1      II = IBUF - 1
          SX6    X2-7700B 
          MI     X6,GNIW     IF L.LAFT < 7700B  */ NO OVERFLOW
          RJ     DAT         DUMP THE LINK AND FILL TABLES
  
**        GNIW - GET NEXT INPUT WORD ( MAIN LOOP )
  
 GNIW     SA5    A5+1        II = II + 1
          SX7    0
          MX0    -6 
          UX6    B2,X5       OPC = OC[II] 
          SA7    IH          IH = 0 
          PL     X5,GNIW1    IF [II] > 0
          SB3    B2-128 
          GE     B3,PMR      IF OPC \ 128  */ A MACRO REF 
  
**        ENTER OPCODE PROCESSOR WITH - 
*         (X0) = MASK(54) , (A5,X5) = II, [II]
*         (B2) = OPCODE, (X6) = LOW48[II] AND (X4) = )OPC 
  
 GNIW1    SA4    OC.AT+B2 
          SB3    X4 
          AX4    36 
          JP     B3          JUMP( OC.AT[OC] )
 IA.EX    SPACE  3,14 
**        IA.EX - ERROR EXIT PROCESSING 
*         CALLED BY THE TABLE MANAGER WHEN A MEMORY OVERFLOW
*         OR AT THE END OF THE SLIST FILE IF THERE ARE ASSEMBLY ERRORS
  
 IA.EX    SA1    HO$B 
          ZR     X1,IA.EX2   IF B = 0 
  
          SA2    WWL
          ZR     X2,IA.EX1   IF WWL = 0    */ NOTHING ON LGO
  
          WRITER F.LGO
          BKSP   F.LGO,,R 
  
 IA.EX1   WRLGO  IDT,17B     OUTPUT IDENT TABLE 
          WRLGO  ERRL,3      AND ERROR LINE 
          EQ     END5              */ GO FLUSH OUT *LGO*
  
 IA.EX2   SA1    HO$C 
          ZR     X1,CG$IA    IF C = 0 
          WRITEC F.CMPS,ERRL,3     OUTPUT ERR LINE
          WRITEC F.CMPS,(=8L  END  ),1
          WRITER F.CMPS,,R
          EQ     CG$IA
  
 ERRL     DATA   28L  ERR   ERRORS IN - PROGNAM 
 PMR      EJECT 
**        PMR - PROCESS MACRO REFERENCE 
  
 PMR      SA4    =XF$MACS+B3 MIW = MACS(OPC)
          SA3    X4 
          BX6    X4 
          SA6    MIW
          MX7    -3 
          BX6    X3 
          SA6    A6+B1       MIW(2) = MHW 
          BX2    -X7*X3      NP = MHW & 7 
          SB2    X2 
  
*         UNPACK PARAMETERS FROM MACRO CALL INTO *PBUF* 
  
          MX0    -L.MP
          BX7    -X0*X5 
          SA7    PBUF+1 
          AX5    L.MP 
          BX7    -X0*X5 
          SA7    A7+B1
          SB3    B1+B1
          LE     B2,B3,PMR1  IF NP @ 2
          GNIW
          BX7    -X0*X5 
          SA7    PBUF+3 
          AX5    L.MP 
          BX7    -X0*X5 
          SA7    A7+B1
          SA4    MIW+1
          MX3    -3 
          BX2    -X3*X4 
          SX6    X2-5 
          MI     X6,PMR1     IF NP < 5
          GNIW
          BX7    -X0*X5 
          SA7    PBUF+5 
          AX5    L.MP 
          BX7    -X0*X5 
          SA7    A7+B1
  
 PMR1     SA1    BCDC 
          MI     X1,PMR5     IF BCDC < 0   */ C OPTION ONLY 
  
*         MOVE MACRO TEXT TO MACRO BUFFER 
  
          SX7    A5 
          SB2    OC.EOM 
          PX6    B2,X7
          SA5    MIW         6/,18/N.PR,18/LEN,18/FWA-1 
          SX2    X5+B1
          AX5    18 
          SX1    X5 
          IX0    X2+X1       PRA = FWA + LEN
          LX1    18 
          BX6    X1+X6
          LX1    -18
          SA6    =XF$MXB+X1  MXB(LEN) = PACK(OC.EOM,II) 
          ZR     X1,PMR3     IF LEN = 0 
          MOVE   X1,X2,F$MXB MOVE( LEN, FWA , F$MXB ) 
 PMR      SPACE  1,4
*         SUBSTITUTE PARAMETER VALUES IN THE MACRO BUFFER 
*         RELOC BYTE FORMAT IS 6/LOW-BIT,6/WORD INDEX 
  
          SA4    X0          PRW = [PRA]
          MX7    -IH.CAL
          SB2    60-L.MRB    SC = 60 - L.MRB
          MX0    -6 
          AX5    18 
          SB4    X5          N = N.PR[MIW] */ N. SUBSTIT PARAMS 
          SB5    F$MXB       BASE = F$MXB 
  
 PMR2     ZR     B4,PMR3     IF N = 0      */ END OF RELOC BYTES
          AX3    B2,X4       RB = SHIFT( PRW , -SC )
          BX6    -X0*X3 
          SA2    B5+X6       MW = BASE( WI[RB] )
          SB5    B5+X6       BASE = BASE + WI[RB] 
          AX3    6
          BX3    -X0*X3 
          SB3    X3-60
          LX2    -B3
          SA1    X2 
          BX2    X7*X2
          SB3    X3 
          BX6    X2+X1       SUBSTITUTE PARAM VALUE IN MACRO WORD 
          SB4    B4-B1       N = N - 1
          LX6    B3 
          SB2    B2-L.MRB    SC = SC - L.MRB
          SA6    A2 
          GE     B2,PMR2     IF SC \ 0
          SB2    B2+60       SC = SC + 60 
          SA4    A4+B1       PRA = PRA + 1;  PRW = [PRA]
          EQ     PMR2 
  
 PMR3     SA1    BCDC 
          ZR     X1,PMR4     IF BCDC = 0   */ NO OBJ LIST 
  
          SA1    MIW+1
          RJ     FMC         FORMAT AND STORE MACRO CALL LINE 
  
 PMR4     SA5    F$MXB-1     II = F$MXB - 1 
          EQ     GNMW1
  
 PMR5     SA1    MIW+1
          RJ     FMC         FORMAT AND OUTPUT MACRO LINE 
  
 PMR6     SX6    0
          SA6    MIW         MIW = 0       */ CLEAR MACRO MODE FLAG 
          EQ     GNIW        EXIT TO MAIN LOOP
 EOM      SPACE  2
**        EOM - END OF MACRO PROCESSING 
  
          PROCESS EOM 
          SA5    X5          II = [II]     */ RESTORE INPUT BUFFER POINT
          AX6    18 
          NZ     X6,PMR6     IF LENGTH " 0
          WRTEXT 0           LIST THE MACRO LINE
          EQ     PMR6 
 INST     TITLE  MACHINE INSTRUCTION PROCESSORS 
**        MACHINE CODE INSTRUCTION PROCESSORS 
*         CONVERT *SI.* FORMAT TO MACHINE INSTRUCTIONS, NOTE RELOCATION 
*         WRITE TO TEXT TABLES, CONVERT TO BCD, ETC.
 PROCESS  SPACE  2
**        PROCESS - DEFINE TRANSFER POINT FOR OPCODE PROCESSORS 
* 
*         PROCESS (PLIST),V 
*         PLIST - LIST OF 1 OR MORE OPCODES TO BE PROCESSED 
*         V = COMMON VALUE ASSOCIATED WITH THE LIST OF NAMES
  
          PURGMAC PROCESS 
 PROCESS  MACRO  P,V
          IRP    P
          NOREF  .P 
 .P       BSS    0
          IFC    NE,/V//,2
          NOREF  )P 
 )P       =      V
          IRP 
          ENDM
 PRTII    SPACE  2,10 
**        PRTII - PROCESS TYPE I INSTRUCTION
* 
*         PRTII  (PLIST)
  
 PRTII    MACRO  P
          IRP    P
          NOREF  .P,)P
 )P       =      OC.P*1S9 
 .P       BSS    0
          ENDM
 PSEUDO   SPACE  3,12 
**        PSEUDO - DEFINE PSEUDO OP NAME AND ARGUMENT TYPES FOR BCD 
*         LISTING PURPOSES
* 
*         PSEUDO NAME,(ARG-TYPES),LAB 
*         LAB = 1 IF FIRST ARG IS IN THE LABEL FIELD, ELSE 0
  
 PSEUDO   MACRO  NAME,PL,LAB
+         VFD    36/6L;A
          VFD    3/1-LAB
 .N       SET    0
          IRP    PL 
 .N       SET    .N+1 
          VFD    3/AT.PL
          IRP 
          VFD    *P/.N
          ENDM
  
          ECHO   1,Z=(C,B,S,Q,M,E),V=(1,2,3,4,5,6)
 AT.Z     =      V
          NOREF  .N 
 XBX      SPACE  2,8
 .TS      IFEQ   HC.TS,0
  
**        XBX INSTRUCTIONS
  
          PRTII  (ILS,IRS,NR,RNZ,UP,PK) 
          SX3    200020B
          EQ     TYI
  
**        XXX INSTRUCTIONS
  
  
          PRTII  (AND,OR,XOR,FA,FS,DFA,DFS,RFA,RFS,IA,IS,FM,RFM,DFM,FD,_
,RFD) 
          ECHO   1,X=(IAZ,ISZ,IM),Y=(IA,IS,DFM) 
          PROCESS X,)Y
          SX3    202020B
  
 TYI      SX6    307070B
          BX7    X6*X5
          BX6    X3-X7
          SA6    RERR 
          ZR     X6,TYI1A    IF RERR = 0
  
          SA1    NAE
          SX6    X1+B1       NAE = NAE + 1 */ BUMP ERROR COUNTER
          SA6    A1 
  
 TYI1A    MX0    -3 
          BX1    -X0*X5      I = RI[II] & 7 
          LX5    -SI.RJP
          BX2    -X0*X5      J = RJ[II] & 7 
          LX5    SI.RJP-SI.RKP
          BX3    -X0*X5      K = RK[II] & 7 
  
*         FORM FMIJK , (X4) = FM000, (X1,X2,X3) = I,J,K 
  
 TYI1     LX1    6
          BX4    X1+X4
          LX2    3
          BX3    X2+X3
          IX4    X3+X4
          WRTEXT 1
          EQ     GNIW 
  
*         BXI  -XJ*XK INSTRUCTIONS, MACHINE FORMAT IS - FMIKJ . 
  
          PRTII  (STR,IMP,EQV)
          MX0    -3 
          BX1    -X0*X5      I = RI[II] & 7 
          LX5    -SI.RJP
          BX3    -X0*X5      K = RJ[II] & 7 
          LX5    SI.RJP-SI.RKP
          BX2    -X0*X5      J = RK[II] & 7 
          EQ     TYI1 
  
*         XX INSTRUCTIONS 
  
          PRTII  (XMT,XMTC,CX)
          MX0    -3 
          BX1    -X0*X5      I = RJ[II] & 7 
          LX5    -SI.RJP
          BX2    -X0*X5      J = RJ[II] & 7 
          BX3    -X0*X5      K = J
          EQ     TYI1 
  
**        CONSTANT SHIFT AND MASK INSTRUCTIONS
  
          PRTII  (KLS,KRS,FMA)
          MX0    -3 
          BX1    -X0*X5      I = RI[II] & 7 
          LX5    -SI.CAP
          MX2    0           J = 0
          SX3    X5          K = CA[II] 
          EQ     TYI1 
  
 #DAL     IFNE   .DAL,0 
  
**        LCM READ/WRITE INSTRUCTIONS 
  
          PROCESS DRL,01400B
          PROCESS DWL,01500B
          SX1    B0          I = 0
          MX0    -3 
          BX2    -X0*X5      J = RI[II] 
          LX5    -SI.RJP
          BX3    -X0*X5      K = RJ[II] 
          EQ     TYI1 
 #DAL     ENDIF 
  
**        MEMORY REFERENCE PROCESSING 
  
 )F       =      7S8+5S4+6   TO CHANGE BAX INTO 5/6/7 
  
          PROCESS (SLD,SST,SA),3S8+4S4+6
          PROCESS (SDL,SDS,SS),5S4+7
          BX1    -X0*X6      IR = RI[II]
          LX6    -SI.RJP
          BX2    -X0*X6      JR = RJ[II]
          LX6    SI.RJP-SI.RKP
          BX3    -X0*X6      KR = RK[II]
          BX6    X3 
          AX6    3
          BX7    X2 
          ZR     X6,SLD1     IF RT[KR] = 0 */ KR IS A B-REGISTER
          BX2    X3 
          BX3    X7          SWAP( JR , KR )
  
 SLD1     BX3    -X0*X3 
          SB7    B0          FLAG = 0 
          EQ     PLD2 
 PLD      SPACE  2,8
          PROCESS STT,2S8+1 
          SA1    =XS$CON
          LX5    -SI.IHP
          BX2    X1-X5
          LX5    SI.IHP 
          SX1    X2 
          NZ     X1,PLD0     IF IH[SI] " CON. 
  
          PROCESS LDC,2S8+1 
          LX5    -SI.CAP
          SA3    =XO.CUT
          SB3    X5 
          SA2    X3+B3       C = CUT( CA[SI] )
          MX1    -SI.CAL
          BX3    X1*X5
          BX5    X3+X2       CA[SI] = C 
          LX5    SI.CAP 
  
          PROCESS (LD,ST,PLD,PST,S,ILD,TLD,TST,ILD),2S8+1 
 PLD0     BSS    0
          BX1    -X0*X6      IR = RI[II]
          LX6    -SI.RJP
          BX2    -X0*X6      JR = RJ[II]
          LX6    SI.RJP-SI.CAIHP
          MX7    -SI.CAIHL
          BX3    -X7*X6      K = CAIH[II] 
          NZ     X3,PLD1     IF K " 0 
          SX4    )SLD 
          EQ     SLD1 
  
 PLD1     LX5    -SI.CAP
          SB7    B1          FLAG = 1 
  
*         PLD2 - COMMON PROCESSOR TO DETERMINE F AND M FOR A MEMORY REF 
*         INSTRUCTION.  (B7) = 0 IF EXIT TO TYI1, ELSE FALL THROUGH 
*         (X1,X2,X3) = IR,JR,KR 
*         EXIT   (X4) = FM000 , (X1,X2) = REDUCED TO REGISTER NUMBERS.
  
 PLD2     SB3    3
          AX6    B3,X2
          LX6    2
          SB4    X6 
          AX4    B4 
          MX0    -3 
          BX4    -X0*X4      M = SHIFT()XX,-4*(JR/8)) & 7 
          LX4    9
  
          AX6    B3,X1
          LX6    2
          SB4    X6 
          SX7    )F 
          AX7    B4 
          BX6    -X0*X7      F = SHIFT( )F , -4*(IR/8) ) & 7
          LX6    12 
          BX4    X4+X6
          BX1    -X0*X1 
          BX2    -X0*X2 
          ZR     B7,TYI1     IF FLAG = 0
  
          LX1    6
          LX2    3
          BX1    X1+X2
          BX4    X1+X4
          LX4    15          FMIJ0 - 0
          MX7    -SI.CAL
          BX3    -X7*X5 
          BX4    X3+X4       ADD CA 
          SX6    X5 
          SA6    IH2+1       IH2(2) = CA[II]
          LX5    SI.CAP-SI.IHP
          SX3    X5 
          ZR     X3,PLD4     IF IH[II] = 0
  
          RJ     GAI         GET ADDR INFO
          MX7    -18
          SB3    X4 
          SX3    X3+B3       K = K + RA[RBWORD] 
          BX4    X7*X4
          BX3    -X7*X3 
          BX4    X3+X4
          LX5    SI.IHP+59-SI.H2P 
          PL     X5,PLD4     IF ^H2[II]    */ NO H2 
  
          SA3    IH 
          LX3    30 
          BX0    X3+X4       SAVE BINARY AND IH 
          GNIW
          BX6    X5 
          SA6    IH2         IH2 = [II] 
          BX3    X5 
          RJ     GAI         GET ADDR INFO
          SB3    X0 
          SB4    X3 
          MX7    -18
          SX3    B3-B4       K = K - RA[RBWORD] 
          BX3    -X7*X3 
          MX7    -12
          LX7    18 
          BX4    -X7*X0 
          LX0    30 
          BX4    X3+X4
          SX6    X0 
          MX7    0
          SA6    IH          RESET IH 
          SA7    RBWORD      RBWORD = 0    */ NO RELOCATION FOR THIS INS
  
 PLD4     WRTEXT 2           OUTPUT BINARY
 .FPAS    IFNE   HC.FPAS,0
 .FPAS    ENDIF 
          EQ     GNIW 
  
 .TS      ENDIF 
 JUMPS    SPACE  2,14 
**        JUMP PROCESSORS 
 RJXJ     SPACE  2,14 
 .RJXJ    IFNE   HC.RJXJ,0
  
**        RJXJ   CA,IH,0,RI  ,  CA = 12/BIAS,6/JT 
*         OUTPUT BINARY FOR ^JT  XI,*+1 ;  RJ IH+CA 
  
          PROCESS RJXJ
          RJ     FPU         FORCE UPPER
          SX1    B1 
          LX1    AR.RLP 
          SB2    2
          RJ     ATR         SET UPPER TEXT RELOC FOR X-JUMP TO *+1 
          MX0    -3 
          BX1    -X0*X5      I = RI[II] & 7 
          SX4    0300B
          BX4    X1+X4       030I 
          LX5    -SI.CAP
          BX6    -X0*X5      JT = CA[II] & 7
          SX7    B1 
          BX3    X6-X7       J = XOR(JT,1)  */ TOGGLE JUMP TYPE 
          LX3    3
          BX4    X3+X4
          LX4    18 
          SA2    AI 
          SX3    X2+B1       K = ORGC[AI] + 1 
          BX4    X3+X4       03JIK
          LX4    6
          BX4    X7+X4       ADD 01 OPCODE
          LX4    24 
          SX3    X5 
          AX3    6
          IX4    X3+X4       ADD BIAS 
          LX5    SI.CAP-SI.IHP
          SA2    BCDC 
          ZR     X2,RJXJ2    IF BCDC = 0
  
          SA3    =10H 
          SA2    =10HRJ::   X0, 
          BX7    X3 
          LX1    6
          SA7    LBUF 
          IX7    X1+X2       ADD REG NUMBER 
          SA3    FMI.XJ+X6
          MX6    12 
          BX6    X6*X3
          LX6    -12
          BX7    X6+X7
          SA7    A7+B1
          BX1    X4          SAVE BINARY
          SX2    X5 
          CALL   CSN#        CONVERT NAME 
          SB4    60 
          BX7    X6 
          SB4    B4-B3       UBC = 60 - BC
          SX6    X1 
          ZR     X6,RJXJ1    IF BIAS = 0
          RJ     CON
          SX3    1R+
          LX3    -6 
          BX6    X3+X6
          RJ     ADC         ADD +BIAS
 RJXJ1    RJ     TSB         TERMINATE STRING 
          BX4    X1 
 RJXJ2    SX3    X5 
          RJ     GAI         GET ADDR INFO OF EXTERNAL
          IX4    X3+X4
          WRTEXT 4,RELOC     WRITE BINARY AND ADD RELOC 
          EQ     GNIW 
 .RJXJ    ENDIF 
 JPX      SPACE  2,14 
          PROCESS JPX,0300B  03IJK
          MX0    -3 
          BX2    -X0*X5      J = RI[II] & 7 
          LX5    -SI.CAP
          BX1    -X0*X5      I = CA[II] & 7  */ JUMP TYPE 
  
 JPX1     LX1    3
          BX2    X1+X2
          LX5    SI.CAP-SI.IHP
          BX4    X4+X2
          LX4    18 
          SX3    X5 
          RJ     GAI
          IX4    X3+X4
          WRTEXT 2
          EQ     GNIW 
  
          PROCESS JPBB
          MX0    -3 
          BX1    -X0*X5      I = RI[II] & 7 
          LX5    -SI.RJP
          BX2    -X0*X5      J = RJ[II] & 7 
          LX5    SI.RJP-SI.CAP
          SX4    X5+4        FM = 04+CA[II] 
          LX4    6
          EQ     JPX1 
 JIN      SPACE  2,14 
          PROCESS JIN,0200B 
          BX1    -X0*X5 
          LX1    3
          BX4    X1+X4       02I0 
          LX5    -SI.IHP
          SX5    X5 
  
          PROCESS RJ3,0100B 
          PROCESS UJP,0400B 
          SX3    X5 
          LX4    18 
          RJ     GAI
          LX5    -SI.CAP
          SX7    X5 
          SA7    IH2+1       SAVE FOR LISTING 
          IX3    X3+X7
          MX0    -18
          BX3    -X0*X3 
          IX4    X3+X4
          WRTEXT 2
          RJ     FPU         FORCE UPPER AFTER
          EQ     MPXA 
  
 RJ6      SPACE  2,14 
 .HC      IFNE   HC.RJ6,0 
  
 RJTA     PSEUDO RJT,(S,C)
 RJTB     SB0    0
          SB0    0
  
          PROCESS RJ6 
          SA1    RJTA 
          UX5    X5 
          LX5    30 
          RJ     LPO         LIST PSEUDO
          LX5    30 
          RJ     FPU         FORCE UPPER
          SX3    X5 
          RJ     GAI         GET ADDR INFO
 .FPAS    IFNE   HC.FPAS,0
 RJT1     BSS    0
 .FPAS    ENDIF 
          SB2    2
          RJ     ATR         ADD UPPER RELOC FOR THE NAME 
          SX4    B1 
          LX4    54 
 .RJTBN   IFC    NE,/"HC.RJTBN"// 
          SA3    =X"HC.RJTBN" 
          RJ     GAI
          BX4    X3+X4       ADD RA OF TRACEBACK NAME 
 .RJTBN   ENDIF 
          LX5    -SI.CAP
          SX6    X5-7777B 
          PL     X6,RJT2     IF CA[II] \ 7777B
          SX7    X5 
          LX7    18 
          BX4    X4+X7       12/0100,18/0,12/CA,18/TEMPA0.
          WRTEXT 4,"HC.RJTBN"      WRITE BINARY AND ADD RELOC 
          EQ     MPXA 
  
 RJT2     MX7    -12
          LX7    18 
          BX4    -X7+X4 
          WRTEXT 4,"HC.RJTBN" 
          SA5    A5 
          SA4    RJTB 
          LX5    -SI.CAP
          SX6    X5 
          BX4    X4+X6       OUTPUT SB0  0  ;  SB0 LINE-NUM 
          WRTEXT 4
          EQ     MPXA 
  
 .HC      ENDIF 
 BMI      SPACE  3,14 
 .TS      IFNE   HC.TS,0
  
**        BMI - BEGIN *TS* FORMAT MACHINE INSTRUCTION PROCESSING
  
          PROCESS BMI 
          SX6    BMI1 
          EQ     SXA         SET EXIT ADDR AND START PROCESSING 
  
 BMI1     GNIW               WD = GNIW( INPUT ) 
          SX7    B0 
          SA7    IH          IH = 0 
          MX0    6
          BX3    X0*X5
          LX3    6           OPC = SHIFT( MASK(6) & WD , 6 )
          ZR     X3,BMI6     IF OPC = 0    */ PSEUDO OP 
          SX7    X3-10B 
          SX4    X3-50B 
          MI     X7,BMI2     IF OPC < 10B  */ 30 BIT INSTRUCTIONS 
          MI     X4,BMI3     IF OPC < 50B  */ SHORT INSTRUCTIONS
          MX0    -3 
          BX2    -X0*X3 
          SX4    X2-3 
          PL     X4,BMI3     IF OPC & 7 > 2  */ SHORT INSTRUCTION 
  
*         PROCESS 30 BIT INSTRUCTION - 12/FMIJ,18/CA,12/0,18/IH 
  
 BMI2     SX3    X5 
          LX5    30 
          RJ     GAI         GET ADDR INFO
          SX6    X5 
          SX6    IH2+1       IH2(2) = CA
          IX7    X6+X3       K = CA + RA[RBWORD]
          MX0    -18
          BX7    -X0*X7 
          MX1    -12
          LX1    18 
          BX3    -X1*X5      FMIJ 0 
          BX4    X3+X7
          WRTEXT 2           OUTPUT BINARY, ETC 
          EQ     BMI1 
  
*         PROCESS UP TO 4 15 BIT INSTRUCTIONS 
  
 BMI3     BX0    X5 
  
 BMI4     LX0    15          WD = SHIFT(WD,15)
          MX0    -15
          BX4    -X1*X0      DATA = WD & 77777B 
          BX0    X1*X0       WD = WD & MASK(45)  */ REMOVE BYTE 
 BMI5     WRTEXT 1
  
          NZ     X0,BMI4     IF WD " 0
          EQ     BMI1 
  
*         PROCESS PSEUDO INSTRUCTION - 6/0,60N,18/CA,12/H2,18/IH
  
 BMI6     BX3    X5 
          AX3    -12
          SB3    X3+
          JP     BMI.JT+B3
  
 BMI.JT   BSS    0
          LOC    0
          SX6    GNIW        0 - EMI - END MACHINE INST PROCESSING
          EQ     SXA
          EQ     .BOS 
          SX4    0400B
          EQ     .UJP 
          SX4    0100B
          EQ     .RJ3 
          EQ     .RJ6 
          UX4    X5          LCM READ/WRITE - 12/00NN,33/0,15/01XJK 
          MX0    0
          EQ     BMI5 
*                ** NEED JIN, BSS, OTR PROCESSORS 
          LOC    *O 
 SXA      SPACE  2,14 
**        SXA - SET EXIT ADDRESS OF PROCESSORS USED BY BOTH *SI.* 
*                AND *TS* FORMAT PROCESSING 
* 
*         ENTRY  (X6) = EXIT ADDRESS
* 
*         EXITS TO (X6) 
  
 SXA      SB3    X6 
          LX6    32 
          PX7    X6 
          AX7    2
          SA7    MPXA        MPXA = 0400ADDR,0
          JP     B3 
  
 MPXA     EQ     GNIW        MIXED PROCESSOR EXIT ADDRESS WORD
  
 .TS      ELSE
  
 MPXA     =      GNIW        NO TS MACHINE INSTRUCTION PROCESSING 
  
 .TS      ENDIF 
 LCC      TITLE  INITIAL CARD GROUP PROCESSING AND INITIALIZATION 
**        LCC    0,WC AND WC WORDS FOLLOW IN *C* FORMAT 
  
          PROCESS LCC 
          ALLOC  LCC,X5+B1   ALLOC( LCC , WC+1 )
          BX6    X5 
          SA6    X2+B6
          SA0    A6+1 
          RJ     MWI         MWI( WC , LCC )
          EQ     GNIW 
 IDENT    SPACE  2,10 
**        IDENT  0,SY 
  
          PROCESS IDENT 
          SX3    X5 
          RJ     GAI
          SA1    A1-2        WORD A 
          MX0    42 
          BX6    X0*X1
          SA6    ERRL+2      SAVE NAME IN *ERR* LINE
          SA6    NAE+3       SAVE IN ASSEMBLY ERRORS MESSAGE
          SA6    IDT+1       SAVE NAME IN 77 TABLE
          SA1    =XHO$DATE
          SA2    A1+B1
          LX1    6
          LX2    6
          BX6    X1 
          BX7    X2 
          SA6    A6+B1
          SA7    A6+B1
          MOVE   3,=XHO$CCOP,IDT+CCO  CONTROL CARD OPTIONS
          EQ     GNIW 
 TITLE    SPACE  2,12 
**        TITLE  0,WC AND WC WORDS FOLLOW 
  
          PROCESS TITLE 
          SA4    =1H
          SA0    =XF$STITL+1
          BX6    X4 
          SA6    A0-B1       O.STITL(1) = 10H 
          SX6    X5+2 
          SA6    =XN$STITL   N$STITL = WC + 2 
          RJ     MWI         MWI( WC , O.STITL+1 )
          MX6    0
          SA6    A0          LINE TERMINATOR
          EQ     GNIW 
 COMMENT  SPACE  2,12 
*         COMNT  0,WC AND WC WORDS FOLLOW IN *H* FORMAT 
  
          PROCESS COMNT 
          SA0    IDT+COMMNT 
          RJ     MWI         MWI( WC , IDT+COMMENT )
          EQ     GNIW 
 LIB      SPACE  2
*         LIB - DEFINE LIBRARY NAME 
  
          PROCESS LIB 
          UX1    X5 
          LX1    12 
          ADDWRD LIB,X1      SAVE NAME IN *LIB* 
          EQ     GNIW 
 MWI      SPACE  3,14 
**        MWI - MOVE WORDS FROM INPUT BUFFER TO WORKING STORAGE 
* 
*         ENTRY  (X5) = WC
*                (A0) = FWA OF WS BUFFER
* 
*         EXIT   (A0) = LWA+1 
*                (A7,X7) = LWA AND [LWA]
  
 MWI1     GNIW               GET WORD FROM INPUT
          BX7    X5 
          SA7    A0          STORE IN WS BUFFER 
          SA0    A0+B1       FWA = FWA + 1
          SX0    X0-1        WC = WC - 1
          NZ     X0,MWI1     IF WC " 0
 MWI      ROUTINE 
          SX0    X5 
          EQ     MWI1 
 USEBLK   SPACE  3,14 
**        USBLK - TERMINATE INITIAL CARD GROUP PROCESSING 
  
          PROCESS USBLK 
          SX6    A5 
          SA6    IBUF        IBUF = II     */ SAVE INPUT BUFFER POINTER 
          ADDWRD LIB,0       TERMINATE LIB TABLE
          ADDWRD LCC,0       TERMINATE LCC TABLE
          SA1    HO$B 
          ZR     X1,USBLK4   IF B = 0 
  
*         OUTPUT *LCC* DIRECTIVES TO *LGO* AS SEPERATE RECORDS
  
          BX5    X2          (X5) = O.LCC 
 USBLK1   SA4    X5          WORD COUNT 
          ZR     X4,USBLK2   IF [FWA] = 0  */ END OF LCC TABLE
          SB6    X5+B1
          SX5    B6+X4       FWA = FWA + 1+[FWA]
          WRLGO  B6,X4       LCC DIRECTIVE TO LGO 
          WRITER F.LGO,,R 
          EQ     USBLK1 
  
 USBLK2   WRLGO  IDT,15      OUTPUT 77 TABLE
  
 USBLK4   CALL   CG$ASN      ADJUST SYMTAB
  
*         SCAN *SYM* AND APPEND A $ TO NAMES THAT CONFLICT WITH 
*         REGISTER NAMES
  
          SA1    O.SYM
          SA2    L.SYM
          SA1    X1 
          MX0    -6 
          SB4    1RX
          SB6    6
          SX5    1R$
          SB3    B1+B1
          LX5    42 
          SX4    B6 
          BX5    X4+X5
  
 USBLK4A  SX2    X2-3 
          ZR     X2,USBLK4C  IF FINISHED
          SA1    A1+3        NEXT NAME
          BX3    -X0*X1 
          LX6    B6,X1
          SX4    X3-12
          NZ     X4,USBLK4A  IF NOT A 2 CHAR NAME 
          BX7    -X0*X6 
          SB2    X7 
          LE     B2,B3,USBLK4B     IF FIRST CHAR IS A OR B
          NE     B2,B4,USBLK4A     IF NOT X 
 USBLK4B  LX6    6
          BX7    -X0*X6 
          SX6    X7-1R0 
          MI     X6,USBLK4A 
          SX6    X7-1R8 
          PL     X6,USBLK4A 
  
          IX6    X5+X1       APPEND $ TO THE NAME 
          SA6    A1 
          EQ     USBLK4A
  
 USBLK4C  SA5    BCDC 
          ZR     X5,USBLK9A  IF BCDC = 0   */ OL & C = 0
  
          NUPAGE             FORCE EJECT AND OUTPUT TITLE 
          SA2    =8LIDENT 
          SA3    IDT+1
          RJ     FSP         OUTPUT IDENT LINE
          SA5    BCDC 
          PL     X5,USBLK5   IF C = 0 
  
          SA3    N$STITL
          SA4    =10H  TITLE
          BX6    X4 
          SA6    F$STITL
          SB7    X3 
          LE     B7,B1,USBLK5      IF L.STITL @ 1 
          WRITEC F.CMPS,A6,B7 
  
*         LIST *LCC* DIRECTIVES 
  
 USBLK5   SA4    O.LCC
          SA5    X4 
          SB5    X5          WC = [LCC] 
          ZR     X5,USBLK7   IF WC = 0
          SA2    =1H
          SA3    =8LLCC 
          SB4    12          UBC = 12 
          BX6    X2 
          SA6    LBUF 
          BX7    X3 
 USBLK6   SA5    A5+B1
          SB3    60 
          BX6    X5 
          RJ     ADC
          NZ     B5,USBLK6
          SX6    A5+B1
          SA6    O.LCC
          RJ     TSB         TERMINATE THE LINE 
          WRTEXT 0           AND LIST IT
          EQ     USBLK5 
  
 USBLK7   SA1    O.LCC
          SA2    L.LCC
          SX2    X2-1 
          IX6    X1-X2       RESET O.LCC
          SA6    A1 
  
*         LIST THE LIB DIRECTIVES 
  
          SA5    O.LIB
          SX0    X5+2 
 USBLK8   SA2    =8LLIB=
          SA3    X0 
          SX0    X0+B1
          ZR     X3,USBLK9   IF END OF THE TABLE
          RJ     FSP         FORMAT AND LIST  LIB=  LIBNAME 
          EQ     USBLK8 
  
 USBLK9   SA2    =8LUSEBLK
          SA3    =1H
          RJ     FSP         FORMAT AND LIST *USEBLK* LINE
 USBLK9A  SA1    O.LIB
          SA2    L.LIB
          SB6    X1 
          SB7    X2-1 
          SB2    B1+B1
          EQ     B7,B2,USBLK10     IF L.LIB = 3 
          SX6    LT.LDSET 
          LX6    12 
          SX4    B7-B1
          BX6    X4+X6
          LX6    36 
          SA6    B6          HEADER WORD
          SX7    LS.LIB 
          LX7    12 
          SX4    X4-1 
          BX7    X7+X4
          LX7    36 
          SA7    A6+B1       LIB SUBTABLE HEADER WORD 
          WRLGO  B6,B7       OUTPUT LIB TABLE TO *LGO*
  
*         SCAN *CBT* AND SETUP THE *PIDL* TABLE 
  
 USBLK10  SA5    L.CBT
          AX5    1
          MX7    0           L.LCC = 0
          SA7    L.LCC
          ALLOC  PIDL,X5+2   ALLOC( PIDL , L.CBT/2+2 )
          SB6    X2 
          SB7    B1+B1       INDEX
          SA1    O.CBT
          SA2    X1 
          SA3    X1+B1
          MX0    -24
          SB5    B1          PD = 1        */ PIDL TBL DECRMENT 
          ZR     X3,USBLK14  IF LEN = 0    */ // COMM NOT REFED 
          SB5    B1+B1       PD = 2 
          SX6    B5+B1
          SA6    CCB         CCB = 3
          EQ     USBLK12
  
 USBLK11  SA2    A2+2        FETCH NEXT ENTRY 
          SA3    A3+2 
 USBLK12  BX4    -X0*X3 
          PL     X3,USBLK13  IF ^LCM RESIDENT 
          MX7    -3 
          IX4    X4-X7
          AX4    3           ROUND UP TO NEAREST 8
          SX7    B1 
          LX7    17 
          BX4    X7+X4       SET LCM BIT
 USBLK13  BX6    X2+X4
          SA6    B6+B7       STORE ENTRY IN PIDL
          SB7    B7+B1       BUMP INDEX 
 USBLK14  SX5    X5-1 
          NZ     X5,USBLK11  IF NOT FINISHED
  
          SX7    B7-B5       L.PIDL = INDEX - PD
          SX6    B6+B5
          SA7    L.PIDL 
          SA6    O.PIDL 
          SX7    B7-B1       LEN = INDEX - 1
          LX7    36 
          SB2    LT.PIDL-2000B
          PX6    B2,X7
          SA6    B6          STORE HEADER 
          SA3    =XN$SLBT 
          SA4    IDT+1
          BX6    X3+X4
          SA6    B6+B1       STORE PROG NAME AND LENGTH 
  
          WRLGO  B6,B7       PIDL TABLE TO LGO
  
*         SETUP *LBIT*
  
          SA5    =XN$LBT
          LX1    B1,X5
          ALLOC  LBIT,X1     ALLOC( LBIT , 2*N$LBT )
          SX0    B1 
          LX0    AD.RBP 
          SB2    4
          PX0    B2,X0
          SA4    =XF$LBT
 USBLK16  SX4    X4          FWA
          BX6    X4+X0
          SA6    X2 
          MX7    0
          SA7    X2+B1
          SX5    X5-1 
          SX2    A7+B1
          SA4    A4+B1
          NZ     X5,USBLK16 
  
*         LIST THE BLOCKS ( NAME TYPE ADDR  LENGTH )
  
          SA1    BCDC 
          SX1    X1+
          ZR     X1,USBLK28  IF OL = 0 OR C " 0 
          MOVE   4,BLKA,LBUF
          LISTL  (=8L ),1    BLANK LINE 
          LISTL  OBUF,8      BLOCK MAP TITLE
          SA1    =10HLOCAL
          BX6    X1 
          SA6    LBUF+1 
          SA5    F$LBT
          SA1    N$LBT
          SX0    X1 
          SA0    LBNT 
  
 USBLK18  SA4    A0          10H NAME 
          SA0    A0+B1
          SX1    X5          FWA
          BX6    X4 
          SA6    LBUF 
          CALL   COD= 
          LX6    24 
          SA6    LBUF+2 
          SX1    X5 
          SA5    A5+B1
          SX6    X5 
          IX1    X6-X1
          CALL   COD=        LENGTH 
          LX6    24 
          MX7    -12
          BX6    X7*X6
          SA6    A6+B1
          LISTL  OBUF,8 
          SX0    X0-1 
          NZ     X0,USBLK18 
  
*         LIST THE COMMON BLOCKS
  
          MOVE   3,BLKB,LBUF
          SA2    L.CBT
          SA3    O.CBT
          SX0    X2 
          SA5    X3+B1
          ZR     X5,USBLK25  IF // COM NOT REFED
  
 USBLK24  MX7    -24
          BX1    -X7*X5 
          CALL   COD= 
          LX6    24 
          MX7    -12
          BX6    X7*X6
          SA6    LBUF+3 
          LISTL  OBUF,8 
  
 USBLK25  SX0    X0-2        LEN = LEN - 2
          ZR     X0,USBLK26  IF END OF CBT
          SA1    A5+B1
          RJ     FSN         COUNT CHARS IN NAME
          SA3    =1H
          SB2    B3-B1
          MX2    B2 
          BX3    -X2*X3 
          BX6    X1+X3       BLANK FILL 
          SA6    LBUF 
          SA5    A1+B1
          EQ     USBLK24
  
 USBLK26  LISTL  (=8L ),1    BLANK LINE 
  
*         REFORMAT THE *PIDL* TABLE 
  
 USBLK28  SA3    L.PIDL 
          SA2    O.PIDL 
          ZR     X3,USBLK30  IF L.PIDL = 0
          BX0    -X3
          SA1    X2 
          SX1    0           SET FOR BLANK COMMON 
  
 USBLK29  MX2    42 
          BX1    X2*X1
          RJ     FSN         COUNT CHARS IN NAME
          SX3    1R/
          BX1    X1+X3
          LX1    -6 
          SB4    B3-48
          LX3    -B4
          BX1    X3+X1
          SX2    X2+12       NBITS = NBITS + 12 
          BX6    X1+X2
          SA6    A1 
          SX0    X0+B1
          SA1    A1+B1
          NZ     X0,USBLK29 
  
*         SETUP THE *ENTR* TABLE
  
 USBLK30  SA5    N.ENT
          ZR     X5,USBLK35  IF N.ENT = 0 
          LX4    B1,X5
          ALLOC  ENTR,X4+B1  ALLOC( ENTR , 2*N.ENT+1 )
          SB6    X2 
          SB7    B1 
          SB2    LT.ENTR-2000B
          LX5    37 
          PX6    B2,X5
          SA6    B6          STORE HEADER WORD
          LX5    -37
          SA4    O.SYM
          MX0    42 
          SA1    X4+B1
  
 USBLK31  SA1    A1+3 
          LX1    59-WB.ENTP 
          PL     X1,USBLK31  IF ^ENT[WORDB] 
          SA2    A1-B1
          SA3    A1+B1
          BX6    X0*X2
          SA6    B6+B7
          SX7    X3          RA 
          SX4    B1          RB = 1        */ PROG RELOC
          LX3    58-AR.RLP
          PL     X3,USBLK32  IF ^ COMMON RELOC
          LX3    2+AR.RLP-AR.RBP
          MX4    -AR.RBL
          BX4    -X4*X3 
          SA2    CCB
          IX4    X4+X2       RB = CCB + RB[WORDC] 
 USBLK32  LX4    18 
          BX7    X4+X7
          SA7    A6+B1
          SB7    B7+2 
          SX5    X5-1 
          NZ     X5,USBLK31 
  
          WRLGO  B6,B7       ENTRY TABLE TO LGO 
  
*         OUTPUT ENTRY STATEMENTS TO *COMPS*
  
          SA1    BCDC 
          PL     X1,USBLK34  IF C = 0 
  
          SA1    O.ENTR 
          SA2    L.ENTR 
          AX0    B1,X2
          SA5    X1+B1
          BX3    X5 
  
 USBLK33  SA2    =8LENTRY 
          RJ     FSP
          SX0    X0-1 
          SA5    A5+2 
          BX3    X5 
          NZ     X0,USBLK33 
  
 USBLK34  SX6    0
          SA6    L.ENTR      L.ENTR = 0 
  
 USBLK35  SA1    BCDC 
          ZR     X1,USBLK45  IF BCDC = 0
          SA2    XCI
          LX2    -AR.XCIP 
          SX5    X2 
          ZR     X5,USBLK45  IF XCI = 0 
          PL     X1,USBLK38  IF OL
  
*         OUTPUT *EXT* STATEMENTS TO *COMPS*
  
 USBLK36  SA2    =8LEXT 
          SA4    O.SYM
          SB5    X5 
          SA3    X4+B5       WORD A 
          SA5    A3+2        WORD C 
          MX7    42 
          BX3    X7*X3
          LX5    -AR.XCIP 
          SX5    X5 
          RJ     FSP         OUTPUT EXT STMT
          NZ     X5,USBLK36  IF NOT END OF CHAIN
  
          EQ     USBLK45
  
*         OUTPUT O-LIST OF EXTERNAL NAMES 
  
 USBLK38  SA1    =10HEXTERNALS
          MX7    0
          BX6    X1 
          SA6    LBUF 
          SA7    A6+B1
          LISTL  OBUF,6 
  
 USBLK39  SB7    LBUF        INDEX
          SB6    LBUF+6      LIMIT
          SA1    O.SYM
          SB5    X1+2 
  
 USBLK40  SA4    B5+X5
          LX4    -AR.XCIP 
          SX5    X4          NEXT 
          SA1    A4-2 
          MX2    -6 
          BX6    X2*X1
          BX1    -X2*X1 
          SB3    X1 
          SA3    =1H
          SB2    B3-B1
          MX2    B2 
          BX3    -X2*X3 
          BX6    X6+X3
          SA6    B7 
          SB7    B7+B1
          ZR     X5,USBLK41  IF END OF THE CHAIN
          LT     B7,B6,USBLK40     IF LINE NOT FULL 
  
 USBLK41  MX6    0
          SA6    B7 
          SB7    B7+B1
          LISTL  OBUF,B7-B6 
          NZ     X5,USBLK39  IF MORE NAMES TO PROCESS 
  
          LISTL  (=8L ),1 
  
*         REFORMAT *CBT* FOR USE BY CUB, BIN OUTPUT ROUTINES, ETC 
  
 USBLK45  SA1    O.CBT
          SA2    L.CBT
          SA3    CCB
          SB5    AD.RBP 
          SB6    4
          MX0    1
          SB2    X1          I = 0
          SB3    X2+B2       N = L.CBT
          BX7    X3          R = CCB
          SB4    2
  
 USBLK46  SA2    B2+B1
          BX4    X0*X2
          SA7    A2          CBT(I+1) = R 
          LX4    1+AD.LCMP
          LX6    B5,X7
          PX5    B6,X6
          BX6    X4+X5
          SA6    B2 
          SX7    X7+B1
          SB2    B2+B4       I = I + 2
          LT     B2,B3,USBLK46
  
*         SETUP TEXT TABLE, ETC FOR PROCESSING
  
          SA1    IL.LAF 
          SX7    0
          SA7    L.LAFT      L.LAFT = 0 
          ALLOC  LAFT,X1     ALLOC( LAFT , IL.LAF )  */ INITIAL ALLOC 
          IFEQ   HC.TS,0,2
          SX6    =XTOVA#
          SA6    =XTO#       TO = TOVA     */ SET ASSEMBLER OVERFLOW EXIT 
          SX0    B1 
          LX0    AD.RBP 
          SB2    4           PR = 4 
          MX6    0
          PX7    B2,X0
          SA7    AI 
          SA6    CW          CW = 0 
          SA6    TI          TI = 0 
          SB3    LT.XTXT-2000B
          PX7    B3,X0
          SA7    A6+B1       TH = 12/LT.XTXT,12/0,36/RBOC 
          SA6    A7+B1       TR = 0 
          SA6    RBWORD      RBWORD = 0 
          SA4    IBUF 
          SA5    X4          II = [IBUF]   */ RESTORE INPUT BUFFER PTR
          EQ     GNIW 
  
 BLKA     DIS    ,/BLOCK     TYPE      ADDRESS   LENGTH/
 BLKB     DATA   30H/ /       COMMON         0
 FSN      SPACE  2,14 
**        FSN - FORMAT SYMBOL NAME
* 
*         ENTRY  (X1) = 0L_NAME 
* 
*         EXIT   (X6) = 54/0L_NAME,6/NBITS
*                (X2,B3) = NBITS , 6*N-CHARS-IN-NAME
* 
*         USES   X1 - X7, B3, A5
  
 FSN      ROUTINE 
          SX3    B1 
          SA5    =40404040404040404040B 
          IX4    X1-X3
          BX3    -X4+X1 
          SB3    60-5 
          BX4    X5*X3
          LX3    B3,X4
          IX2    X4-X3
          BX6    X2+X4       MASK OF 77 "S
          AX6    12 
          BX4    -X6
          PX6    X4 
          NX3    B3,X6
          SX2    B3 
          BX6    X1+X2
          EQ     FSN
 FSP      SPACE  3,14 
**        FSP - FORMAT AND LIST SIMPLE PSEUDO 
* 
*         ENTRY  (X2) = 8L_PSEUDO-NAME
*                (X3) = 0LNAME
  
 FSP      ROUTINE 
          SA1    =1H
          LX3    12 
          BX7    X1 
          MX4    48 
          SA7    LBUF 
          BX6    -X4*X3 
          BX7    X2+X6
          SA7    A7+B1
          BX7    X4*X3
          SB4    12 
          RJ     TSB         TERMINATE BUFFER 
          WRTEXT 0           AND LIST IT
          EQ     FSP
 CG$ASN   SPACE  3,14 
**        CG$ASN - ADJUST SYMBOL NAMES IN *SYM* AND *QBT* 
  
 CG$ASN   ENTRY. ** 
  
*         REFORMAT NAME WORDS OF SYMTAB 
  
          SA1    O.SYM
          SA2    L.SYM
          SB5    X2-3 
          SA1    X1+3 
  
 ASN1     MX0    6*HC.MCIS
          BX1    X0*X1
          RJ     FSN         FORMAT NAME
          SA6    A1 
          SB5    B5-3 
          SA1    A1+3 
          NZ     B5,ASN1
  
*         REFORMAT *QBT*
  
 .QBT     IFNE   HC.QBT,0 
          SA1    O.QBT
          SA2    L.QBT
          SB5    X2-2 
          SA1    X1+B1
          LE     B5,ASN3
  
 ASN2     SA1    A1+1 
          RJ     FSN
          SA6    A1 
          SB5    B5-B1
          NZ     B5,ASN2
  
 ASN3     BSS    0
  
 .QBT     ENDIF 
  
*         SETUP *EXT* CHAIN AND COUNT NUMBER OF ENTRY POINTS AND
*         EXTERNALS 
  
          SA1    O.SYM
          SA2    L.SYM
          SA5    ASNA 
          SB4    X1+2 
          SB5    X2-3 
          SB6    B0          N.ENT = 0
          SB7    B0          N.EXT = 0
          SA1    X1+B1
          MX7    2           XC = 0 
          EQ     ASN5 
  
 ASN4     SB6    B6+1        N.ENT = N.ENT + 1
  
 ASN5     SA1    A1+3 
          SB5    B5-3        LS = LS - 3
          MI     B5,ASN6     IF END OF SYMTAB 
          BX2    X1 
          LX2    59-WB.LABP 
          MI     X2,ASN5     IF LAB[WORDB]
          BX4    X5*X1
          LX1    59-WB.ENTP 
          ZR     X4,ASN5     IF ^( EXT ! ENT )
          MI     X1,ASN4     IF ENT 
  
          SB7    B7+B1       N.EXT = N.EXT + 1
          SA7    A1+B1       WORDC = XC    */ CHAIN POINTS TO LAST
          SX4    A7-B4
          MX6    2
          LX4    AR.XCIP
          BX7    X6+X4       XCI = INDEX OF THIS
          EQ     ASN5 
  
 ASN6     SA7    XCI
          SX6    B6 
          SX7    B7+B1
          SA6    N.ENT
          AX7    1
          SX7    X7+B1
          SA7    IL.LAF      IL.LAF = (N.EXT+1)/2 + 1 
          EQ     CG$ASN 
  
 ASNA     BFMW   WB,(EXT,ENT) 
 ADC      TITLE  DISPLAY CODE CONVERSION ROUTINES 
**        BFN - BLANK FILL NAME MACRO 
* 
*         ENTRY  X6,B3 = NAME AND BIT COUNT 
*         EXIT   BLANK FILLED NAME IN REGISTER *RR* 
* 
*         USES   A2, B2, X2, X3 
  
 BFN      MACRO  RR 
          SA3    =1H
          SB2    B3-B1
          MX2    B2 
          BX3    -X2*X3 
          B;A    X6+X3
          ENDM
 ADC      SPACE  2
**        ADC - ADD CHARACTERS TO STRING
* 
*         ENTRY  (X6) = CHAR STRING 
*                (B3) = BC , BIT COUNT
*                (X7) = ASSEMBLED STRING IN 0L FORMAT 
*                (B4) = UBC , UNUSED BIT COUNT ( FOR X7 ) 
* 
*         USES   X - 2, 3, 4, 6   B - 2, 3, 4 
  
 ADC      ROUTINE 
          SB2    B4-B1
          MX4    B2 
          BX3    X4*X6
          LX2    B4,X3
          BX7    X2+X7
          BX4    -X4*X6 
          LX6    B4,X4
          SB4    B4-B3       UBC = UBC - BC 
          GT     B4,ADC      IF UBC > 0 
          SA7    A7+B1       STORE CURRENT WORD 
          SB4    B4+60       UBC = UBC + 60 
          BX7    X6 
          EQ     ADC
 TSB      SPACE  2
**        TSB - TERMINATE STRING BUFFER 
* 
*         ENTRY  (X7) LAST WORD OF ASSEMBLED STRING 
*                (B4) = UBC 
* 
*         EXIT   LINE WRITTEN TO *COMPS* IF BCDC < 0
*                (LBUF.WC) = NUMBER OF WORDS IN LBUF
* 
*         PRESERVES X1 IF C = 0 ( NEEDED IN *RJXJ* PROCESSOR )
  
 TSB0     SB7    A7+B1
          SB6    LBUF 
          SB7    B7-B6       (B7) = WORD COUNT
          SA2    BCDC 
          SX6    B7+
          SA6    LBUF.WC
          PL     X2,TSB      IF BCDC \ 0
          WRITEC F.CMPS,B6,B7      WRITE LINE TO COMPS FILE 
  
 TSB      ROUTINE 
          SA7    A7+1        STORE LAST WORD
          SB3    12 
          GE     B4,B3,TSB0  IF 12 BIT LINE TERMINATOR PRESENT
          MX7    0
          SA7    A7+B1       STORE A ZERO WORD
          EQ     TSB0 
 CMA      SPACE  3,14 
**        CMA - CONVERT MACRO ARGUMENT TO DISPLAY CODE
* 
*         ENTRY  (X2) = ARG VALUE 
*                (X4) = ARG TYPE ( 1 - 6 )
* 
*         EXIT   (X6) = 0L_BCD-STRING 
*                (B3) = BC , BIT COUNT ( 6*N.CHARS IN STRING )
* 
*         USES   X - 2, 3, 4, 6   B - 2, 3
  
 CMA      ROUTINE 
          SB2    X4 
          JP     CMA.JT-1+B2
  
 CMA.JT   BX6    X2 
          LX2    59-23
          EQ     CMA.C
  
          EQ     CMA.B
  
          EQ     CMA.S
  
          SB2    X2 
          MX6    -6 
          EQ     CMA.Q
  
          SX6    1R(
          EQ     CMA.M
  
*         CONVERT CONSTANT
  
 CMA.C    MI     X2,CMA.C1   IF VAL < 0 
          RJ     CON
          LX6    6
          SB3    B3-6 
          EQ     CMA
  
 CMA.C1   AX2    59-23
          BX6    -X2
          RJ     CON
          SX4    1R-
          LX4    54 
          BX6    X4+X6       *-NNNB*
          EQ     CMA
  
 CMA.S    CALL   CSN#        CONVERT NAME 
          EQ     CMA
  
 CMA.Q    BSS    0
 .HC      IFNE   HC.QBT,0 
          SA3    O.QBT       QUAL BLOCK NAME
          SA4    X3+B2
          BX3    -X6*X4 
          SB3    X3 
          BX6    X6*X4
          EQ     CMA
 .HC      ENDIF 
  
 CMA.B    SX6    X2-1S15
          MI     X6,CMA.B1   IF A COMMON BLOCK
          SA3    LBNT+X6
          SB3    42 
          MX6    42 
          BX6    X6*X3
          EQ     CMA
  
 CMA.B1   SA3    O.PIDL 
          MX6    -6 
          SB2    X2 
          SA4    X3+B2
          BX3    -X6*X4 
          SB3    X3 
          BX6    X6*X4
          EQ     CMA
  
 CMA.M    LX2    1           CONVERT MICRO NUMBER TO MIC VALUE
          SB6    X2 
          SB3    6
          LX6    -6 
          RJ     ADC         ADD LEFT PAREN 
          SA4    =XF$MIC-2+B6 
          SA3    A4+B1
          BX6    X4 
          SB3    X3 
          RJ     ADC         ADD STRING 
          SX6    1R)
          SB3    6
          LX6    -6 
          EQ     CMA
 CON      SPACE  3,14 
**        CON - CONVERT OCTAL NUMBER TO DISPLAY CODE
* 
*         ENTRY  (X6) = BINARY NUMBER ( \ 0 ) 
* 
*         EXIT   (X6) = 0L:NNNB 
*                (B3) = BIT COUNT 
* 
*         USES   X - 2, 3, 4, 6   B - 2, 3
  
 CON0     SX6    X6+1R0 
          LX6    -12
 CON      ROUTINE 
          MX2    -3 
          SB3    12          BC = 12
          BX3    X2*X6
          ZR     X3,CON0     IF NUM < 8 
          SX4    1RB
  
 CON1     BX3    -X2*X6 
          LX4    -6 
          SX3    X3+1R0 
          AX6    3
          IX4    X3+X4
          SB3    B3+6        BC = BC + 6
          NZ     X6,CON1
  
          LX4    -12
          BX6    X4 
          EQ     CON
 FMC      SPACE  3,14 
**        FMC - FORMAT MACRO CALL ( CONVERT TO BCD )
* 
*         ENTRY  (X1) = MACRO HEADER WORD ( 36/6L_NAME,3/LAB,18/PAR,3/NP
* 
*         EXIT   MACRO CALL FORMATTED AS A BCD LINE IMAGE AND STORED IN 
*         *LBUF*. WRITTEN TO *COMPS* IF C OPTION SELECTED.
* 
*         PRESERVES - A0, X0, A5, X5
  
 FMC      ROUTINE 
          SA2    =1H
          SB5    B1          AN = 1        */ ARG NUMBER
          BX7    X2 
          SA7    LBUF        LBUF(1) = 10H
          BX4    X1 
          LX4    59-21
          MI     X4,FMC1     IF ^ LAB      */ 1ST ARG NOT IN LABEL FIELD
          AX4    56 
          SA2    PBUF+1 
          RJ     CMA         CONVERT MACRO ARG
          BFN    X7          BLANK FILL THE NAME
          SX3    B1                        */ SET LOW BIT IN CASE LABEL 
          BX7    X3+X7                     */ FIELD WAS ABSENT
          LX7    -6 
          SA7    A7          LBUF(1) = SHIFT( CMA(A1)) , 6 )
          SB5    B1+B1       AN = 2 
  
*         SETUP REGISTERS FOR THE MAIN LOOP 
  
 FMC1     MX2    36 
          SX3    1R 
          BX7    X2*X1       ASR = 6L_MAC-NAME  */ ASSEMBLY REGISTER
          SB4    18          UBC = 18      */ UNUSED BIT COUNT
          LX3    18 
          BX7    X3+X7       ASR = ASR + SHIFT( 1R  , 18 )
          MX6    -3 
          BX1    X6*X1
          LX1    42          PTW = SHIFT( MHW , 42 ) */ PARAM TYPE BYTES
          EQ     B5,B1,FMC2  IF AN = 1
          LX1    3           PTW = SHIFT( PTW , 3 ) 
  
 FMC2     SA2    PBUF+B5     ARGV = PBUF(AN)
          MX6    -3 
          BX4    -X6*X1      PTB = PTW & 7
          LX1    3           PTW = SHIFT( PTW , 3 ) 
          SB5    B5+B1       AN = AN + 1
          ZR     X4,FMC4     IF PTB = 0    */ END OF ARBS 
          BX6    -X6*X1 
          ZR     X6,FMC3     IF THIS ARG IS THE LAST ARG
          RJ     CMA         CONVERT ARG
          SA2    FMCA 
          SB3    B3+6 
          SB2    B3-60
          LX2    -B2
          BX6    X2+X6
          RJ     ADC         ADD *ARG-VAL,* TO STRING 
          EQ     FMC2 
  
 FMC3     RJ     CMA         CONVERT LAST ARG 
          RJ     ADC
  
 FMC4     RJ     TSB         TERMINATE BUFFER , WRITE IT TO COMPS 
          EQ     FMC
  
 FMCA     DATA   1R,
 FBD      SPACE  3,14 
**        FBD - FORMAT BINARY DATA. SETS UP FIRST 40 COLUMNS OF PRINT 
*                LINE TO - ADDRESS, DATA IN OCTAL AND RELOCATION. 
*                CALLED BY A EQ JUMP FROM *APT* 
* 
*         ENTRY  (B2) = PR  , (B3) = NP  , (X4) = DATA
* 
*         DESTROYS X5 
  
 FBD      SA1    NLF
          NZ     X1,APT      IF NLF " 0    */ *FPC*  CALL TO APT
  
          ZR     B3,FBD4     IF NP = 0
          GT     B3,B4,FBD5  IF NP > 2
  
          SA1    LBUF 
          NZ     X1,FBD0     IF LBUF " 0   */ INST CONVERTED TO BCD 
          SA1    BCDC 
          ZR     X1,FBD0     IF BCDC = 0
          RJ     FMI         FORMAT MACHINE INSTRUCTION 
  
 FBD0     NE     B3,B1,FBD3  IF NP = 2
  
          SA1    =5A00000 
          RJ     CDO         CONVERT DATA TO OCTAL
          SX2    B2 
          SA7    OBUF+3      BLANKS TO RELOC WORD 
          LX2    -1 
          BX3    -X2
          PL     X2,FBD1     IF PR IS EVEN
          LX6    30 
 FBD1     SA6    OBUF+2+X3   STORE NNNNNBBBBB 
          SA7    OBUF+1+X2   STORE BLANK WORD 
  
*         FORMAT ADDRESS AND LIST THE LINE
  
 FBD2     SA1    BCDC 
          SX5    B3+
          MI     X1,FBD2A    IF C " 0 
          SA1    AI 
          MX2    -AD.ORGCL
          SX5    B3 
          SA3    =1H
          UX7    B2,X1
          BX1    -X2*X1 
          SB4    B2+B3
          BX6    X3          SET RESULT = BLANKS
          SB4    B4-4 
+         NZ     B4,*+1      IF PR+NR " 4 THEN OBUF(1) = BLANKS 
          CALL   COD=              ELSE ADDR
          LX6    6
          SA6    OBUF 
          SA3    LBUF.WC
          LISTL  A6,X3+4     LIST THE LINE
          SA1    RERR 
          ZR     X1,FBD2A    IF RERR = 0   */ NO INSTRUCTION ERROR
          SX6    X1+3R000 
          LX6    42 
          MX7    18 
          BX6    X7*X6
          SA6    A1 
          LISTL  FBDA,4      -  **** ABOVE INST IN ERROR - XXX -
          SX6    0
          SA6    RERR        RERR = 0 
  
 FBD2A    MX6    0
          SA6    LBUF        LBUF = 0 
          LX5    59-1 
          SA3    AI 
          SX6    B1 
          UX7    B2,X3
          SA6    LBUF.WC     LBUF.WC = 1
          PL     X5,APT      IF NP " 2
          EQ     APT6 
  
 FBDA     DATA   30L  ***** ABOVE INST IN ERROR -  XXX
 RERR     BSSZ   1           XOR OF MASK AND REG TYPES
  
*         PROCESS 2 PARCEL DATUM
  
 FBD3     RJ     CRI
          SA1    =10H0000000000 
          SA6    OBUF+3 
          RJ     CDO         CONVERT DATA 
          SX2    B2 
          LX2    -1 
          BX3    -X2
          NE     B2,B1,FBD1  IF PR " 1     */ NOT SPLIT WORD CASE 
          MX3    30 
          BX7    X3*X7       5L 
          BX4    -X3*X6      L
          BX6    X3*X6       U
          LX6    30 
          BX6    X7+X6
          SA6    OBUF+1 
          BX7    X4+X7
          LX7    30 
          SA7    A6+B1
          EQ     FBD2 
  
*         PROCESS 0 PARCEL DATUM
  
 FBD4     SA1    =1H
          BX7    X1 
          SA7    OBUF+1 
          SA7    A7+B1
          SA7    A7+B1
          EQ     FBD2 
  
*         PROCESS FULL WORD OF DATA 
  
 FBD5     RJ     CFW
          SA7    OBUF+1 
          SA6    A7+B1
          RJ     CRI         CONVERT RELOC INFO 
          SA6    OBUF+3 
          EQ     FBD2 
 CDO      SPACE  2,8
**        CDO - CONVERT DATA TO OCTAL 
* 
*         ENTRY  (X1) = FILL WORD ( 10H XXXXX ) 
*                (X4) = DATA
* 
*         EXIT   (X6) FILL WORD WITH BCD CONVERSION 
*                (X7) = 10H 
  
 CDO1     BX7    -X6*X4 
          AX4    3
          LX7    B5 
          IX1    X1+X7
          SB5    B5+6 
          NZ     X4,CDO1
  
          BX6    X1 
          SA1    =1H
          BX7    X1 
  
 CDO      ROUTINE 
          MX6    -3 
          SB5    B0 
          EQ     CDO1 
 CFW      SPACE  2,14 
**        CFW - CONVERT FULL WORD 
* 
*         ENTRY  (X4) = DATA
* 
*         EXIT   (X6,X7) = LOWER 10, UPPER 10 DIGITS
  
 CFW      ROUTINE 
          SA1    =10H0000000000 
          MX6    30 
          BX2    -X6*X4 
          LX4    30 
          BX4    -X6*X4 
          RJ     CDO         CONVERT UPPER
          BX3    X6 
          BX4    X2 
          SA1    =10H0000000000 
          RJ     CDO         CONVERT LOWER
          BX7    X3 
          EQ     CFW
 CRI      SPACE  2,12 
**        CRI - CONVERT RELOCATION INFORMATION TO DISPLAY CODE
* 
*         EXIT   (X6) = 10H-RELOC-INDICATOR 
  
 CRI      ROUTINE 
          SA1    RBWORD 
          LX1    58-AR.RLP
          PL     X1,CRI1     IF RL < 2
          SA2    =10H  <EXT>
          LX1    1
          MI     X1,CRI2     IF RL = 3
  
          SA3    O.PIDL 
          MX6    -AR.RBL
          LX1    1+AR.RLP-AR.RBP
          BX6    -X6*X1 
          IX7    X3+X6
          SA2    X7 
          MX6    -6 
          BX3    -X6*X2 
          BX6    X6*X2
          SB4    X3-1 
          SA3    =1H
          MX2    B4 
          BX3    -X2*X3 
          BX6    X6+X3
          LX6    -6 
          EQ     CRI
  
 CRI1     SA2    =1H
          LX1    1
          PL     X1,CRI2     IF RL = 0
          SA2    =2A+ 
 CRI2     BX6    X2 
          EQ     CRI
 FMI      TITLE  FMI - FORMAT MACHINE INSTRUCTION 
**        FMI - FORMAT MACHINE INSTRUCTION ( CONVERT TO DPC ) 
* 
*         ENTRY  (X4) = BINARY
*                (B3) = NP ( 1 OR 2 ) 
* 
*         PRESERVES - A0, X0, A5, X5, X4, B2, B3
  
  
 FMI      ROUTINE 
          PX6    B3,X4
          BX7    X0 
          SA6    FMIA 
          SA7    FMIB        SAVE X0, B3 AND X4 
          MX1    -3 
          BX7    -X1*X4      K = BINARY & 7 
          EQ     B3,B1,FMI1  IF NP = 1
          AX4    15          BINARY = SHIFT(BINARY,-15) 
          SX7    X4          K = SETX(BINARY) 
 FMI1     SA7    K
          DUP    2,3
          AX4    3           BINARY = BINARY / 8
          BX7    -X1*X4      I,J = BINARY & 7 
          SA7    A7-B1
  
          AX4    3           OPC = BINARY/8 
          SB5    B1+B1
          SB4    X4-1 
          GT     B4,B5,FMI2  IF OPC > 3 
          EQ     B4,B1,FMI4  IF OPC = 2 
  
          SA1    FMI.XJ+X7   DW = FMI.XJ(I) 
          NZ     B4,FMI5     IF OPC = 3 
          ZR     X7,FMI4     IF I = 0      */ RJ INSTRUCTION
          SA1    FMI.LCM+X7  DW = FMI.LCM(I)
          EQ     FMI5 
  
 FMI2     SX3    X4-50B 
          MI     X3,FMI4     IF OPC < 50B 
  
          BX2    -X1*X4 
          SA1    FMI.SET+X2  DW = FMI.SET( OPC&7 )
          AX4    3
          SX4    X4-4 
          SX6    X4-3        TRANSLATE F TO A, B OR X 
          NZ     X6,FMI3
          SX4    1RX
 FMI3     LX4    48 
          BX1    X4+X1       DW = DW ! SHIFT(LETTER,48) 
          EQ     FMI5 
  
 FMI4     SA1    FMI.II-1+X4 DW = FMI.II(OPC-1) 
  
*         SETUP REGISTERS FOR MAIN LOOP 
  
 FMI5     SA2    =1H
          SB4    48          UBC = 48 
          BX7    X2 
          SA7    LBUF        LBUF(1) = 1H  ;  SI = 1
          MX3    12 
          BX7    X3*X1       W = DW & MASK(12)  */ FIRST 2 CHARS
          BX1    -X3*X1 
          LX1    12+5        DW = SHIFT(DW,12+5)
          MX0    -5 
  
 FMI6     BX6    -X0*X1      C = DW & 37B 
          LX1    5           DW = SHIFT(DW,5) 
          SB6    X6 
          SB5    6
          GE     B6,B5,FMI7  IF C \ 6      */ NO SPECIAL PROCESSING 
  
          JP     B6+FMI.JT   JUMP( FMI.JT(C) )
  
 FMI7     SA2    FMI.JT+B6
          SB3    6           BC = 6 
          SX3    X6-9 
          SX6    X2+1R0 
          LX6    -6          CH = SHIFT(FMI.JT(C)+1R0,54) 
          MI     X3,FMI8     IF C < 9      */ REGISTER NUMBER 
  
          MX6    6
          LX3    1
          SA2    FMI.CH 
          LX4    B1,X3
          IX3    X3+X4
          SB5    X3 
          LX2    B5 
          BX6    X6*X2       CH = MASK(6) & SHIFT(FMI.CH,6*(C-9)) 
  
*         ADD CHARACTERS TO THE STRING
  
 FMI8     LX6    B4 
          BX7    X6+X7       W = W ! SHIFT(CH,UBC)
          SB4    B4-B3       UBC = UBC - BC 
          NZ     B4,FMI6     IF UBC " 0 
          SA7    A7+B1       SI = SI + 1;  LBUF(SI) = W 
          MX7    0           W = 0
          SB4    60          UBC = 60 
          EQ     FMI6 
 FMI      SPACE  2,10 
*         SPECIAL PROCESSORS
  
*         Q - ADD ADDRESS EXPRESSION ( IH-H2+CA ) 
  
 FMI.Q    SA2    IH 
          ZR     X2,FMI.Q2   IF IH = 0
 FMI.Q1   CALL   CSN#        CONVERT NAME 
          RJ     ADC         AND ADD TO THE STRING
          SA2    IH2
          ZR     X2,FMI.Q3   IF IH2 = 0 
          SX6    1R-
          LX6    -6 
          SB3    6
          RJ     ADC         ADD A -
          SA2    IH2
          MX6    0
          SA6    A2          IH2 = 0
          EQ     FMI.Q1 
  
 FMI.Q2   SA2    IH2+1
          SX1    0           SIGN=0 
          PL     X2,FMI.Q4   IF CA \ 0
  
          AX3    B4,X7
          NZ     X7,FMI.Q2A  GET LAST CHAR IN STRING
          SA3    A7 
  
 FMI.Q2A  MX6    -6 
          BX1    -X6*X3 
          SX4    X1-1R+ 
          SX1    1R-         SIGN = - 
          NZ     X4,FMI.Q4   IF LAST CHAR " + 
          ZR     X7,FMI.Q2B  IF LAST CHAR IS IN PREVIOUS WORD 
          AX6    B4 
          SB4    B4+6        UBC = UBC + 6
          LX6    B4 
          BX7    -X6*X7      REMOVE LAST CHAR 
          EQ     FMI.Q4 
  
 FMI.Q2B  BX3    X6*X3
          BX6    X3+X1       CHANGE LAST CHAR TO A -
          SA6    A3 
          MX1    0           SIGN = 0 
          EQ     FMI.Q4 
  
 FMI.Q3   SA2    IH2+1
          SX1    1R+         SIGN = 1R+ 
          PL     X2,FMI.Q4   IF CA \ 0
          SX1    1R-         SIGN = 1R- 
  
 FMI.Q4   SA2    IH2+1
          ZR     X2,FMI.END  IF CA = 0
          LX1    -6 
          MX6    0
          SA6    A2          IH2(2) = 0 
          BX3    X2 
          AX3    59 
          BX6    X2-X3
          RJ     CON         CONVERT CA TO BCD
          BX6    X1+X6
          NZ     X1,FMI.Q5   IF SIGN " 0
          LX6    6
          SB3    B3-6        BC = BC - 6
 FMI.Q5   RJ     ADC         ADD CA TO THE STRING 
  
 FMI.END  RJ     TSB         TERMINATE STRING 
          SA4    FMIA 
          SA3    FMIB 
          SA2    AI 
          UX4    B3,X4
          BX0    X3 
          UX6    B2,X2       RESTORE B2 
          EQ     FMI
  
*         CONDITIONAL B - SKIP AFTER
  
 FMI.C    BX6    -X0*X1 
          SA2    FMI.JT+X6
          LX1    10          DW = SHIFT(DW,10)  */ SKIP NEXT 2 CHARS
          ZR     X2,FMI6     IF REG NUM OF NEXT = 0 
          LX1    -10
          R=     X6,1RB 
          SB3    6           BC = 6 
          LX6    54 
          EQ     FMI8 
  
*         CONDITIONAL B - ADD A +B TO STRING
  
 FMI.D    BX3    -X0*X1 
          SX6    2R+B 
          LX6    48          CH = *+B*
          SA2    FMI.JT+X3
          SB3    12          BC = 12
          ZR     X2,FMI.END  IF REG-NUM OF NEXT = 0 
          RJ     ADC         ADD CHARS
          EQ     FMI6 
  
*         BLANK STRING TO COLUMN 18 
  
 FMI.BL   SA2    =1H
          SB3    B4-18       BC = UBC - 18
          SB5    B3-B1
          MX3    B5 
          BX6    X3*X2       CH = MASK(BC) & 10H
          EQ     FMI8 
  
*         SHIFT COUNT - CONVERT TO DECIMAL
  
 FMI.S    SA2    J
          SA3    A2+B1
          LX2    3
          BX4    X2+X3
          SX6    X4+1R0 
          LX6    54 
          SB3    6           BC = 6 
          SX2    X4-10
          MI     X2,FMI8     IF SC < 9
  
          SX6    2R10 
+         SX2    X2-10
          SX6    X6+1S6 
          PL     X2,*-1 
          SX6    X6-1S6 
          SX2    X2+10
          IX6    X6+X2
          LX6    48 
          SB3    12          BC = 12
          EQ     FMI8 
  
*         COMBINED SPECIAL PROCESSOR JUMP AND CHARACTER DATA TABLE
  
 FMI.JT   EQ     FMI.END     0
          EQ     FMI.Q       1
          EQ     FMI.C       2
          EQ     FMI.D       3
          EQ     FMI.BL      4
          EQ     FMI.S       5
 I        BSS    1           6
 J        BSS    1           7
 K        BSS    1           8
  
 FMI.CH   DATA   8L+-*/,ABX 
 FMI      SPACE  2,10 
**        INST - MACRO TO SPECIFY MACHINE INSTRUCTION FORMATS FOR *FMI* 
* 
*         INST   (STRING) 
* 
*         THE FIRST 2 CHARACTERS HAVE NO SPECIAL MEANING. 
*         CHARACTERS THAT MAY APPEAR IN THE REST OF THE STRING AND
*         THEIR INTERPRETIONS ARE - 
*         A B X - REGISTER TYPES
*         + - * / ,  - SEPERATOR CHARS
*         I J K - REGISTER NUMBERS FROM THE MACHINE INSTRUCTION 
*         BLANK - END OF OPERATION FIELD
*         S - 2 DIGIT SHIFT COUNT ( JK FIELD )
*         C - CONDITIONAL B-REGISTER SPEC, SKIP IF REG NUM OF NEXT IS =0
*                            ELSE ADD A *B* TO THE STRING AND CONTINUE
*         D - CONDITIONAL *+B* SPEC, SKIP IF REG NUM OF NEXT IS =0, 
*                            ELSE ADD A *+B* TO THE STRING
*         Q - ADDRESS EXPRESSION ( IH-IH2+CA , CA = IH2(2) )
*                APPEARENCE OF A *Q* TERMINATES CONVERSION. 
  
          NOREF  .1,.2
 INST     MACRO  W
 Z        MICRO  1,2,$W$
          VFD    12/2R"Z" 
 .1       SET    3
 Z        MICRO  1,,$W$ 
 .2       MICCNT Z
          DUP    .2-2 
 Z        MICRO  .1,1,$W$ 
*                        ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/()$= , 
 Z        MICRO 1R"Z",1,#NOBC----FGH-----A-E----P------------IJKL----DM#
*                            INDEX INTO FMI.JT
          VFD    5/1R"Z"
 .1       SET    .1+1 
          ENDD
          VFD    *P/0 
          ENDM
  
 FMI.XJ   BSS    0           X-JUMPS
          ECHO   1,ZZ=("XJUMPS")
          INST   (ZZ XJ,Q)
  
 FMI.LCM  EQU    *-4         DRL,DWL INSTRUCTIONS 
          INST   (RXJ XK) 
          INST   (WXJ XK) 
  
 FMI.SET  INST   (S:I AJ+Q) 
          INST   (S:I CJ+Q) 
          INST   (S:I XJ+Q) 
          INST   (S:I XJDK) 
          INST   (S:I AJDK) 
          INST   (S:I AJ-BK)
          INST   (S:I BJDK) 
          INST   (S:I BJ-BK)
  
 FMI.II   BSS    0           OPCODES 1 - 47B
          INST   (RJ Q) 
          INST   (JP BI+Q)
 FMIA     BSS    1
          INST   (EQ CI,CJ,Q) 
          INST   (NE CI,CJ,Q) 
          INST   (LE BJ,CI,Q) 
          INST   (LT BI,CJ,Q) 
          INST   (BXI XJ) 
          INST   (BXI XJ*XK)
          INST   (BXI XJ+XK)
          INST   (BXI XJ-XK)
          INST   (BXI -XJ)
          INST   (BXI -XK*XJ) 
          INST   (BXI -XK+XJ) 
          INST   (BXI -XK-XJ) 
          INST   (LXI S)
          INST   (AXI S)
          INST   (LXI CJ,XK)
          INST   (AXI CJ,XK)
          INST   (NXI CJ,XK)
          INST   (ZXI CJ,XK)
          INST   (UXI CJ,XK)
          INST   (PXI CJ,XK)
          INST   (FXI XJ+XK)
          INST   (FXI XJ-XK)
          INST   (DXI XJ+XK)
          INST   (DXI XJ-XK)
          INST   (RXI XJ+XK)
          INST   (RXI XJ-XK)
          INST   (IXI XJ+XK)
          INST   (IXI XJ-XK)
          INST   (FXI XJ*XK)
          INST   (RXI XJ*XK)
          INST   (DXI XJ*XK)
          INST   (MXI S)
          INST   (FXI XJ/XK)
          INST   (RXI XJ/XK)
 FMIB     BSS    1
          INST   (CXI XJ) 
 APT      TITLE  LOADER TABLE OUTPUT ROUTINES 
**        APT - ADD PARCELS TO TEXT TABLE 
* 
*         ENTRY  (B3) = NP , NUMBER OF PARCELS OF DATA ( 1 - 4 )
*                (X4) = DATA , RIGHT ADJUSTED 
*                RBWORD - RELOC INFO IN AR. FORMAT
*                (IH) = SYMTAB ORDINAL
* 
*         EXIT   DATA ADDED TO TEXT TBL, RELOCATION NOTED IF NP = 2 
* 
*         PRESERVES  A5, X0, X5 
  
 APT      ROUTINE 
          SA3    AI 
          SA1    A3+B1                     (X1) = CW
          UX7    B2,X3       PR = NPR[AI]  */ PARCELS REMAINING IN CW 
          LE     B3,B2,APT4  IF NP @ PR    */ DATA FITS IN CW 
          ZR     B2,APT2     IF PR = 0     */ CW IS FULL
  
          SA2    NOPT-1+B2
          BX1    X2+X1       CW = CW ! NOPT(PR-1)  */ FILL CW WITH NO OP
  
 APT2     SA2    TI 
          BX6    X1          TD(TI) = CW
          SX1    B1 
          SA6    TD+X2
          SB2    4           PR = 4 
          IX3    X3+X1       ORGC = ORGC + 1
          SX7    X2+B1       TI = TI + 1
          MX1    0           CW = 0 
          SA7    A2 
          SX6    X2-14
          NZ     X6,APT4     IF TI " 15    */ TEXT TABLE NOT FULL 
  
*         WRITE TEXT TABLE TO *LGO* AND RESET 
  
          SA6    A2+         TI = 0 
          SA1    TH 
          SX2    15+1 
          SB7    X2+B1
          LX2    36 
          MX6    -12
          LX6    36 
          BX1    X6*X1
          BX6    X1+X2       WC[TH] = 16
          SA6    A1 
          PX7    B3,X3
          SA7    A3 
          BX6    X4 
          SA6    A3+B1
          WRLGO  A1,B7       TEXT TABLE TO LGO
          SA3    AI 
          UX7    B3,X3
          SA4    A3+B1                     RESTORE DATA 
          MX1    0           CW = 0 
          SB2    4           PR = 4 
          MX6    0
          SA6    TR          TR = 0 
          SETXTH X3,A6-B1 
  
*         ADD DATA TO *CW*, NOTE RELOCATION IF NP = 2 . 
  
 APT4     SB2    B2-B3       PR = PR - NP 
          SX2    -B2
          LX2    4
          SB4    X2+B2
          LX6    -B4,X4 
          BX7    X1+X6       CW = CW ! SHIFT(DATA,15*PC)
          SA7    A3+B1
          PX6    B2,X3
 APT5     SA6    A3          ** WORD PLUGGED FOR OLIST* 
          SB4    B1+B1
          EQ     FBD         (OL ON ) OR NE B3,B4,APT  ( OL OFF ) 
 APT6     SA1    RBWORD 
          RJ     ATR         ADD TEXT RELOCATION
          EQ     APT
  
 NOPT     VFD    45/0        TABLE OF NO OPS
+         VFD    30/0 
+         VFD    15/0 
  
 APTA     SA6    A3 
          SB4    B1+B1
          EQ     FBD         PLUG FOR OBJECT LISTING
+         SA6    A3          PLUG TO RESTORE NO OBJ LISTING 
          SB4    B1+B1
          NE     B3,B4,APT
 ATR      SPACE  3,14 
**        ATR - ADD TEXT RELOCATION ( STANDARD POSITIONS ONLY ) 
* 
*         ENTRY  (X1) = RBWORD
*                (B2) = PR , PARCELS REMAINING IN WORD ( 0 - 2 )
*                (IH) = SYMTAB ORDINAL
  
 ATR      ROUTINE 
          ZR     X1,ATR      IF RBWORD = 0
          SX6    0           A = RBWORD 
          SA6    RBWORD      RBWORD = 0 
          BX2    X1 
          LX2    58-AR.RLP
          LX3    B1,X2
          MI     X2,ATR1     IF RL \ 2     */ COMMON OR EXTERNAL
          PL     X3,ATR      IF RL = 0     */ ABS 
  
*         ADD PROGRAM RELOCATION BYTE TO *TR* WORD IN TEXT TABLE
  
          SA2    TI 
          SX7    B2+56
          SX4    B1+B1
          LX2    2
          IX7    X7-X2
          SA3    TR 
          SB3    X7 
          LX6    B3,X4
          BX7    X6+X3       TR = TR ! SHIFT(2,PR+56-4*TI)
          SA7    A3 
          EQ     ATR
  
 ATR1     MI     X3,ATR3     IF RL = 3     */ EXTERNAL
          MX2    -AR.RBL
          LX1    -AR.RBP
          BX6    -X2*X1      R = RB[A]
          SA3    O.CBT
          LX6    1
          SB3    X3+B1
          SA4    AI 
          SA3    B3+X6       LW = CBT(2*R+1)  */ LOADER BLOCK NUMBER
          BX7    X4 
          LX7    59-AD.LCMP 
          PL     X7,ATR2     IF ^LCM[AI]   */ NOT AN LCM BLOCK
  
*         ADD LINK BYTE FOR LCM RELOC TO XFILL TABLE
  
          SX6    X6+18S10 
          LX6    9-1
          MX3    -AD.ORGCL
          BX7    -X3*X4 
          LX7    30 
          LX4    -AD.RBP
          BX1    -X2*X4 
          SX2    B2 
          BX6    X6+X7
          LX2    4
          BX1    X1+X6
          SX3    B2 
          IX4    X2-X3
          LX4    24 
          BX1    X4+X1       6/0,24/ORGC,6/15*PR,9/RB,9/RB[AI]
          ADDWRD XFT,X1 
          EQ     ATR
  
*         ADD BYTE TO *LAF* TABLE A3,X3 = LW, X4 = AI 
  
 ATR2     SX7    X3          ID = LOW18[LW] 
          SX1    1S2+B2 
          LX7    30 
          MX2    -18
          LX1    27 
          BX2    -X2*X4 
          LX4    -AD.RBP
          BX1    X7+X1
          MX3    -AD.RBL
          BX1    X1+X2
          BX4    -X3*X4 
          LX4    18 
          BX1    X4+X1       12/,18/ID,1/1,2/PR,9/RB,18/ORGC
          ADDWRD LAFT,X1
          EQ     ATR
  
*         SET LW, AI AND GO ADD A LINK BYTE TO *LAFT* 
  
 ATR3     SA2    IH 
          SA4    AI 
          LX3    B1,X2
          IX3    X2+X3
          SX3    X3+1S16     LW = 1S16+3*IH 
          EQ     ATR2 
 AXR      SPACE  3,14 
**        AXR - ADD EXTENDED RELOCATION INFORMATION 
* 
*         ENTRY  (X6) = LEN OF FIELD
*                (B2) = BASE, LOW BIT OF FIELD
*                RBWORD, IH, IH+1 SET 
  
 AXRA     CON    1S59+1S44+1S29 
  
*         CALL *ATR* TO ADD STANDARD RELOCATION INFO
  
 AXR0     SX7    B2+2 
          AX7    4
          SB2    X7          PR = (BASE+2)/16 
          RJ     ATR         ADD TEXT RELOC 
  
 AXR      ROUTINE 
          SA2    AXRA 
          SA1    RBWORD 
          LX7    B2,X2
          PL     X7,AXR1     IF BASE " 0 ! 15 ! 30
          SX7    X6-18
          ZR     X7,AXR0     IF LEN = 18
  
*         SETUP RELOC WORD FOR XFILL/XLINK TABLE
  
 AXR1     SA2    AI 
          MX7    0
          SA7    A1          RBWORD = 0 
          LX6    18 
          SX7    B2 
          LX7    24 
          BX6    X6+X7
          MX3    -AD.ORGCL
          BX7    -X3*X2 
          LX7    30 
          BX6    X6+X7
          LX2    -AD.RBP
          MX3    -AD.RBL
          BX7    -X3*X2 
          BX6    X6+X7       LFW = 30/ORGC[AI],6/BASE,6/LEN,9/0,9/RB[AI]
          MX7    AR.RLL 
          LX7    AR.RLL+AR.RLP
          BX7    -X1*X7 
          ZR     X7,AXR3     IF RL = 3     */ EXTERNAL
  
*         ADD XFILL WORD FOR PROGRAM / COMMON SYMBOL
  
          SX2    B1          R = 1
          LX1    58-AR.RLP
          PL     X1,AXR2     IF RL = 1     */ PROGRAM RELOC 
          LX1    2+AR.RLP-AR.RBP
          SA2    CCB
          BX3    -X3*X1 
          IX2    X2+X3       R = CCB + RB[RBWORD] 
  
 AXR2     LX2    9
          BX1    X2+X6       ADD *RB* OF *IH* 
          ADDWRD XFT,X1 
          EQ     AXR
  
 AXR3     SA2    IH+1 
          SA6    AXRB+2 
          BX7    X2 
          SA7    A6-B1
          WRLGO  A7-B1,3     XLINK TABLE TO LGO 
          EQ     AXR
  
 AXRB     VFD    12/LT.XLNK,12/2,36/0 
          BSS    2
 DTT      SPACE  3,14 
**        DTT - DUMP CURRENT TEXT TABLE PRIOR TO A SWITCH TO ANOTHER
*                BLOCK, ETC.
* 
*         EXIT   (X6) = 45/CW,11/0,4/RELOC BYTE 
*                (X3) = AI
  
 DTT      ROUTINE 
          SA3    AI 
          SA2    TI 
          UX7    B2,X3
          MX6    0           (X6) = 0      */ ENSURE EXIT CONDITION 
          NZ     B2,DTT1     IF PR[AI] " 0
          SA1    A3+B1
          BX7    X1 
          SA7    TD+X2       TD(TI) = CW
          SX2    X2+B1       TI = TI + 1
          SA6    A1          CW = 0 
          SB2    4           PR = 4 
          SX4    B1 
          IX3    X3+X4       ORGC = ORGC + 1
          PX7    B2,X3
          SA7    A3 
  
 DTT1     ZR     X2,DTT2     IF TI = 0  NOTHING TO DUMP 
          SA1    TH 
          MX6    -12
          LX6    36 
          BX1    X6*X1
          SX2    X2+B1
          SB7    X2+B1
          LX2    36 
          BX6    X2+X1       WC[TH] = TI + 1
          SA6    A1 
          WRLGO  A1,B7
  
 DTT2     SA3    AI 
          SA1    A3+B1
          UX7    B2,X3
          SB3    4
          SA2    TI 
          BX6    X1          RETVAL = CW
          EQ     B2,B3,DTT3  IF PR = 4
          LX2    2
          SA1    TR 
          SB2    X2+4 
          MX4    -4 
          LX1    B2 
          BX2    -X4*X1 
          BX6    X2+X6
  
 DTT3     SX7    0
          SA7    TR          TR = 0 
          SA7    TI          TI = 0 
          EQ     DTT
 FPU      SPACE  3,14 
**        FPU - FORCE POS COUNTER UPPER 
* 
*         EXIT   PR = 4 ( AT BEGINNING OF A NEW WORD )
*                (X3) = ORGC
  
 FPU      ROUTINE 
          SA3    AI 
          SB4    4
          UX7    B3,X3
          EQ     B3,B4,FPU   IF PR[AI] = 4
          SX6    B1 
          ZR     B3,FPU1     IF PR = 0     */ CURRENT WORD IS FULL
  
          SA4    NOPT-1+B3
          SA6    NLF         NLF = 1       */ SET NO LIST FLAG
          WRTEXT B3          FILL WORD WITH NO OPS
          MX7    0
          SA7    NLF         NLF = 0
          SX6    B1 
          SA3    AI 
          SB4    4
  
 FPU1     IX3    X3+X6       ORGC = ORGC + 1
          PX6    B4,X3       PR = 4 
          SA6    AI 
          SA2    CW 
          SA3    TI 
          MX7    0
          BX6    X2 
          SA6    TD+X3       TD(TI) = CW
          SA7    A2          CW = 0 
          SX6    X3+B1       TI = TI + 1
          SX3    X3-14
          SA6    A3 
          NZ     X3,FPU      IF TI " 15    */ TABLE NOT FULL
          RJ     DTT         DUMP IT
          SETXTH X3 
          EQ     FPU
 DAT#     EJECT 
**        DAT# - DUMP ACCUMULATED TABLES
*                DUMPS XFILL, FILL, LINK, ETC TABLES. 
* 
*         EXIT   (B5) = SPACE RELEASED
* 
*         PRESERVES A0,X0, A5,A5
  
 DAT      ENTRY. **,# 
          SA1    HO$B 
          ZR     X1,DAT10    IF B = 0 
  
*         DUMP XFILL TABLE
  
          SA4    L.XFT
          ZR     X4,DAT1     IF L.XFT = 0 
          SX7    LT.XFIL
          LX7    12 
          BX6    X7+X4
          LX6    36 
          SA6    T
          WRLGO  A6,1 
          SA4    L.XFT
          SA3    O.XFT
          WRLGO  X3,X4
  
*         SORT LINK AND FILL REFS 
  
 DAT1     SA1    L.LAFT 
          SA2    O.LAFT 
          SA3    IL.LAF 
          IX1    X1-X3
          IX2    X2+X3
          ZR     X1,DAT10    IF L.LAFT = IL.LAF 
          IX6    X1+X2
          MX7    60 
          SA7    X6          LAFT(L.LAFT)+1) = -0  */ SEARCH TERMINATOR 
          SB7    X2 
          CALL   SHL#        SORT( LAFT ) 
          SA3    O.LAFT 
          SB5    30          SC = 30
          SA2    B7          FI = O.LAFT + IL.LAF 
          SB6    X3          WF = O.LAFT
          SB7    B5 
          MX6    0           W = 0
          SA6    X3          WI = WF
          MX7    30 
  
*         FORM THE FILL TABLE 
  
 DAT2     LX2    29-16
          MI     X2,DAT4     IF EXT REF 
          LX2    16-29
          BX4    X2 
          RJ     AFW         ADD THE WORD 
  
*         LOOP TO ADD FILL BYTES
  
 DAT3     BX1    X2          FL = [FI]
          SA2    A2+B1       FI = FI + 1
          BX3    X2-X1
          BX4    X7*X3
          NZ     X4,DAT2     IF LBN[FI] " LBN[FL] 
          BX3    -X7*X2 
          LX3    B5 
          BX6    X3+X6       ADD THE BYTE 
          SB5    B5-B7
          PL     B5,DAT3
          SA6    A6+B1
          SB5    B7 
          MX6    0
          EQ     DAT3 
  
 DAT4     SX4    LT.FILL
          RJ     DLT         DUMP THE FILL TABLE
  
*         FORM THE LINK TABLE 
  
          SA3    O.SYM
          SB3    X3-1S16
          SA6    B6          SETUP A6 = WF
 DAT6     ZR     X2,DAT9     IF END OF *LAF*
          AX3    B7,X2
          SA4    B3+X3
          MX3    42 
          BX4    X3*X4
          RJ     AFW         ADD NAME TO LINK TABLE 
  
 DAT7     BX4    -X7*X2 
          LX4    B5 
          BX6    X4+X6
          SB5    B5-B7
          PL     B5,DAT8     IF SC \ 0
          SA6    A6+B1
          SB5    B7          SC = 30
          MX6    0           W = 0
  
 DAT8     BX1    X2 
          SA2    A2+B1       FI = FI P 1
          BX3    X1-X2
          BX4    X7*X3
          ZR     X4,DAT7     IF EXTN[FI] = EXTN[FL] 
          EQ     DAT6 
  
 DAT9     SX4    LT.LINK
          RJ     DLT         DUMP THE LINK TABLE
  
 DAT10    SA4    IL.LAF 
          SA3    L.XFT
          SA2    L.LAFT 
          SB5    X3 
          MX7    0
          BX6    X4 
          IX4    X2-X4
          SB5    B5+X4       SR = L.XFT + L.LAFT-IL.LAF 
          SA7    A3          L.XFT = 0
          SA6    A2          L.LAFT = IL.LAF
          EQ     DAT
  
 T        OBSS   1           A TEMPORARY
 AFW      SPACE  2,14 
**        AFW - ADD A FULL WORD TO THE LINK/FILL TABLE
* 
*         ENTRY  (X4) = WORD TO BE ADDED
  
 AFW      ROUTINE 
          NE     B5,B7,AFW1 
          BX6    X4 
          SA6    A6+B1
          MX6    0
          EQ     AFW
  
 AFW1     BX3    X7*X4
          LX3    30 
          BX6    X3+X6
          SA6    A6+B1
          LX4    30 
          BX6    X7*X4
          EQ     AFW
 DLT      SPACE  3,14 
**        DLT - DUMP LINK/FILL TABLE
* 
*         ENTRY  (X4) = TABLE CODE
  
 DLT      ROUTINE 
          EQ     B5,B7,DLT1 
          SA6    A6+1 
 DLT1     SB7    A6+B1
          SX0    A2 
          SB7    B7-B6
          SX6    B7-B1
          ZR     X6,DLT2     IF WC = 1
          LX4    12 
          BX6    X4+X6
          LX6    36 
          SA6    B6 
          WRLGO  B6,B7
  
 DLT2     SB7    30 
          SB5    B7 
          MX7    30 
          SA2    X0 
          SA3    O.LAFT 
          SB6    X3 
          EQ     DLT
 GAI      TITLE  UTILITY SUBROUTINES
**        GAI - GET ADDRESS INFORMATION WORD OF A SYMTAB ENTRY
* 
*         ENTRY  (X3) = IH , SYMTAB ORDINAL 
* 
*         EXIT   (X1) = RBWORD ( WORD C OF SYMTAB ) 
*                (X3) = RA[RBWORD]
*                RBWORD, IH, IH+1 AND WB SET
* 
*         USES   B2, X1, X2, X3, X6 
  
 GAI0     BX6    -X1*X3 
          AX2    IH.HL
          SA2    =XF$FRT-1+X2      BASEP = FRT(I[IH]) 
          SA3    X2          BASE = [BASEP] 
          SB2    X6 
          SA1    X3+B2       RBWORD = BASE(H[IH]) 
          BX6    X1 
          SA6    RBWORD 
          MX2    -AR.RAL
          BX3    -X2*X1 
  
 GAI      ROUTINE 
          MX1    -IH.IHL
          BX6    -X1*X3 
          MX1    -IH.HL 
          BX2    X1*X6
          SA6    IH 
          NZ     X2,GAI0     IF I[IH] " 0 
  
          SA2    O.SYM
          SB2    X2+2 
          LX3    2
          IX3    X3-X6
          SA1    B2+X3       RBWORD = SYM(3*IH+2) 
 .FPAS    IFNE   HC.FPAS,0
          SA2    A1-B1
          BX6    X2          WB = SYM(3*IH+1) 
          SA6    WB 
 .FPAS    ENDIF 
          MX3    AR.RLL 
          LX3    AR.RLL+AR.RLP
          BX3    -X1*X3      RA = 0 
          BX6    X1 
          SA6    RBWORD 
          ZR     X3,GAI1     IF RL = 3     */ EXTERNAL
          MX3    -AR.RAL
          BX3    -X3*X1      RA = RA[RBWORD]
          EQ     GAI
  
*         SAVE NAME IN CASE OF XLINK TABLE ENTRY IS NEEDED
  
 GAI1     SA2    A1-2 
          MX6    42 
          BX6    X6*X2
          SA6    IH+1 
          EQ     GAI
 END      TITLE  PSEUDO INSTRUCTION PROCESSING
*         PROCESS END OF SUBPROGRAM 
*         END    CA,IH  , CA = LABEL ORDINAL, IH = XFER ORDINAL 
  
          PROCESS END 
          SA1    NAE
          ZR     X1,END2     IF NAE = 0 
          CALL   CDD= 
          SA6    NAE
          MESSAGE  A6,,R     MESSAGE(  NNN ASSEMBLY ERROR IN PROGNAM )
          SA2    =XN$FERR 
          SX6    X2+B1       N.FERR = N.FERR + 1
          SA6    A2 
  
 END2     RJ     FPU         FORCE UPPER
          SX6    X5 
          SA6    ENDB+1      ENDB(2) = IH[II]  */ SAVE XFER NAME ORDINAL
          SA1    N$FERR 
          ZR     X1,END2A    IF N$FERR = 0 */ NO ERRORS 
          SA2    =XCP.ERCT
          PL     X2,IA.EX    IF CP.ERCT \ 0  */ NOT LGO REGARDLESS
  
 END2A    SA2    BCDC 
          ZR     X2,END3     IF BCDC = 0
  
          SA6    PBUF+2      PBUF(2) = IH[II] 
          LX5    -SI.CAP
          SX6    X5 
          SA6    A6-B1       PBUF(1) = CA[II]  */ LOC SYMBOL
          SA1    ENDA 
          RJ     FMC         FORMAT END LINE
          WRTEXT 0           AND LIST IT
          SA3    BCDC 
          PL     X3,END3     IF BCDC \ 0   */ C NOT SELECTED
  
          WRITER F.CMPS,,R   FLUSH COMPS FILE 
          EQ     CG$IA
  
 END3     SA3    HO$B 
          ZR     X3,CG$IA    IF B = 0 
  
          RJ     DTT         DUMP TEXT TABLE
  
          RJ     DAT         DUMP XLINK, LINK AND FILL TABLES 
  
          SA3    ENDB+1 
          ZR     X3,END5     IF ENDB(2) = 0  */ NO XFER NAME
          RJ     GAI
          SA1    A1-2 
          MX0    42 
          BX6    X0*X1       ENDB(2) = MASK(42) & SYM(3*IH) 
          SA6    ENDB+1 
          WRLGO  A6-B1,2     XFER TABLE TO LGO
  
 END5     WRITER F.LGO,,R    FLUSH LGO FILE 
          EQ     CG$IA
  
 ENDA     PSEUDO END,(S,S),1
 ENDB     VFD    12/LT.XFER,12/1,36/0 
          BSS    1           XFER NAME
 BTW      SPACE  3,20 
 VFDW     BSS    2           CURRENT *BTW* TEXT WORD
 VFDL     =      VFDW+1      ADDRESS OF LAST MACRO INST IN THE BTW/ETW
*                            GROUP
 BTW      SPACE  2,10 
**        BTW - BEGIN TEXT WORD DEFINITION
  
          PROCESS BTW 
          SA4    X5 
          BX6    X4          VFDW = [LOW18[II]] 
          SA6    VFDW 
          AX5    R1.CAP 
          SX6    F$MXB+X5 
          SA6    A6+B1       VFDL = O.MXB + CA[II]
          RJ     FPU         FORCE UPPER
  
*         GNMW - RETURN POINT FOR PSEUDO INSTRUCTIONS INSIDE A MACRO
*         CHECK FOR END OF *BTW* RANGE. 
  
 GNMW     SA4    VFDL 
          SX5    A5 
          IX6    X4-X5
          NZ     X6,GNMW1    IF II " VFDL 
          SA4    A4-B1
          SA6    A4          VFDL = 0 
          WRTEXT 4           OUTPUT CURRENT VFD WORD
  
 GNMW1    SA5    A5+B1       II = II + 1
          UX6    B2,X5
          SA4    OC.AT+B2 
          SB3    X4 
          AX4    36 
          JP     B3          JUMP( OC.AT(OC) )
 ARI      SPACE  2,10 
**        ARI - ADD RELOCATABLE INFO TO BTW WORD
  
          PROCESS ARI 
          SA2    X5          IH = LOW18[LOW18[II]]
          SX3    X2 
          SA1    =XS$CON
          BX7    X1-X3
          SA7    A5          [II] = S$CON - IH   */  =0 IF IH = CON 
          RJ     GAI         GET ADDR INFO
          RJ     ACF         ADD RA TO VFDW 
          SX6    -B3
          RJ     AXR         ADD EXTENDED RELOCATION
          EQ     GNMW 
 ACI      SPACE  2,10 
**        ACI - ADD CONSTANT INFO TO *BTW* WORD 
  
          PROCESS ACI 
          SA3    X5          CON = [LOW18[II]]
          RJ     ACF         ADD CONSTANT VALUE TO VFDW 
          EQ     GNMW 
 AAC      SPACE  2,14 
**        AAC - ADD ADDRESS CONSTANT
  
          PROCESS AAC 
          SA4    A5-B1
          SA3    X5          CON = [LOW18[II]]
          NZ     X4,AAC1     IF [II-1] " 0 */  LAST IH .NE. CON.
          SA1    O.CUT
          SB3    X3 
          SA3    X1+B3       CON = CUT(CON) 
 AAC1     RJ     ACF         ADD VALUE TO FIELD 
          EQ     GNMW 
* 
 ACF      SPACE  3,14 
**        ACF - ADD CONSTANT FIELD TO *VFDW*
* 
*         ENTRY  (X3) = CONSTANT VALUE
*                (X5) = 12/P(OC),18/59-LEN,12/P(BASE-BIT),18/XX 
* 
*         EXIT   (B2) = BASE BIT
*                (B3) = -LEN
* 
*         USES   B - 2, 3, 4  X - 2, 3, 5, 6, 7 
  
 ACF      ROUTINE 
          LX5    30 
          SA2    VFDW 
          UX6    B2,X5
          SB3    X5                        (B3) = 59-LEN
          SB4    B2-60                     (B4) = -(60-BASE)
          LX2    -B4
          MX7    B3 
          BX6    -X7*X2      EXTRACT
          BX2    X7*X2       CLEAR
          SB3    B3+B1
          LX3    B3          SIGN EXTEND CON VALUE
          AX3    B3 
          LX6    B3 
          AX6    B3          SIGN EXTEND FIELD
          IX3    X3+X6
          BX6    -X7*X3      TRUNCATE 
          BX6    X2+X6
          LX6    B2 
          SA6    A2 
          SB3    B3-60             (B3) = -LEN
          EQ     ACF
 ASV      SPACE  3,14 
**        ASV - ADD STRING VALUE TO CURRENT TEXT WORD 
  
          PROCESS ASV 
          SA1    X5          MICRO VALUE
          AX5    18+6 
          SA2    A1+B1       BIT COUNT OF MICRO 
          SB3    X2 
          SB4    X5          6*NC-1 
          AX5    18 
          MI     B4,ASV1     IF NC = 0     */ 0L FORMAT 
  
          BX6    X1 
          BFN    X1          BLANK FILL MICRO 
          MX6    B4 
          BX1    X6*X1       TRUNCATE TO NC CHARS 
  
 ASV1     SA2    VFDW 
          MX0    -6 
          BX4    -X0*X5 
          SB4    X4+B1       TOP BIT + 1
          LX1    B4 
          BX6    X1+X2
          SA6    A2 
          EQ     GNMW 
 DCS      SPACE  2,10 
**        DCS - DEFINE CHAR STRING AS A MICRO NAME
*         DCS    CC,I  AND 1 WORD FOLLOWS IN CC_L FORMAT. 
  
          PROCESS DCS 
          BX0    X5 
          GNIW
          BX6    X5 
          SX1    X0-1 
          LX1    1
          SA6    =XF$MIC+X1  MIC(2*I-2) = STRING
          AX0    R1.CAP 
          SX1    X0 
          LX2    B1,X1
          IX6    X1+X2
          LX6    1
          SA6    A6+B1       MIC(2*I-1) = 6*CC
          EQ     GNIW 
 MIC      SPACE  3,14 
*         MIC - DEFINE MICRO STRING 
  
          PROCESS MIC 
          SA3    X5 
          SX2    X3          IH = LOW18[LOW18[II]]
          CALL   CSN#        GET DPC NAME AND BIT COUNT 
          AX5    18 
          MX0    -6 
          BX4    -X0*X5      SEP CHAR 
          LX4    6
          BX6    X6+X4
          SB6    6
          SB2    B0 
  
*         SEARCH FOR FINAL DELIMETER
  
 MIC1     SB2    B2+B6
          LX7    B2,X6
          BX4    X5-X7
          BX7    -X0*X4 
          NZ     X7,MIC1
          SB2    B2-B6       6*NCHAR IN STRING
          MX2    B2 
          LX6    -1 
          BX6    X2*X6       TRUNCATE STRING
          LX6    1
          GE     B2,B3,MIC2  BIT COUNT = MIN( BC , 6*NCHARS ) 
          SB3    B2 
  
 MIC2     AX5    6
          BX3    -X0*X5      6*FC-6 
          SB4    X3 
          SB3    B3-B4       BC = BC - (6*FC-6) 
          SB2    B4-B1
          MX2    B2 
          BX6    -X2*X6 
          LX6    B4 
  
 MIC3     AX5    6
          BX4    -X0*X5 
          ZR     X4,MIC4     IF NC = 0
          BFN    X6 
          SB3    X4          BC = 6*NC
          SB4    B3-B1
          MX2    B4 
          BX6    X2*X6       BLANK FILL AND TRUNCATE
  
 MIC4     AX5    6
          BX5    -X0*X5 
          SA6    =XF$MIC+X5  STORE NAME 
          SX7    B3 
          SA7    A6+B1       STORE BIT COUNT
          EQ     GNMW 
 IFT      SPACE  3,14 
**        IFT - PROCESS IF.XX INSTRUCTIONS
  
          PROCESS IFT 
          MX1    -15
          BX6    -X1*X5 
          SA2    PBUF+X6     OP2
          AX5    15 
          BX6    -X1*X5 
          SA3    PBUF+X6     OP1
          SB2    X2 
          SB3    X3 
          AX5    15 
          BX6    -X1*X5      SKIP COUNT 
          SB4    X6 
          MX1    -3 
          AX5    15 
          BX5    -X1*X5      TEST TYPE
          SB5    X5 
          JP     B5+IFT.JT   JUMP( IFT.JT(IFTYPE) ) 
 IFT.JT   BSS    0
          ECHO   2,Z=("RELOPS") 
          Z      B3,B2,GNMW 
          EQ     IFT2 
  
 IFT2     SA5    A5+B4       SKIP PAST ELSE/ENDIF 
          EQ     GNMW 
 ELSE     SPACE  2,8
**        ELSE - REVERSE EFFECTS OF IF
  
          PROCESS ELSE
          SB4    X5 
          SA5    A5+B4       SKIP UNTIL ENDIF 
          EQ     GNMW 
 SET      EJECT 
**        SET -  LI  SET.  ADDR-EXPR
  
          PROCESS SET 
          SA1    AI 
          SA2    UBO
          MX3    -AD.RBOCL
          AX2    15 
          SX0    B1+B1
          IX2    X0-X2       RL = 2 - SHIFT(UB0,-15)
          BX1    -X3*X1 
          LX2    AR.RLP 
          BX6    X2+X1
          SA6    =XORG#CTR   ORG#CTR = AR(RL,RBOC[AI])
          MX0    -15
          BX4    -X0*X5 
          RJ     GSA         GET SET ARG VALUES 
          AX5    15 
          BX4    -X0*X5 
          BX6    X7          (X6) = ARG1
          MX1    -3 
          AX5    15 
          RJ     GSA         (X7) = ARG2
          BX4    -X1*X5 
          SB4    X4 
          SB3    60-24
          LX2    B3,X6       SIGN EXTEND RA"S 
          AX2    B3 
          LX3    B3,X7
          AX3    B3 
          MX1    AR.RLL 
          LX1    AR.RLL+AR.RLP
          AX5    3
          JP     B4+SET.JT
  
 SET.JT   IX3    X2+X3       +
          EQ     SET1 
  
          IX3    X2-X3       -
          BX4    X1*X7
          EQ     SET.SUB
  
          IX3    X2*X3       *
          EQ     SET1 
  
+         ZR     X3,SET1     IF X/0 THEN RETURN 0 
          IX3    X2/X3
          EQ     SET1 
  
 SET.SUB  ZR     X4,SET1     IF RL[OP2] = 0 
*         RL[OP2] = 0 => RL[OP1] = 0
          MX6    0           (RL,RB)OP1 = 0 
          MX7    0           (RL,RB)OP2 = 0 
  
*         STORE RESULT VALUE
  
 SET1     MX4    -AR.RAL
          BX3    -X4*X3      TRUNCATE RA
          BX6    X6+X7       OR RL,RB"S 
          BX7    X4*X6
          BX6    X7+X3       RECOMBINE RL,RB, & RA
          BX5    -X0*X5      RESULT ORD 
          SX3    X5-1S14
          PRINT  SET,(* RESULT,ORD = *O20,Z6),(X6,X5) 
          PL     X3,SET3     IF ORD \ 1S14 */ RESULT GOES TO SYMTAB 
          BX2    X4*X6
          ZR     X2,SET2     IF RL[RESULT] = 0
          SB4    X5+=XSS#BIAS+1S17 I = ORD + SS.BIAS
          SA6    F$SST+B4    SST(I) = RESULT
          MX7    1           RESULT = 1S59+I  */ SET FLAG BIT 
          SX6    B4+I.SS
          BX6    X7+X6       RESULT = 1S59 + I.SS+I 
 SET2     SA6    PBUF+X5     PBUF(ORD) = RESULT 
          EQ     GNMW 
  
 SET3     SA3    PBUF+X3
          SA2    O.SYM
          LX4    B1,X3
          IX3    X3+X4
          SB3    X2+2 
          SA6    B3+X3       SYM(3*IH+2) = RESULT 
          EQ     GNMW 
 GSA      SPACE  2,14 
**        GSA - GET SET ARGUMENT VALUES 
* 
*         ENTRY  (X4) = ARG INDEX 
* 
*         EXIT   (X7) = ARG VALUE 
  
 GSA0     SA3    PBUF+X3
          SA2    O.SYM
          LX4    B1,X3
          IX3    X3+X4
          SB3    X2+2 
          SA4    B3+X3       VAL = SYM(3*IH+2)
          BX7    X4 
 GSA      ROUTINE 
          SX3    X4-1S14
          PL     X3,GSA0     IF ARG \ 1S14  */ ARG VAL IN SYMTAB
  
          SA3    PBUF+X4     VAL = PBUF(ARG)
          SB3    =XORG#CTR
          BX7    X3 
          PL     X3,GSA      IF VAL \ 0 
          SB3    A3-B3
          ZR     B3,GSA 
          SB3    X3-I.SS
          SA3    F$SST+B3 
          BX7    X3          VAL = SST(VAL-I.SS)
          EQ     GSA
 LPO      EJECT 
**        LPO - LIST PSEUDO OP WITH MAX OF 2 ARGUMENTS
* 
*         ENTRY  (X1) = *FMC* FORMAT CONVERSION WORD
*                (X5) = PSEUDO OP WORD
* 
*         EXIT   (X5) PRESERVED 
*                EXITS TO *GNIW* IF *C* SELECTED
  
 LPO      ROUTINE 
          SA2    MIW
          SA3    BCDC 
          NZ     X2,LPO1     IF MIW " 0    */ IN A MACRO EXPANSION
          ZR     X3,LPO      IF BCDC = 0   */ OL & C = 0
          MX7    -24
          BX6    -X7*X5 
          SA6    PBUF+2      PBUF(2) = IHX[II]
          LX5    -SI.CAP
          SX6    X5 
          SA6    A6-B1       PBUF(1) = CA[II] 
          LX5    SI.CAP 
          RJ     FMC         FORMAT PSEUDO OP LINE AND WRITE TO *COMPS* 
  
 LPO1     SA3    BCDC 
          PL     X3,LPO      IF BCDC \ 0   */ ^ ( C"0 ) 
          EQ     MPXA        */ RETURN TO MAIN LOOP 
 SLP      SPACE  3,14 
**        SLP - SUBSTITUTE LOCAL PARAMS IN PSEUDO OP WORD 
* 
*         ENTRY  (X1) = *FMC* FORMAT CONVERSION WORD
*         CALLS  LPO
  
 SLP      ROUTINE 
          BX6    X5 
          LX6    59-24
          PL     X6,SLP1     IF LOW BITS NOT A LOCAL PARAM
  
          SA4    X5 
          MX2    -26
          BX5    X2*X5
          BX5    X4+X5
  
 SLP1     LX6    24-25
          LX5    -SI.CAP
          PL     X6,SLP2     IF CA FIELD NOT A LOCAL PARAM
  
          SA4    X5 
          MX2    -18
          BX5    X2*X5
          BX5    X4+X5
  
 SLP2     LX5    SI.CAP 
          RJ     LPO         LIST PSEUDO
          EQ     SLP
 LAB      SPACE  3,14 
**        LAB    CA,IH
  
          PROCESS LAB 
          SX6    X5 
          SB2    OC.BSS 
          LX6    R1.CAP 
          LX5    -R1.CAP
          SX5    X5 
          BX6    X5+X6
          PX5    B2,X6       REFORMAT AS A *BSS*
  
**        BSS    SY,*WC 
  
          PROCESS BSS 
          SA1    BSSA 
          RJ     SLP         SUBSTITUTE PARAMS AND LIST 
          MX7    -AR.RAL
          BX0    -X7*X5      WC = IHX[II] 
          RJ     FPU         FORCE UPPER
  
*         CHECK THAT ADDRESS OF LABEL AGREES WITH THE ORG COUNTER.
  
          LX5    -SI.CAP
          SX3    X5 
          ZR     X3,BSS1     IF NO SYM
          RJ     GAI
          SA4    AI 
          MX6    0
          MX7    -AD.ORGCL
          SA6    RBWORD 
          BX6    X4-X1
          BX6    -X7*X6 
          ZR     X6,BSS1     IF ORGC[AI] = RA[IH] 
          SA2    NAE
          SX6    X2+B1       NAE = NAE + 1
          SA6    A2 
          SA1    HO$LO$O
          ZR     X1,BSS1     IF OL = 0
          LISTL  BSSB,BSSC   *  ERROR - RA OF LABEL " ORG.CTR * 
  
 BSS1     SA1    MIW
          NZ     X1,BSS2     IF MIW " 0    */ INSIDE A MACRO
          WRTEXT 0
 BSS2     ZR     X0,MPXA     IF WC = 0
  
          RJ     DTT         DUMP THE CURRENT TEXT TABLE
          IX6    X3+X0       ORGC[AI] = ORGC[AI] + WC 
          SA6    A3 
          SETXTH X6 
          EQ     MPXA 
  
 BSSA     PSEUDO BSS,(S,C),1
 BSSB     DIS    ,/ ERROR - RA OF LABEL .NE. ORG.CTR/ 
 BSSC     EQU    *-BSSB 
 BSSZ     SPACE  3,14 
**        BSSZ   SY,*WC 
  
          PROCESS BSSZ
          SA1    BSSZA
          RJ     SLP         SUBSTITUTE PARAMS AND LIST 
          MX7    -AR.RAL
          BX0    -X7*X5      WC = IHX[SI] 
          RJ     FPU         FORCE UPPER
          ZR     X0,MPXA     IF WC = 0
          SA3    AI 
          MX6    -AD.RBOCL
          BX7    -X6*X3      SA = RBOC[AI] */ SOURCE ADDR 
          SA7    BSSZB+1
          MX4    0
          WRTEXT 4           OUTPUT FIRST ZERO WORD 
          SX6    B1 
          IX0    X0-X6       WC = WC - 1
          ZR     X0,MPXA     IF WC = 0     */ ONLY 1 WORD 
          SA6    NLF         NLF = 1       SHUT OFF LISTING 
          BX7    X0 
          AX7    2
          NZ     X7,BSSZ3    IF WC > 3
  
 BSSZ1    MX4    0
          WRTEXT 4           OUTPUT A ZERO WORD 
          SX0    X0-1        WC = WC - 1
          NZ     X0,BSSZ1    IF WC " 0
  
 BSSZ2    SX6    0           NLF = 0
          SA6    NLF
          EQ     MPXA 
  
*         WC > 4, OUTPUT 1 OR MORE *REP* TABLES 
  
 BSSZ3    RJ     DTT         FLUSH TEXT TABLE 
          IX6    X0+X3       ORG[AI] = ORG[AI] + WC 
          SA6    A3 
          SETXTH X6 
          SA2    BSSZB
          MX4    -AD.RBL
          LX4    12 
          BX6    X4*X2       CLEAR RB NUMBER FROM CL FIELD
          LX3    59-AD.CLP
          PL     X3,BSSZ3A
          LX3    1+AD.CLP-AD.RBP+12 
          BX3    -X4*X3 
          BX6    X3+X6       SET RB NUMBER IN CL FIELD
 BSSZ3A   SA6    A2 
          MX1    -15
          BX2    X1*X0
          BX6    X0 
          LX6    45 
          ZR     X2,BSSZ4    IF WC < 2**15
  
          MX1    -9 
          BX4    -X1*X0 
          SX6    X4+1S9      RC1 = WC & 777B + 1000B
          LX6    45 
          SA6    BSSZB+2
          WRLGO  BSSZB,3     OUTPUT FIRST REP TABLE 
          SA1    BSSZB+1
          SA2    A1+B1
          LX2    15 
          SX3    X2+B1
          IX6    X1+X3       DA = SA + RC1+1
          SX7    1S9         BLOCK SIZE = 1000B 
          LX7    33 
          BX6    X7+X6
          IX0    X0-X2
          AX0    9           REP COUNT = (WC-RC1)/1000B 
          LX0    45 
          BX6    X6+X0
  
 BSSZ4    SA6    BSSZB+2
          WRLGO  BSSZB,3     OUTPUT REP TABLE 
          EQ     BSSZ2
  
 BSSZA    PSEUDO BSSZ,(S,C),1 
 BSSZB    VFD    12/LT.REPI,12/2,36/1 
          BSS    2
 BOS      SPACE  2,14 
**        BOS    LINE-NUM,0  , H2 = 2/LIST-FLAGS,10/XX
*         LISTS A LINE OF THE FORM *35X,"LINE ",IN* 
  
          PROCESS BOS 
          SA4    BCDC 
          LX6    -SI.CAP
          SX1    X6          LINEN = CA[II] 
          SX7    X6+
          SA7    =XHO$CSN    HO$CSN = LINEN 
          MI     X4,BOS2     IF C " 0 
          LX5    -28
          MX4    -2 
          BX3    -X4*X5 
          SB2    X3          LF = H2[II]   */ LIST FLAGS
          ZR     B2,BOS1     IF LF = 0     */ NO CHANGE 
          SB3    B1+B1
          SX6    B3-B2
          SA6    A4          BCDC = 2 - LF
          SA3    APTA-1+B2
          BX7    X3          ADJUST PLUG
          SA7    APT5 
 BOS1     SA4    A4+
          ZR     X4,GNIW     IF BCDC = 0
  
 BOS2     MX0    -12
          CALL   CDD=        RETURNS (X4) = LEFT JUSTIFIED NUMBER 
          SA1    =1H
          SA2    =5ALINE
          BX7    X1 
          SA7    LBUF        FOR I = 1 TO 3 ; LBUF(I) = 1H
          SA7    A7+B1
          SA7    A7+B1
          BX7    X2 
          SA7    A7+B1       LBUF(4) = 5ALINE 
          BX7    X0*X4       WD = 8LLINE-NUM
          SB4    12          UBC = 12 
          RJ     TSB         TERMINATE LINE AND WRITE TO COMPS
          WRTEXT 0           LIST THE LINE IF OL " 0
          EQ     MPXA 
 CON      SPACE  2,14 
**        CON    SY,*CA 
  
          PROCESS CON 
          SX7    1R+
          SA7    FMCA        SET SEPERATOR = +
          SA1    CONA 
          RJ     SLP         SUBSTITUTE LOCAL PARAMS AND FORMAT 
          SX7    1R,
          SA7    FMCA        RESTORE SEPERATOR CHAR 
          MX7    -AR.RAL
          BX4    -X7*X5      DATA = IHX[II] 
          LX5    -SI.CAP
          SX3    X5 
          RJ     GAI
          IX4    X3+X4       DATA = DATA + RA[RBWORD] 
          WRTEXT 4
          SX6    AR.RAL 
          SB2    B0 
          RJ     AXR         ADD RELOCATION 
          EQ     GNIW 
  
 CONA     PSEUDO CON,(S,C)
 DATA     SPACE  2,14 
**        DATA   WC,CC AND WC WORDS FOLLOW
  
          PROCESS DATA
          BX0    X5 
          AX0    R1.CAP 
          SX0    X0          WC = CA[II]
          SX5    X5 
          NZ     X0,DATA1    IF WC " 0
          SA1    DATAA
          LX5    R1.CAP 
          RJ     LPO         LIST PSEUDO
          LX5    -R1.CAP
          SX4    X5 
          WRTEXT 4
          EQ     GNIW 
  
 DATA1    GNIW               GET A DATA WORD
          SA1    BCDC 
          ZR     X1,DATA2    IF BCDC = 0
  
          BX4    X5 
          RJ     CFW         CONVERT 20 DIGITS
          BX1    X6          SAVE LOWER 
          BX6    X7 
          SA2    =1H
          BX7    X2 
          SA3    =8LDATA
          SA7    LBUF        LBUF(1) = 10H
          SB3    60          BC = 60
          SB4    12          UBC = 12 
          BX7    X3          WD = 8LDATA
          RJ     ADC         ADD UPPER TO STRING
          BX6    X1 
          R=     X1,1RB 
          RJ     ADC         ADD LOWER
          LX1    6
          SB4    6           UBC = 6
          BX7    X1+X7       ADD FINAL B
          RJ     TSB         TERMINATE STRING AND WRITE TO *COMPS*
 DATA2    BX4    X5 
          WRTEXT 4
          SX0    X0-1        WC = WC - 1
          NZ     X0,DATA1    IF WC " 0
          EQ     GNIW 
  
 DATAA    PSEUDO DATA,C 
 DIS      SPACE  2,14 
*         DIS    0,WC  , AND WC WORDS FOLLOW IN *H* FORMAT
  
          PROCESS DIS 
          SX6    X5 
          SA6    DISA        WC = IH[II]
  
 DIS1     SA4    DISA 
          SX5    5
          IX7    X4-X5
          PL     X7,DIS2     WTM = MIN( WC , 5 )  */ WORDS TO MOVE
          BX5    X4 
 DIS2     IX6    X4-X5       WC = WC - WTM
          SA6    A4 
          ZR     X5,GNIW     IF WTM = 0 
          SA1    =1H
          SA2    =10HDIS     0, 
          BX6    X1 
          SA6    LBUF 
          LX5    6
          IX7    X5+X2             ADD WC TO DIS STMT 
          SA7    A6+B1
          LX5    -6 
          SA0    A7+B1
          RJ     MWI         MWI( WTM , LBUF+2 )
          SX7    1R 
          SB4    60-6 
          LX7    -6 
          RJ     TSB         TERMINATE THE STRING AND WRITE TO *COMPS*
  
*         NOW OUTPUT THE BINARY, NOTE THAT *NLF* SERVES A DOUBLE USE
  
 DIS3     SA1    NLF
          SA4    LBUF+2+X1   DATA = LBUF(NLF+2) 
          WRTEXT 4           OUTPUT BINARY AND LIST FIRST TIME
          SA1    NLF
          SX6    X1+B1       NLF = NLF + 1
          SA6    A1 
          SX5    A0-LBUF-2
          IX7    X6-X5
          MI     X7,DIS3     IF NLF < WTM 
          SA7    A1          NLF = 0
          EQ     DIS1 
  
 DISA     OBSS   1
 ENT      SPACE  2
          PROCESS ENT 
          SX4    B1 
          LX4    SI.CAP 
          BX5    X4+X5       CA = 1 
          EQ     .LAB 
 HOL      EJECT 
**        HOL    CC,F   CC = CHAR COUNT, F = 1RH, 1RL OR 1RR
*                            AND 1 WORD FOLLOWS IN H FORMAT 
  
          PROCESS HOL 
          SA3    =1H
          SA1    =9LHOL     0 
          SX4    X6 
          AX6    SI.CAP-6 
          BX7    X3 
          IX6    X1+X6
          SA7    LBUF 
          BX6    X6+X4       10LHOL      NF 
          SA6    A7+B1
          UX0    X5 
          GNIW               GET DATA WORD
          BX7    X5 
          SA7    LBUF+2 
          SB4    12 
          MX7    0
          MX5    0
          RJ     TSB         TERMINATE LINE AND WRITE TO *COMPS*
          SB2    X0-1RH 
          BX4    X5 
          AX0    SI.CAP-1    2*CC 
          ZR     B2,HOL1     IF F = 1RH 
          LX1    B1,X0
          IX2    X1+X0       6*CC 
          SB4    X2 
          SB3    B4-B1
          MX6    B3 
          BX4    X6*X4       REMOVE TRAILING BLANKS 
          SB2    B2+1RH-1RL 
          ZR     B2,HOL1     IF F = 1RL 
          LX4    B4 
 HOL1     WRTEXT 4           OUTPUT BINARY
          EQ     GNIW 
 ORG      SPACE  3,14 
**        ORG    IH,CAX  - SET ORG COUNTER
  
 .Z       SET    -1 
          IFC    NE,/"HC.UDVB"//,4
          ECHO   3,X=("HC.FLB") 
 .Z       SET    .Z+1 
          IFC    EQ,/X/"HC.UDVB"/,1 
          STOPDUP 
 HC.UDVB  MAX    0,.Z 
  
 K.       VFD    2/1,25/0,9/HC.UDVB,24/0   SAVED VALUE OF UDV BLOCK ADDRESS 
  
          PROCESS ORG 
          UX6    X5 
          NZ     X6,ORG1     IF CAIH[II] " 0
          SA1    K. 
          RJ     SOC         RESET ORG CTR TO PREVIOUS VALUE
          MX7    39          M=MASK(39) 
          EQ     ORG2 
  
 ORG1     SX6    1S15+HC.UDVB 
          SX5    0
          RJ     CUB         CHANGE BLOCKS
          RJ     FPU         FORCE UPPER
          SA1    K. 
          SA2    AI 
          MX6    X1+X2       K. = MAX( K. , AI )
          SA6    A1 
          SA5    A5 
          MX0    -AR.RAL
          BX4    -X0*X5 
          LX5    -SI.CAP
          SX3    X5 
          RJ     GAI         WC = GAI( IH[II] ) 
          IX1    X1+X4       RA[WC] = RA[WC] + CAL[II]
          RJ     SOC         SET NEW ORG VALUE
          SA6    S.          SAVE FOR REPI PROCESSOR
          MX7    60          M = MASK(60) 
  
 ORG2     SA2    ORGA 
          SA5    A5 
          BX1    X7*X2       FMCW = ORGA & M
          RJ     LPO         LIST THE PSEUDO
          WRTEXT 0
          EQ     GNIW 
  
 ORGA     PSEUDO ORG,(S,C)
 SOC      SPACE  2,14 
**        SOC - SET ORG COUNTER 
* 
*         ENTRY  (X1) = NORG, ADDRESS IN AR. FORMAT 
* 
*         EXIT   (X6) = ADDRESS IN AD. FORMAT 
  
 SOC0     MX0    -AD.RBOCL
          BX6    -X0*X4 
 SOC      ROUTINE 
          SA2    UBO
          MX0    -AR.RBL
          BX3    -X0*X2      RB = UBO & 777B
          AX2    15 
          SX7    B1+B1
          IX6    X7-X2       RL = 2 - UBO/1S15
          SA4    AI 
          MX0    -AD.ORGCL
          BX5    -X0*X4 
          LX3    AR.RBP      CORG = AR(RL,RB,ORGC[AI])
          BX5    X3+X5
          LX6    AR.RLP 
          BX6    X5+X6
          BX7    X6-X1
          SA2    SOCB 
          BX7    X2*X7
          ZR     X7,SOC0     IF CORG = NORG 
  
          BX6    X1 
          SA6    SOCA 
          MX7    -AR.RBL
          LX6    -AR.RBP
          BX6    -X7*X6      NUBO = RB[NORG]
          LX1    58-AR.RLP
+         MI     X1,*+1 
          SX6    X6+1S15     IF( RL = 1 ) THEN UBO = UBO + 1S15 
          RJ     CUB         SWITCH TO THE NEW BLOCK
          NZ     X7,*+1      IF NO CHANGE 
          RJ     DTT         DUMP THE TEXT TABLE IF NO CHANGE 
          SA1    SOCA 
          SA2    AI 
          SA3    TH 
          MX0    -AD.ORGCL
          BX1    -X0*X1 
          BX2    X0*X2
          IX6    X1+X2       ORGC[AI] = ORGC[NORG]
          SA6    A2 
          BX3    X0*X3
          IX6    X1+X3       ORGC[TH] = ORGC[NORG]
          SA6    A3 
          MX7    -AD.RBOCL
          BX6    -X7*X6      RBOC = RBOC[TH]
          EQ     SOC
  
 SOCA     OBSS   1
 SOCB     BFMW   AR,(RL,RB,RA)
 REPI     SPACE  2,14 
**        REPI   DLEN,RC,INC,DESTIN-ADDR-INC
  
          PROCESS REPI
          SX6    X5 
          SA6    PBUF+2      REP COUNT
          LX5    -SI.CAP
          SX7    X5 
          SA7    A6-B1       DLEN 
          LX6    45 
          LX7    AD.RBOCL 
          BX0    X6+X7
          GNIW               GET SECOND WORD
          SX6    X5 
          SA6    PBUF+3      INC
          AX5    18 
          SX7    X5 
          SA7    A6+B1       DESTIN ADDR INC
          LX6    AD.RBOCL 
          SA2    S. 
          MX1    -AD.RBOCL
          BX2    -X1*X2 
          IX7    X2+X7
          BX7    X0+X7
          SA7    A2+B1
          BX6    X6+X2
          SA6    A2 
          SA3    BCDC 
          ZR     X3,REPI1    IF BCDC = 0
          SA1    REPIA
          RJ     FMC         FORMAT *REPI* LINE 
          WRTEXT 0           AND LIST IT
  
 REPI1    RJ     FPU         FORCE UPPER
          RJ     DTT         FLUSH OUT CURRENT TEXT TABLE 
          SETXTH X3          RESET *TH* 
*                (X5) = SI WORD OR 0 IF NOT CALLED FROM USE 
          SA2    REPIB
          MX4    -AD.RBL
          LX4    12 
          BX6    X4*X2       CLEAR RB NUMBER FROM CL FIELD
          LX3    59-AD.CLP
          PL     X3,REPI2    IF NOT CONDITIONAL LOADING 
          LX3    1+AD.CLP-AD.RBP+12 
          BX3    -X4*X3 
          BX6    X3+X6       SET RB NUMBER IN CL FIELD
 REPI2    SA6    A2 
          WRLGO  REPIB,3     REPI TABLE TO LGO
          EQ     GNIW 
  
 REPIA    PSEUDO REPI,(C,C,C,C) 
 REPIB    VFD    12/LT.REPI,12/2,36/1      XREP, I = 1
 S.       BSS    1           9/0,18/INC,33/RBOC[S.] 
          BSS    1           15/RC,12/DLEN,33/RBOC[DESTIN]
 USE      SPACE  2,14 
**        USE    0,BN - SET NEW USE BLOCK FOR CODE PLACEMENT
  
          PROCESS USE 
          SX6    X5 
          RJ     CUB         CHANGE BLOCKS
          ZR     X7,GNIW     IF NO CHANGE 
          SA4    A5+B1
          BX6    X4-X5
          AX6    48 
          ZR     X6,GNIW     SKIP LIST IF NEXT IS A USE PSEUDO
          SA2    AI 
          SX3    B1 
          LX2    -AD.LCMP 
          BX4    X3*X2
          UX5    X5 
          LX5    SI.CAP      SHIFT TO MAKE IH LISTED AS ARG1
          SA1    USEA+X4
          RJ     LPO         LIST PSEUDO
          WRTEXT 0           LIST ADDRESS + LINE
          EQ     GNIW 
  
 USEA     PSEUDO USE,(B,C)
          PSEUDO USELCM,B 
 CUB      SPACE  3,14 
**        CUB - CHANGE USE BLOCK
* 
*         ENTRY  (X6) = NUBO, NEW USE BLOCK ORIDNAL 
* 
*         EXIT   (X7) = 0 IF NO CHANGE
* 
*         PRESERVES  A0,A5, X0,X5 
  
 CUB      ROUTINE 
          SA4    UBO
          IX7    X4-X6
          SA6    A4+B1       UBO(2) = NUBO
          ZR     X7,CUB      IF NUBO = UBO(1)  */ NEW = CURRENT 
  
          RJ     DTT         DUMP CURRENT TEXT TABLE
          SA4    UBO
          LX4    1
          BX7    X3 
          SX2    X4-1S16     I = 2*(UBO-1S15) 
          MI     X2,CUB1     IF I < 0      */ COMMON BLOCK
  
          SA1    O.LBIT 
          IX2    X1+X2
          SA6    X2+B1       LBIT(I+1) = CW INFO
          SA7    X2          LBIT(I) = AI 
          EQ     CUB2 
  
 CUB1     SA1    O.CBT
          IX2    X1+X4
          SA7    X2          CBT(2*UBO) = AI
  
*         SETUP AI, CW, TEXT HEADER FOR THE NEW BLOCK 
  
 CUB2     SA3    A4+B1
          BX6    X3 
          SA6    A4          UBO(1) = UBO(2)
          LX3    1
          SX7    X3-1S16     I = 2*(UBO-1S15) 
          PL     X7,CUB3     IF I \ 0      */ A LOCAL BLOCK 
  
          SA2    O.CBT
          IX7    X2+X3       TBL = O.CBT + 2*UBO
          MX6    0           V = 0
          BX2    X5 
          LX2    -SI.CAP
          SX2    X2 
          LX2    AD.CLP      CL = CA[SI]
          EQ     CUB4 
  
 CUB3     SA2    O.LBIT 
          IX7    X2+X7       TBL = O.LBIT + I 
          SA3    X7+B1       LCW = LBIT(I+1)
          MX4    -4 
          BX6    -X4*X3 
          LX6    -4 
          SA6    TR          TR = SHIFT(LCW&17B,-4) 
          BX6    X4*X3       V = MASK(45) & LCM 
          MX2    0
  
 CUB4     SA3    X7 
          SA6    CW          CW = V 
          BX6    X3+X2
          SA6    A6-B1       AI = TBL(1) ! CL 
          SETXTH X6          RESET *TH* 
          EQ     CUB
 VFDP     SPACE  3,14 
**        VFDP   BN,LEN AND 1 WORD OF LEFT JUSTIFIED DATA FOLLOWS 
  
          PROCESS VFDP
          SA4    AI 
          MX1    -AD.RBOCL
          BX7    -X1*X4 
          SX3    X5 
          LX3    42 
          BX7    X3+X7
          AX6    SI.CAP 
          LX6    36 
          BX7    X6+X7       18/LEN,6/BN,36/RBOC[AI]
          SA7    VFDP+1 
          UX0    X5 
          GNIW               GET DATA WORD
          BX7    X5 
          SA7    VFDP+2 
          SX1    X0+59
          SX2    1S22/60+1
          IX3    X1*X2
          AX3    22          N.DATA-WORDS = (LEN+59)/60 
          SX6    X3-1 
          SA6    VFDPA       NUMBER OF WORDS REMAINING
          SX3    X3+1        NUMBER OF WORDS IN TABLE 
          SX7    LT.VFDP
          LX7    48 
          LX3    36 
          BX7    X7+X3
          SA7    VFDP 
          WRLGO  VFDP,3      VFDP TABLE TO LGO
          SA2    BCDC 
          ZR     X2,VFDP1 
  
          LX0    -SI.CAP
          SX1    X0 
          SX5    1R,
          RJ     CND         CONVERT BN AND ADD , 
          SA6    LBUF+2 
          LX0    SI.CAP 
          SX1    X0 
          SX5    1R/
          RJ     CND         CONVERT LEN/ 
          SA6    A6+B1
          SA4    VFDP+2 
          RJ     CFW         CONVERT DATA 
          SA7    A6+B1       UPPER
          SA6    A7+B1       LOWER
          SA1    =1H
          SA2    =8LVFDP
          SB4    12          UBC = 12 
          BX7    X1 
          SA7    LBUF 
          BX7    X2 
          MX0    42 
          ECHO   4,Z=(LBUF+2,A3+B1) 
          SA3    Z
          BX6    X0*X3
          SB3    X3 
          RJ     ADC
          SB3    60 
          DUP    2,3
          SA3    A3+B1
          BX6    X3 
          RJ     ADC
          R=     X6,1RB 
          LX6    -6 
          SB3    6
          RJ     ADC         ADD FINAL B
          RJ     TSB
          WRTEXT 0           LIST THE LINE
  
 VFDP1    SA2    VFDPA
          ZR     X2,GNIW     IF NO MORE TEXT
          SX7    X2-1 
          SA7    A2 
          GNIW               GET DATA WORD
          BX7    X5 
          SA7    VFDP+2 
          BX4    X5 
          RJ     CFW         CONVERT FULL WORD
          SA7    LBUF+2      STORE UPPER
          BX7    X6 
          SB4    B0          UBC = 0
          SA1    =1H
          BX6    X1 
          SA6    A7-B1       BLANK OPCODE FIELD 
          SA6    A6-B1
          RJ     TSB         TERMINATE STRING AND PRINT LINE
          WRTEXT 0
          WRLGO  VFDP+2,1    DATA WORD TO LGO 
          EQ     VFDP1
  
 VFDP     VFD    12/LT.VFDP,12/2,36/0 
          BSS    2           18/LEN,6/BN,36/RBOC AND DATA WORD
 VFDPA    BSS    1
 CND      SPACE  3,14 
**        CND - CONVERT NUMBER TO DECIMAL AND ADD SEPERATOR 
* 
*         ENTRY  (X1) = BINARY NUMBER 
*                (X5) = 1R_SEP-CHAR 
* 
*         EXIT   (X6) = 42/0L_NUM_SEP-CHAR,18/N.BITS
  
 CND      ROUTINE 
          CALL   CDD= 
          SB3    B2-B1
          MX2    B3 
          BX6    X2*X4       REMOVE TRAILING BLANKS 
          SB2    B2+6 
          SB3    B2-60
          LX5    -B3
          BX6    X6+X5       ADD SEP CHAR 
          SX2    B2 
          BX6    X6+X2       AND BIT COUNT
          EQ     CND
          SPACE  3
 OC.JT    TITLE  OC.JT - PSEUDO OPERATION AND MACHINE INST JUMP TABLE 
**        DEFINE JUMP TABLE FOR PSEUDO OP"S, MACHINE INSTRUCTIONS 
*         AND PSEUDO"S USED BY THE ASSEMBLER
  
 POL      MICRO  1,,
  
          MACRO  POD,NAM
          IFC    NE,/"POL"//,2
 POL      MICRO  1,,/NAM,"POL"/ 
          SKIP   1
 POL      MICRO  1,,/NAM/ 
          ENDM
  
 MAX.OC   SET    OC.LDC+1 
          IFNE   HC.TS,0,1
 MAX.OC   EQU    OC.RS
  
          MACRO  OPR,N
          IFLT   OC.N,MAX.OC
          IF     DEF,)N,2 
          VFD    24/)N
          SKIP   1
          VFD    24/0 
          VFD    18/0 
          IF     DEF,.N,2 
          VFD    18/.N
          SKIP   1
          VFD    18/*+1S17         N
          ENDIF 
          ENDM
  
          LIST   G
          HERE
  
*CALL     PSODEFS 
  
          ECHO   4,Z=("POL")
          IF     DEF,.Z,2 
          VFD    42/,18/.Z
          SKIP   1
          VFD    42/,18/*+1S17     Z
  
 OC.AT    BSS    0
*CALL     OPRDEFS 
  
          END 
