*DECK     COMPASS 
          IDENT  COMPASS,ORGZ 
          ABS 
          IPARAMS                                                       S028 123
          SYSCOM B1 
          LIST   F,X
 COMPASS  SPACE  4
***       COMPASS - CYBER 70 SERIES COMPREHENSIVE ASSEMBLER PROGRAM.
* 
* 
*         VERSION 1.0   67/01/01   D. M. KURN.
*         VERSION 1.1   67/09/01   D. M. KURN.
*         VERSION 2.0   69/06/07   D. A. CAHLANDER. 
*         VERSION 3.0   71/03/01   R. H. GOODELL. 
*         VERSION 3.1   74/10/07   R. H. GOODELL. 
*         VERSION 3.2   75/03/01   R. H. GOODELL. 
*         VERSION 3.3   75/10/23   R. H. GOODELL, V. M. AMEZCUA.
*         VERSION 3.4   76/09/22   V. M. AMEZCUA, C. M. MCDONALD         FEAT184
*                                  R. L. DEMER, J. E. GARCIA.            FEAT184
*         VERSION 3.5   77/05/24   J. E. GARCIA.                         FEAT184
*         VERSION 3.6   78/06/16.  J. E. GARCIA                          F4810B 
*         VERSION 3.7   86/07/14   A.    MCDEARMON. 
*                                                                        FEAT184
* 
* 
*         CONTROL DATA  PROPRIETARY PRODUCT.
*         COPYRIGHT CONTROL DATA CORP. 1971, 1972, 1973, 1974, 1975,
*                                      1976, 1977, 1978, 1979, 1980,
*                                       1981, 1982. 
 ORGZ     SPACE  4,8
*         INITIALIZE CONDITIONAL ASSEMBLY SYMBOLS.
  
*         DETERMINE IF MODEL 76 ASSEMBLY. 
  
          IFC    EQ,*"MODEL"*76*,1
 MODL76   SET    1           ASSEMBLED IF MODEL 76 ASSEMBLY 
  
*         DETERMINE IF NOS OR KRONOS 1.0 (SCOPE1) ASSEMBLY
  
          IFC    EQ,*"OS.NAME"*KRONOS*
 SCP      IFC    EQ,*"OS.VER"*1.0 * 
 SCOPE1   EQU    1           ASSEMBLED IF KRONOS 1.0 (SCOPE1) 
 SCP      ELSE
 NOS      EQU    1           ASSEMBLED IF NOS 
          ENDIF 
  
*         DETERMINE IF NOS/BE OR SCOPE 2. 
  
          IFC    EQ,*"OS.NAME"*SCOPE *,4
          IFC    EQ,*"OS.VER"*2.1 *,1 
 SCOPE2   EQU    1           ASSEMBLED IF SCOPE 2 ASSEMBLY
          IFC    NE,*"OS.VER"*2.1 *,1 
 NOSBE    EQU    1           ASSEMBLED IF NOS/BE ASSEMBLY 
  
*         DETERMINE IF ECS OR LCM MACHINE 
  
          DEFINHF 
  
          IF     MIC,HF.L,1 
 LCMTYP   EQU    1           ASSEMBLED IF LCM AVAILABLE 
  
          IF     -MIC,HF.E,1
 HAFEXIT  EQU    1           ASSEMBLED IF ECS HALF-EXIT AVAILABLE 
  
**        ENTRY POINTS AND ORIGIN OF (0,0) OVERLAY. 
  
  
          ENTRY  COMPASS     PRIMARY ENTRY POINT
  
          IF     DEF,NOS
          ENTRY  ARG=        SUPPRESS ARGUMENT CHECKING BY SYSTEM 
          ENTRY  MFL=        DECLARE MINIMUM FIELD LENGTH 
 ORGZ     EQU    RA.ORG+1+3  LEAVE ROOM FOR 3 ENTRY POINTS
          ELSE
 ORGZ     EQU    RA.ORG+1+1  LEAVE ROOM FOR 1 ENTRY POINT 
          ENDIF 
  
          IF     DEF,SCOPE1,2 
 CP.BASE  EQU    RA.ORG+4    LEAVE ROOM FOR ENTRY POINTS ONLY 
          ELSE   1
 CP.BASE  EQU    RA.ORG+10B+4 LEAVE ROOM FOR 54 TABLE AND ENTRY POINTS
  
  
          ORG    ORGZ        ALIGN *COMPCOM* ORIGIN 
          BSS    CP.BASE-*   WITH CALLING COMPILERS 
 CONTROL  EJECT 
***       CONTROL CARD CALL.
* 
*         COMPASS(P1,P2,...,PN) 
* 
*           OPTION           MEANING
* 
*             A              ABORT IF ERRORS. 
* 
*             B              BINARY ON FILE *LGO*.
*             B=0            NO BINARY. 
*             B=LFN          BINARY ON FILE *LFN*.
* 
*             D              GENERATE BINARY EVEN IF ASSEMBLY ERRORS. 
* 
*             F              *F SET TO 0. 
*             F=NUMBER       *F SET TO NUMBER.
*             F=NAME         *F SET TO NUMBER CORRESPONDING TO NAME 
*                                   (0=COMPASS, 1=RUN, 2=FTN4, 3=FTN5)
* 
*             G              SYSTEXT FROM FILE *SYSTEXT*
*             G=0            NO SYSTEXT FROM A FILE.
*             G=LFN          SYSTEXT FROM FILE *LFN*. 
*             G=LFN/OVL      SYSTEXT FROM OVERLAY *OVL* IN FILE *LFN*.
* 
*             I              INPUT FROM FILE *COMPILE*. 
*             I=LFN          INPUT FROM FILE *LFN*. 
* 
*             L              LONG LIST ON FILE *OUTPUT*.
*             L=0            NO LONG LIST.
*             L=LFN          LONG LIST ON FILE *LFN*. 
* 
*             LO             SET LIST OPTIONS C, F, G, AND X. 
*             LO=0           NORMAL LIST OPTIONS (B, L, N, AND R).
*             LO=CCC-CCC     TOGGLE LIST OPTIONS CCC-CCC. 
* 
*             ML=STRING      VALUE OF *MODLEVEL* MICRO. 
* 
*             N              NO EJECT FLAG. 
* 
*             O              SHORT LIST ON FILE *OUTPUT*. 
*             O=0            NO SHORT LIST. 
*             O=LFN          SHORT LIST ON FILE *LFN*.
* 
*             P              SELECT CONSECUTIVE PAGE NUMBERING. 
* 
*             PC=STRING      VALUE OF *PCOMMENT* MICRO. 
* 
*                                                                        F4810A 
*             PD             PRINT DENSITY IN LINES/INCH.                F4810A 
*             PD             8 LINES/INCH PRINT DENSITY.                 F4810A 
*             PD=X           X LINES/INCH WHERE X=6D OR X=8D.            F4810A 
*             PD=Z           IP.PD LINES/INCH WHERE Z.NE.6 AND Z.NE.8.   F4810A 
*             OMITTED        IP.PD LINES/INCH PRINT DENSITY              F4810A 
*                                                                        F4810A 
*             PS             PAGE SIZE IN LINES/PAGE.                    F4810A 
*             PS=X           X LINES/PAGE WHERE 4.LE.X.LE.99D.           F4810A 
*             PS=Z           IP.PS LINES/PAGE WHERE Z.LT.4 OR Z.GT.99D.  F4810A 
*             OMITTED        IP.PS LINES/PAGE IF PD NOT SPECIFIED.       F4810A 
*             OMITTED        (PD*IP.PS)/IP.PD LINES/PAGE IF PD SPECIFIED F4810A 
*                                                                        F4810A 
*             S              SYSTEXT FROM LIBRARY OVERLAY *SYSTEXT*.
*             S=0            NO SYSTEXT FROM A LIBRARY. 
*             S=OVL          SYSTEXT FROM LIBRARY OVERLAY *OVL*.
*             S=LIB/OVL      SYSTEXT FROM OVERLAY *OVL* IN LIBRARY *LIB*
* 
*             W              USE *SPY* TO WATCH P-REGISTER WITH N=100B. 
*             W=N            USE *SPY* WITH BIN WIDTH *N* (20,40,100).
* 
*             X              XTEXT FILE NAME *OPL*. 
*             X=LFN          XTEXT FROM FILE *LFN*. 
* 
* 
*         IF THE *L* AND *O* PARAMETERS SPECIFY THE SAME FILE, *O=0*
*         IS ASSUMED. 
* 
*         MULTIPLE *G* AND *S* PARAMETERS MAY BE USED TO SPECIFY A
*         TOTAL OF UP TO SEVEN SYSTEM TEXTS.  THEY ARE LOADED IN THE
*         ORDER IN WHICH THEY ARE NAMED ON THE CONTROL CARD, LEFT TO
*         RIGHT.  IF A MACRO, MICRO, OR SYMBOL IS DEFINED MORE THAN 
*         ONCE, THE LAST DEFINITION HOLDS.
* 
*         THE *X* PARAMETER APPLIES ONLY TO *XTEXT* PSEUDO INSTRUCTIONS 
*         IN WHICH THE LOCATION FIELD (FILE NAME) IS EMPTY. 
* 
*         AFTER THE SEPARATOR FOLLOWING  *COMPASS*,  BLANKS IN THE
*         CONTROL CARD ARE IGNORED.  A PARAMETER VALUE MAY BE ENCLOSED
*         IN DOLLAR SIGNS.  WITHIN A $-DELIMITED STRING, ALL SPECIAL
*         CHARACTERS ARE TREATED AS LETTERS, BLANKS ARE SIGNIFICANT,
*         AND  $$  REPRESENTS A SINGLE DOLLAR SIGN.  THE CONTROL
*         STATEMENT MAY BE CONTINUED ONTO AS MANY CARDS AS NECESSARY, 
*         WITH COLUMN 80 OF EACH CARD FOLLOWED BY COLUMN 1 OF THE NEXT
*         CARD, UNTIL A RIGHT PARENTHESIS OR PERIOD IS ENCOUNTERED. 
 CONTROL  SPACE  4
***       NORMAL CONTROL CARD OPTIONS.
* 
* 
*         A      NOT SELECTED.
*         B=LGO 
*         D      NOT SELECTED.
*         F=0 
*         G=0 
*         I=INPUT 
*         L=OUTPUT
*         LO=0
*         ML     = JULIAN DATE (YYDDD). 
*         N      NOT SELECTED.
*         O=OUTPUT
*         P      NOT SELECTED.
*         PC     = 30 BLANKS. 
*         S=SYSTEXT 
*         W      NOT SELECTED.
*         X=OLDPL 
 PARAMS   EJECT 
****      INSTALLATION OPTIONS AND OTHER ASSEMBLY PARAMETERS. 
  
  
  
**        SUPPRESS CONTROL STATEMENT ARGUMENT CHECKING BY SYSTEM. 
  
 ARG=     EQU    1
  
  
  
**        MINIMUM I/O BUFFER LENGTH.
  
 BUFL     MICRO  1,, 1001B
  
  
  
**        DEFAULT COMMENT COLUMN NUMBER.
  
 COMCOL   EQU    30 
  
  
  
**        CONCATENATION MARK (DISPLAY CODE).
  
 CONCAT   EQU    65B         PRINT 1 RIGHT-ARROW OR PRINT 2 UNDERSCORE
  
  
  
**        SELECTION OF ASSEMBLY-TIME I/O SYSTEM.                        S028 126
*         CP#RM = 0 TO ISSUE *CIO* CALLS DIRECTLY.
*               = 7 TO USE 7000 RECORD MANGLER.                         S028 129
  
          IF     -DEF,SCOPE2
 CP#RM    EQU    0           USE CIO ON 6000 AND CYBER 70/ MODELS 71-74 S028 132
          ELSE                                                          S028 133
 CP#RM    EQU    7           USE 7RM ON 7000 SCOPE 2                    S028 137
          ENDIF                                                         S028 138
  
  
  
**        DEBUGGING FACILITY CONTROL. 
*         DEBUG = 0 TO OMIT DEBUGGING FACILITY. 
*               = 1 TO INCLUDE DEBUGGING FACILITY.
  
 DEBUG    EQU    0
  
  
  
**        FL INCREMENT BY WHICH COMPASS WILL INCREASE FL ON EACH MEMORY  F4810B 
*         REQUEST.                                                       F4810B 
                                                                         F4810B 
 FLINC    CEQU   4000B       NUMBER OF WORDS PER CENTRAL MEMORY REQUEST 
                                                                         F4810B 
                                                                         F4810B 
                                                                         F4810B 
**        INSTALLATION PARAMETERS FOR PRINT FORMATS.
  
          IF     -DEF,IP.PD,1 
 IP.PD    CEQU   6           PRINT DENSITY - 3, 4, 6, OR 8 LINES / INCH 
          IF     -DEF,IP.PS,1 
 IP.PS    CEQU   IP.PD*10    PAGE SIZE - NUMBER OF LINES PER PAGE 
          IF     -DEF,IP.PW,1 
 IP.PW    CEQU   136         PAGE WIDTH - NUMBER OF CHARACTERS PER LINE 
  
  
  
**        MAXIMUM RECURSION DEPTH.
  
 LIMRECUR MICRO  1,, 400
  
  
  
**        RECORD MANAGER LISTING CONTROL. 
*         LISTRM = * * TO LIST RECORD MANAGER ROUTINES. 
*                = *-* TO SUPPRESS LISTING OF RM CODE.
  
 LISTRM   MICRO  1,, -
                                                                        S028 142
                                                                        S028 143
                                                                        S028 144
**        MAXIMUM ECS/LCM FIELD LENGTH FOR COMPASS.                     S028 145
                                                                        S028 146
 MFLL     EQU    200000B     = 65536 DECIMAL                            S028 147
  
  
  
**        MINIMUM FIELD LENGTH FOR COMPASS. 
  
*MFL=     EQU    MIN.FL      DEFINED AT END OF PROGRAM. 
  
  
  
**        MICRO SUBSTITUTION MARK (DISPLAY CODE). 
  
 MICMARK  EQU    64B         PRINT 1 NOT-EQUAL OR PRINT 2 DOUBLE-QUOTE
  
  
  
**        FL AT WHICH COMPASS WILL DUMP TABLES TO FILES.                 F4810B 
                                                                         F4810B 
 MIDFL    CEQU   60000B      FL TO DUMP TABLES TO FILES                  F4810B 
                                                                         F4810B 
                                                                         F4810B 
                                                                         F4810B 
**        MAXIMUM NUMBER OF ENTRIES IN PUSH-DOWN STACKS.
*         APPLIES TO THE BASE, CODE, LIST, QUAL, AND USE STACKS.
  
 MSTACK   EQU    50 
  
  
  
**        MAXIMUM NUMBER OF CARDS PER STATEMENT - MUST NOT EXCEED 15. 
  
 NCARDS   EQU    10 
  
  
  
**        MAXIMUM NUMBER OF VALUE WORDS IN A LITERAL. 
  
 NLITS    EQU    100
                                                                        S028 150
                                                                        S028 151
                                                                        S028 152
**        NOMINAL FIELD LENGTH FOR *REDUCE* MODE UNDER SCOPE 2.         S028 153
                                                                        S028 154
 NOM.FL   EQU    60000B                                                 S028 155
  
  
  
**        BASE NUMBER OF OPCODE TABLE ENTRIES - MUST BE A POWER OF 2. 
  
 NOPCT    EQU    128
  
  
  
**        BASE NUMBER OF SYMBOL TABLE ENTRIES - MUST BE A POWER OF 2. 
  
 NSYMT    EQU    256
  
  
  
**        OVERLAY CONTROL.
*         OVERLAY = 0 FOR ONE (0,0) OVERLAY.
*                 = 1 FOR TWO OVERLAYS, (0,0) AND (1,0).
  
 OVERLAY  SET    1
 OVERLAY  MIN    OVERLAY,1-DEBUG   FORCE OVERLAY = 0 IF DEBUG = 1 
  
  
  
**        PROGRAM LIBRARY FILE NAME FOR RECORD MANAGER. 
*         USED IN *XTEXT* CARDS THAT OBTAIN RECORD MANAGER CODE 
*         MODULES FROM ITS PROGRAM LIBRARY FILE WHEN COMPASS
*         IS ASSEMBLED WITH CP#RM = 1 AND "MODEL" < 75. 
  
 #PLRM#   MICRO  1,8,*        * 
  
  
  
**        TIMING ANALYSIS OPTION. 
*         SPY = 0 TO OMIT TIMING ANALYSIS.
*             = 1 TO CALL *SPY* FOR TIMING ANALYSIS.
  
 SPY      EQU    0
  
  
  
**        INITIAL SPACE REQUIRED BY COMPASS TO LOAD TEXTS.               F4810B 
                                                                         F4810B 
 TXTFL    CEQU   20000B                                                  F4810B 
                                                                         F4810B 
                                                                         F4810B 
**        *XREF* DEFAULT VALUE. 
*         XRDV = -1  FOR PAGE/LINE (P) FORMAT.
*              =  0  FOR ADDRESS (A) FORMAT.
*              = +1  FOR BOTH (B) FORMAT. 
  
 XRDV     EQU    -1 
  
  
  
**        ASSEMBLER VERSION AND MODIFICATION LEVEL. 
*         PLACED IN HEADER LINE OF EACH LISTING PAGE AND IN 
*         WORDS 5-6 OF EACH PRFX TABLE IN BINARY OUTPUT.
  
VERSION   MICRO  1,3,*3.7*
 PSRLEVEL MICRO  1,3,*871*
  
          IFC    -EQ,*"MODLEVEL"*"JDATE"*,1                              CPSA098
 PSRLEVEL MICRO  1,5,*"MODLEVEL"*                                        CPSA098
 PVERSION MICRO  1,8,*"VERSION""PSRLEVEL"*                               CPSA098
 VERSION  MICRO  1,9,*"VERSION"-"PSRLEVEL"*                              CPSA098
  
  
  
**        COMMENT AND TITLE CARDS.
  
          COMMENT   CYBER 70/ MODEL "MODEL" 
          COMMENT   COMPREHENSIVE ASSEMBLER PROGRAM VERSION "VERSION".
          TITLE  COMPASS "VERSION" - CYBER 70/ COMPREHENSIVE ASSEMBLER. 
  
  
  
**        DEFINITIONS USED BY COMPILER/COMPASS COMMON DECK. 
  
 CP.ABORT MICRO  1,, 0       DEFAULT IS NO ABORT ON ASSEMBLY ERRORS 
 CP.BLF   MICRO  1,, 0       DEFAULT VALUE OF *BL* PARAMETER
 CP.F=    MICRO  1,, 0       DEFAULT VALUE OF *F* PARAMETER 
 CP.LISTF MICRO  1,, 1       DEFAULT IS DO WRITE LONG LISTING 
 CP.PAGE  MICRO  1,, 1S59    DEFAULT IS NO PAGE NUMBER PROPAGATION
  
  
  
****
 LOG2     SPACE  4
**        LOG2 - LOG TO THE BASE 2 MACRO. 
* SYM     LOG2   VAL
*         ENTRY  (VAL) = ARGUMENT.
*         EXIT   (SYM) = LOG(2) OF ARGUMENT.
  
  
          MACRO  LOG2,SYM,VAL 
          IFLE   VAL,1,1
 SYM      SET    0
          IFGE   VAL,2,2
 SYM      LOG2   VAL/2
 SYM      SET    SYM+1
          ENDM
  
  
 TLUOPSHF LOG2   NOPCT       LOGARITHM OF NOPCT 
 SHIFTQ   LOG2   NSYMT       LOGARITHM OF NSYMT 
 FET      TITLE  MACRO DEFINITIONS. 
 RM       IFEQ   CP#RM,0
 FET      SPACE  4
**        FET - FILE ENVIRONMENT TABLE MACRO. 
*         FET    FNAME,BUF,BUFL,STATUS,RANDOM 
*         ENTRY  (FNAME) = FILE NAME. 
*                (BUF) = FIRST WORD ADDRESS OF BUFFER.
*                (BUFL) = LENGTH OF BUFFER. 
*                (RANDOM) = RANDOM FILE INDICATION. 
*                (STATUS) = BUFFER STATUS.
  
  
 FET      MACRO  FNAME,BUF,BUFL,STATUS,RANDOM 
          CON    0L;A+STATUS
          VFD    24/RANDOM,18/3,18/BUF
          CON    BUF
          CON    BUF
          CON    BUF+BUFL 
          BSSZ   3
          ENDM
  
  
**        EQUIVALENCED I/O MACROS.
  
  
 CHECK    OPSYN  RECALL 
 REWINDM  OPSYN  REWIND 
 WEOR     OPSYN  WRITER 
  
  
 RM       ENDIF 
 JOBMSG   SPACE  4
**        JOBMSG - SEND MESSAGE TO JOB DAYFILE AND B-DISPLAY. 
*         JOBMSG M,L
*         ENTRY  (M) = FIRST WORD ADDRESS OF MESSAGE. 
*                (L) = NONBLANK FOR AUTORECALL. 
  
  
 JOBMSG   MACRO  M,L
          IFEQ   CP#RM,7                                                S028 164
          MESSAGE (M),,L
          ELSE                                                          S028 166
          MESSAGE (M),LOCAL,L                                           S028 167
          ENDIF 
          ENDM
                                                                        S028 169
                                                                        S028 170
 LOCAL    EQU    3           LOCAL DAYFILE FLAG FOR KRONOS AND SCOPE 1  S028 171
 MANAGE   SPACE  4
**        MANAGE - MANAGE TABLE MACRO.
*         MANAGE TABNAM,INCR
*         ENTRY  (TABNAM) = TABLE NAME. 
*                (INCR) = TABLE LENGTH INCREMENT. 
  
  
 MANAGE   MACRO  TABNAM,INCR
          R=     X1,INCR
          R=     A0,TABNAM
          RJ     ALC
          ENDM
 TABLE    SPACE  4
**        TABLE - CREATE MANAGED TABLE. 
*         TABLE  TNAM,EQIV
*         ENTRY  (TNAM) = TABLE NAME. 
*                (EQIV) = EQUIVALENCED TABLE NAME.
  
  
          MACRO  TABLE,TNAM,EQIV
          IF     -DEF,O.TNAM
 1        IFC    EQ,**EQIV* 
 TNAM     EQU    *-ORIGINS
 O.TNAM   CON    BUCKET 
          RMT 
 L.TNAM CON    0
          RMT 
 1        ELSE   5
 TNAM     EQU    EQIV 
 O.TNAM   EQU    O.EQIV 
          RMT 
 L.TNAM   EQU    TNAM+SIZES 
          RMT 
          IFNE   DEBUG,0                                                S028 173
 DEBUG    RMT                                                           S028 174
          CON    0L_TNAM+TNAM                                           S028 175
          RMT                                                           S028 176
          ENDIF                                                         S028 177
          ENDM
 PCARD    SPACE  4
**        PCARD - PACK CARD INTO MANAGED TABLE. 
*         PCARD  TNAM 
*         ENTRY  (TNAM) = MANAGED TABLE NAME. 
  
  
 PCARD    MACRO  TNAM 
          R=     X1,TNAM
          RJ     PCARD
          ENDM
 ADDWORD  SPACE  4
**        ADDWORD - ADDWORD TO MANAGED TABLE. 
*         ADDWORD TABNAM
*         ENTRY  (TABNAM) = MANAGED TABLE NAME. 
  
  
 ADDWORD  MACRO  TABNAM 
          R=     A0,TABNAM
          RJ     ADDWORD
          ENDM
 STACK    SPACE  4
**        STACK - DEFINE PUSH-DOWN STACK AREA.
*NAME     STACK  BPE,MAX,VAL
*         ENTRY  (NAME) = NAME OF STACK.
*                (BPE)  = NUMBER OF BITS PER ENTRY. 
*                (MAX)  = MAXIMUM NUMBER OF ENTRIES.
*                (VAL)  = DEFAULT ENTRY VALUE.
  
  
          MACRO  STACK,NAME,BPE,MAX,VAL 
 U.       SET    60/BPE 
 N.       SET    MAX+U.-1 
 N.       SET    N./U.
 U.       SET    60-U.*BPE
 NAME     VFD    18/VAL,6/U.,6/BPE,6/0,6/0,18/MAX 
          BSSZ   N. 
 STACKPTR RMT 
          VFD    42/MAX,18/NAME 
          RMT 
          ENDM
 INTMUL   SPACE  4
**        REDEFINE INTEGER MULTIPLY INSTRUCTION.
  
  
          IF     DEF,IP.IMUL,3                                          S028 179
          IFNE   IP.IMUL,0,2                                            S028 180
          PURGDEF IXX*X 
 IXX*X    CPSYN  DXX*X
 SCOPE1   SPACE  4
**        REDEFINE SYSTEM MACROS FOR KRONOS AND SCOPE 1.
  
  
 SCOPE1   IF     DEF,SCOPE1 
          PURGMAC CONTRLC 
 CONTRLC  MACRO  S
          SYSTEM CPM,1,RA.CCD,700B
          ENDM
 SCOPE1   ENDIF                                                          CPS153 
  
          IF     -DEF,SCOPE1,1
          IF     DEF,NOS
          PURGMAC MESSAGE 
 MESSAGE  MACRO  M,X,L
          R=     X1,M 
          IFC    EQ, L  ,2
          R=     X6,X 
          SKIP   1
          R=     X6,1S16+X
          RJ     =XMSG= 
          ENDM
  
          PURGMAC RETURN
 RETURN   MACRO  F,L
          R=     X2,F                                                    CPSA096
 RT       IFC    EQ,*L**                                                 CPSA096
          SX7    70B                                                     CPSA096
 RT       ELSE   1                                                       CPSA096
          SX7    -70B                                                    CPSA096
          RJ     =XCIO=                                                  CPSA096
          ENDM
  
          ENDIF 
 LCM      SPACE  4,8
**        REDEFINE LCM INSTRUCTIONS FOR SYSTEMS OTHER THAN SCOPE 2. 
  
  
 RM       IFNE   CP#RM,7
  
          PURGDEF RXX 
 RXX      OPDEF  I,K
          SA.I   X.K
          ERRMI  I-1         RX.I  ILLEGAL
          ERRPL  I-6         RX.I  ILLEGAL
          ENDM
  
          PURGDEF WXX 
 WXX      OPDEF  I,K
          SA.I   X.K
          ERRMI  I-6         WX.I  ILLEGAL
          ENDM
  
 RM       ENDIF 
  
  
*CALL     COMPCOM 
  
  
 LINKAGE  TITLE  DEFINITIONS DEPENDENT ON COMPCOM.
****      DEFINITIONS DEPENDENT ON COMPILER/COMPASS COMMON DECK.
  
  
  
**        BUFFER SIZES. 
  
 BBUFL    EQU    "BUFL"      BINARY BUFFER LENGTH 
 DBUFL    EQU    "BUFL"*DEBUG SNAPPER BUFFER LENGTH 
 EBUFL    EQU    "BUFL"      ERROR LISTING BUFFER LENGTH
 GBUFL    EQU    "BUFL"*2    SYSTEM TEXT FILE BUFFER LENGTH 
 IBUFL    EQU    "BUFL"      SOURCE INPUT BUFFER LENGTH 
 RBUFL    EQU    "BUFL"      CROSS-REFERENCE BUFFER LENGTH
 SBUFL    EQU    "BUFL"*2    INTERMEDIATE BUFFER LENGTH 
  
  
  
**        SECONDARY OVERLAY NAMES.
  
 OVLA     MICRO  1,, "CP.NAME"A    PASS 1 AND PASS 2 ROUTINES 
  
  
  
****
 STOP     TITLE  MAIN PROGRAM.
**        STOP - END OF JOB PROCESSING. 
  
  
 STOP     SA1    CP.MAXFL    MAX SCM USED DURING RUN
          SX2    100B+10D 
          MX0    -6          ADD THE TEN UNUSED WORDS AND 
          IX3    X1+X2       INCREASE TO NEXT MULTIPLE OF 100B
          BX1    X0*X3
          MX6    0
          SA6    PPTYPE      CLEAR PPTYPE SO OCTAL WILL REALLY BE USED
          RJ     CONOCT      CONVERT TO OCTAL 
          LX6    18 
                                                                        S028 185
          IF     DEF,MODL76 
          SX1    3RB S       ASSEMBLED IF MODEL 76 ASSEMBLY (SCM) 
          ELSE   1
          SX1    3RB         ASSEMBLED IF NOT MODEL 76 ASSEMBLY (CM)
                                                                        S028 190
          MX0    -18
          BX6    X0*X6
          BX6    X6+X1
          SA6    STPA+2      STORE IN MESSAGES
          SA6    STPB+2 
          SA1    BLCM        MAX ECS/LCM USED DURING RUN                S028 192
          ZR     X1,STP0     IF NONE                                    S028 193
          SX2    100B+10D                                               S028 194
          MX0    -6          ADD THE TEN UNUSED WORDS AND               S028 195
          IX3    X1+X2       INCREASE TO NEXT MULTIPLE OF 100B          S028 196
          BX1    X0*X3                                                  S028 197
          RJ     CONOCT      CONVERT TO OCTAL                           S028 198
          SA1    STPD+1                                                 S028 199
          SA2    A1+B1                                                  S028 200
          SA3    A2+B1                                                  S028 201
          MX0    -18         STORE IN MESSAGE                           S028 202
          BX7    X1                                                     S028 203
          LX6    18                                                     S028 204
          BX6    X0*X6                                                  S028 205
          BX2    -X0*X2                                                 S028 206
          BX6    X6+X2                                                  S028 207
          SA7    STPC+1                                                 S028 208
          SA6    A7+B1                                                  S028 209
          BX7    X3                                                     S028 210
          SA7    A6+B1                                                  S028 211
 STP0     SB7    BTIME       CONVERT BATCH ASSEMBLY TIME                S028 212
          RJ     CPTIME 
          SA6    STPC        STORE IN MESSAGE 
  
          SA1    CP.ERRCT 
          ZR     X1,STP1     IF NO ERRORS 
          MI     X1,STP1     IF *D* MODE SET
          MESSAGE STPB,,R    *ASSEMBLY ERRORS.* 
          MESSAGE STPC,,R    *ASSEMBLY TIME.* 
  
          SA1    CP.ABORT 
          LX1    59-29
          PL     X1,STP2     IF ABORT NOT SET 
          ABORT  ,NODUMP,S
  
 STP1     MESSAGE STPA,,R    *ASSEMBLY COMPLETE.* 
          MESSAGE STPC,,R    *ASSEMBLY TIME.* 
  
 STP2     BSS    0
  
 SPY      IFNE   SPY,0
  
          SA1    SPYPAR 
          ZR     X1,STP3     IF SPY NOT CALLED
          MX7    1
          SA7    A1          SIGNAL SPY TO QUIT 
          RECALL A7 
          SA2    A7+B1
          BX7    X2 
          SA7    RA.PGN      CALL *PRNTSPY* 
          SA7    RA.CCD 
          MESSAGE A7,,R 
          LOADREQ 
          EQ     *
  
          DATA   0LCOMPASS   SPY PARAMETERS 
 SPYPAR   DATA   0
          DATA   0LPRNTSPY
  
 SPY      ENDIF 
  
 STP3     ENDRUN
  
 STPA     DATA   C* ASSEMBLY COMPLETE.      00B SCM USED.*
 STPB     DATA   C* ASSEMBLY ERRORS.        00B SCM USED.*
  
 STPC     DATA   C* XXXX.XXX  CPU SECONDS  ASSEMBLY TIME.*
  
          IF     -DEF,LCMTYP
 STPD     DATA   C* XXXX.XXX  CPU SEC.      00B ECS USED.*              S028 219
          ELSE   1
 STPD     DATA   C* XXXX.XXX  CPU SEC.      00B LCM USED.*              S028 221
 BUFFERS  SPACE  4
**        END OF RESIDENT CODE. 
  
  
          USE    BUFFERS
          IDENT              I/O BUFFERS AND INITIALIZATION.
 IBUF     EQU    CP.ORG-IBUFL 
 OBUF     BSS    0
 OBUFL    EQU    IBUF-OBUF
          ORG    OBUF 
 R        ERRMI  OBUFL-"BUFL"      RESIDENT CODE IS TOO LARGE 
 CMP      TITLE  CONTROL CARD OPTION PROCESSING.
**        COMPASS INITIALIZATION. 
  
  
 COMPASS  SB1    1           SET (B1) = 1 
          SX6    A0 
          BX7    X0 
          SA6    CP.NFLS     SAVE FIELD LENGTHS 
          SA7    CP.NFLL
          SA6    CP.AFLS
          SA7    CP.AFLL
          SX6    B0          CLEAR SOURCE CARD IMAGE
          SA6    CP.CARD
          RJ     TFL         TEST FIELD LENGTH, START LOADING OVERLAY 
  
          IFNE   SPY,0,1
          RJ     SSP         START *SPY*
  
          IFNE   OVERLAY,0,1
          RJ     LOV         LOAD OVERLAY 
  
          RJ     ARG         GET ARGUMENTS FROM CONTROL STATEMENT        F4810A 
          RJ     DMF         DIAGNOSE MISUSED FILES (B=A,I=A) 
          RJ     IFP         INITIALIZE FILE PARAMETERS 
          RJ     SFV         SET *F VALUE 
          RJ     SLF         SET LIST FLAGS 
          EQ     CMP         GO TO CONTROL OVERLAY
 ARG      SPACE  4
**        ARG - PROCESS ARGUMENTS FROM CONTROL STATEMENT. 
*         ENTRY  FIRST CARD OF CONTROL STATEMENT IN RA.CCD ET SEQ.
*         EXIT   ARGUMENTS PROCESSED. 
*         USES   ALL. 
*         CALLS  GAC, GAV.
  
  
 ARG      PS                 RETURN EXIT
          JDATE  CP.MODL
          SA5    CP.MODL
          SA0    10 
          BX6    X5          SET JULIAN DATE AS DEFAULT 
          LX6    30          VALUE OF *MODLEVEL* MICRO
          SA6    A5 
          SA6    OPTML
          MX0    -6 
          SB5    B0 
 ARG1     SB3    B1          SKIP BLANKS, KCL PREFIXES $ AND /
          RJ     GAC         GET NEXT CHARACTER.
          SB7    X4-1R+ 
          PL     B7,ARG1     IF CHARACTER IS NOT ALPHANUMERIC SKIP IT.
          SB7    X4-1R0      ELSE 
          LT     B7,ARG1B    IF ALPHA, GO PROCESS VERB. 
 ARG1A    SB3    B1          ELSE SKIP KCL LABEL. 
          RJ     GAC         GET NEXT CHARACTER.
          SB7    X4          SET SHIFT COUNT TO OCTAL VALUE OF CHARACTER
          SA4    =33320200B  MASK FOR SEPARATORS + - " / = , ( $
          LX4    B7 
          MI     X4,ARG1     IF SEPARATOR CHECK NEXT FIELD. 
          EQ     ARG1A       ELSE CONTINUE SKIPPING KCL LABEL.
  
 ARG1B    MX6    0
 ARG2     LX6    6           SCAN VERB
          SB3    0
          BX6    X6+X4
  
          IF     -DEF,SCOPE1,1
          IF     DEF,NOS,1
 ARG2B    BSS    0           ASSEMBLED FOR NOS ASSEMBLY ONLY
  
          RJ     GAC
          SB7    X4-1R9-1 
          MI     B7,ARG2
  
          IF     -DEF,SCOPE1,1
          IF     DEF,NOS,2
          SB7    X4-1R       ASSEMBLED ON NOS ASSEMBLY ONLY 
          ZR     B7,ARG2B    IF SPACE ENCOUNTERED 
  
          SB7    X4-1R.      RETURN IF TERMINATOR 
          SB6    X4-1R) 
          ZR     B7,ARG 
          ZR     B6,ARG 
          SB3    -B1
          NE     B6,B1,ARG2A IF NOT $ 
          SB3    B0 
 ARG2A    SA4    ARGQ        CHECK VERB 
          BX6    X6-X4
          NZ     X6,ARG3     IF NOT *EXECUTE* 
          RJ     GAV         SKIP FIRST ARGUMENT
  
*         PROCESS NEXT KEYWORD. 
  
 ARG3     MI     B4,ARG      RETURN IF TERMINATOR 
          RJ     GAV         GET ARGUMENT VALUE 
          ZR     X6,ARG3     IGNORE EMPTY ARGUMENT
          SA2    OPT
          MX3    12 
          SB7    LOPT 
          SA6    ARGM+3 
 ARG4     BX4    X3*X2       SEARCH KEYWORD LIST
          SB7    B7-1 
          BX7    X4-X6
          ZR     X7,ARG5     IF FOUND 
          SA2    A2+1 
          NZ     B7,ARG4     LOOP 
          EQ     ARGE 
 ARG5     SB7    X2 
          BX7    X2 
          LX7    59-29
          MI     X7,ARG5A    IF MULTIPLE OCCURRANCES OK 
          LX7    29-28
          MI     X7,ARGE     IF NOT FIRST OCCUR.
          MX4    1
          BX7    X4+X7
          LX7    28+1        RESTORE AND SET *OCCURRED* 
          SA7    A2 
  
 ARG5A    AX2    30 
          SB6    X2 
          PL     B6,ARG6     IF = ALLOWED 
          SX2    -B6
 ARG6     SA2    X2          GET DEFAULT VALUE
          BX7    X2 
          MI     B7,ARG7     IF SPECIAL ARGUMENT
 ARG6A    BSS    0
          SX2    B4-3 
          SA7    B7          STORE DEFAULT VALUE
          NZ     X2,ARG3     IF NO =
          MI     B6,ARGE     IF = NOT ALLOWED 
          SB2    B6          SAVE LOC. OF DEFAULT OF ARG. 
          RJ     GAV         GET ARGUMENT VALUE 
          SA6    B7 
          SB7    OPTI        TEST FOR ILLEGAL ARGUMENT *I=0*. 
          NE     B2,B7,TXARG IF *ARG"I* TEST FOR *ARG=X*. 
          ZR     X6,ARGE     ELSE IF *I=0* PRINT ERROR MESSAGE AND ABORT
 TXARG    SB7    OPTX             ELSE TEST FOR ILLEGAL ARGUMENT *X=0*. 
          NE     B2,B7,ARG3  IF *ARG"X* CONTINUE PROCESSING.
          NZ     X6,ARG3     ELSE IF *X"0* CONTINUE PROCESSING. 
          EQ     ARGE             ELSE PRINT ERROR MESSAGE AND ABORT. 
 ARG7     SB7    -B7         PROCESS SPECIAL ARGUMENT 
          JP     B7 
  
*         PROCESS *E* AND *O* ARGUMENTS 
  
 ARG7A    SA1    ERFFLG 
          NZ,X1  ARGE        IF BOTH E AND O ARE SPECIFIED, ERROR 
          SX6    B1 
          SA6    A1          SET FLAG TO INDICATE E OR O SPECIFIED
          SB7    ELFN        CELL TO STORE DEFAULT IN 
          EQ     ARG6A
  
*         PROCESS *G* ARGUMENT - G, G=0, G=LFN, OR G=LFN/OVL. 
  
 ARG8     SB7    B4-3        LFN = *SYSTEXT*
          MX6    0           OVL = NO NAME
          NZ     B7,ARG9     IF NO =
          RJ     GAV         GET FILE NAME
          SB7    B4-2 
          BX7    X6 
          MX6    0
          NZ     B7,ARG9     IF NO /
          RJ     GAV         GET OVERLAY NAME 
 ARG9     ZR     X7,ARG3     IF *G=0*, IGNORE IT
          SX2    B1 
          BX6    X6+X2       SET *G* FLAG 
          EQ     ARG12
  
*         PROCESS *S* ARGUMENT - S, S=0, S=OVL, OR S=LIB/OVL. 
  
 ARG10    SB7    B4-3 
          BX6    X7          OVL = *SYSTEXT*
          MX7    0           LIB = NO NAME
          NZ     B7,ARG11    IF NO =
          RJ     GAV         GET LIB OR OVL 
          SB7    B4-2 
          NZ     B7,ARG11    IF NO /
          BX7    X6          SET LIBRARY NAME 
          RJ     GAV         GET OVERLAY NAME 
 ARG11    NZ     X6,ARG12    IF NOT *S=0* 
          SA6    CP.LIB      SET *S=0* FLAG 
          EQ     ARG3 
 ARG12    SA2    CP.STEXT    GET SYSTEM TEXT COUNTER
          SB6    X2-7 
          SB7    X2+B1
          ZR     B6,ARG13    IF HAVE 7 ALREADY
          SA6    A2+B7       STORE OVERLAY NAME 
          SA7    CP.LIB+B7   STORE FILE OR LIBRARY NAME 
          SX6    B7 
          SA6    A2          STORE UPDATED COUNT
          EQ     ARG3 
 ARG13    MESSAGE ARGN,,R    *MORE THAN 7 SYSTEM TEXTS SPECIFIED.*
          ABORT  ,NODUMP
  
*         PROCESS *ML* ARGUMENT.
  
 ARG14    SB7    CP.MODL
          EQ     ARG16
  
*         PROCESS *LO* ARGUMENT.
  
 ARG15    SB7    SLFA 
 ARG16    SB6    B4-3 
          MX6    0
          SA7    B7          STORE DEFAULT VALUE
          NZ     B6,ARG3     IF NO =
          SB6    54 
 ARG17    RJ     GAC         GET ARGUMENT CHARACTER 
          NZ     B4,ARG18    IF SEPARATOR 
          LX4    B6 
          BX6    X6+X4
          SB6    B6-6 
          PL     B6,ARG17    IF NOT MORE THAN 9 CHARACTERS
          EQ     ARGE 
 ARG18    SA6    B7          STORE ARGUMENT 
          EQ     ARG3 
  
*         PROCESS *PC* ARGUMENT.
  
 ARG19    SB7    3
          SB6    54 
          NE     B4,B7,ARG3  IF NO =
          SB7    -B7
          MX6    0
 ARG20    RJ     GAC         GET ARGUMENT CHARACTER 
          NZ     B4,ARG22    IF SEPARATOR 
          LX4    B6 
          BX6    X6+X4
          SB6    B6-6 
          PL     B6,ARG20    IF WORD NOT FULL 
          PL     B7,ARG21    IF ALREADY HAVE 30 CHARACTERS
          SA6    CP.PCOM+3+B7 
 ARG21    SB7    B7+B1       COUNT WORDS
          SB6    54 
          MX6    0
          EQ     ARG20
 ARG22    PL     B7,ARG3     IF 30 CHARACTERS ALREADY STORED
          SA2    ARGL 
          SB6    B6-48
          SB2    6
          MX3    0
          EQ     B6,B2,ARG23 IF WORD IS EMPTY 
          MX3    6
          LX3    B6 
 ARG23    BX7    -X3*X2      BLANK FILL LAST WORD 
          BX6    X6+X7
          SA6    CP.PCOM+3+B7 
          EQ     ARG3 
  
*         PROCESS *PD* ARGUMENT.                                         F4810A 
                                                                         F4810A 
 ARG24    SB7    B4-3        CHECK IF =                                  F4810A 
          SX2    8           SECOND DEFAULT                              F4810A 
          NZ     B7,ARG25    IF NO = , GO SET CP.PD TO SECOND DEFAULT    F4810A 
          RJ     GAV         GET PRINT DENSITY                           F4810A 
          RJ     CDB         CONVERT DISPLAY CODE TO BINARY EQUIVALENT   F4810A 
          MI     X2,ARG3     IF ERROR, RETURN (CP.PD=DEFAULT)            F4810A 
          SX1    X2-8                                                    F4810A 
          ZR     X1,ARG25    IF 8 LINES/INCH                             F4810A 
          SX1    X2-6                                                    F4810A 
          NZ     X1,ARG3     IF NOT 6 OR 8 LINES/INCH CP.PD=DEFAULT      F4810A 
 ARG25    BX7    X2          ELSE                                        F4810A 
          SA7    CP.PD       SET PRINT DENSITY                           F4810A 
          SA1    CP.PS       IF PS ARG WAS SPECIFIED, RETURN
          NZ     X1,ARG3
          GETPAGE SPFA       ELSE CALC. PAGE SIZE USING 
          SA1    CP.PD         DEFAULT VALUES TO RATIO
          BX2    X1 
          SA1    SPFA 
          MX3    59          CLEAR COMPLETION BIT 
          BX7    X3*X1
          SA7    A1 
          MX3    -8          *PS* FIELD SIZE
          BX7    X2 
          AX1    20          POSITION FOR *PS*
          BX2    -X3*X1      EXTRACT DEFAULT *PS* 
          AX1    8           POSITION FOR *PD*
          MX3    -4          *PS* FIELD SIZE
          BX1    -X3*X1      EXTRACT DEFAULT *PD* 
          IX7    X7*X2                                                   F4810A 
          IX7    X7/X1                                                   F4810A 
          SA7    CP.PS       STORE CALCULATED PAGE SIZE                  F4810A 
          EQ     ARG3        RETURN                                      F4810A 
                                                                         F4810A 
*         PROCESS *PS* ARGUMENT.                                         F4810A 
                                                                         F4810A 
 ARG26    SB7    B4-3        CHECK IF =                                  F4810A 
          NZ     B7,ARG3     IF NO = , RETURN JOB DEFAULT 
          RJ     GAV         GET PAGE SIZE VALUE
          RJ     CDB         CONVERT DISPLAY CODE TO BINARY EQUIVALENT
          MI     X2,ARG3     IF ERROR, USE JOB DEFAULT
          SX7    99D         PRESET MAX =99D
          IX1    X7-X2
          NG     X1,ARG27    IF .GT. MAX, USE JOB MAX = 99D 
          SX7    4D          PRESET MIN = 4 
          IX1    X2-X7
          NG     X1,ARG27    IF .LT. MIN, USE MIN = 4 
          BX7    X2 
          SA7    CP.PS       SET PAGE SIZE
          EQ     ARG3        RETURN 
  
 ARG27    SA7    CP.PS       STORE ADJUSTED PAGE SIZE 
          MESSAGE ARGA,,R    DIAGNOSE INCORRECT PAGE SIZE 
          EQ     ARG3        RETURN 
                                                                         F4810A 
*         ERROR EXIT. 
  
 ARGE     MESSAGE ARGM,,R 
          ABORT  ,NODUMP
 GAC      SPACE  4
**        GAC - GET ARGUMENT CHARACTER. 
*         ENTRY  (X0) = MASK -6.
*                (X5) = CURRENT WORD OF CARD IMAGE. 
*                (A0) = 10. 
*                (A5) = ADDRESS OF (X5).
*                (B3) = $ MODE,  -1 = NORMAL,  0 = STRING MODE. 
*                (B5) = NUMBER OF CHARACTERS REMAINING IN (X5). 
*         EXIT   (X4) = CHARACTER.
*                (B4) = CHARACTER TYPE,  -1 = TERMINATOR,  0 = ALPHANUM,
*                            +1 = SEPARATOR,  +2 = /, +3 = =. 
*                (X5, A5, B3, B5)  UPDATED. 
*         USES   X1-X4, A1-A3, A6.
*         CALLS  CONTRLC, MESSAGE.
  
  
 GAC      PS                 RETURN EXIT
 GAC1     ZR     B5,GAC5     IF (X5) IS EMPTY 
          LX5    6
          SB5    B5-B1       EXTRACT NEXT CHARACTER 
          BX4    -X0*X5 
          SB4    X4-1R$ 
          ZR     B4,GAC3     IF $ 
          ZR     B3,GAC4     IF IN STRING MODE
          SB4    B0 
          MI     B3,GAC2     IF NOT LEAVING STRING MODE 
          SB3    -B1
 GAC2     SX2    X4-1R9-1    CLASSIFY CHARACTER 
          SX3    X4-1R.-1 
          MI     X2,GAC      IF ALPHANUMERIC, RETURN
          SB4    B1 
          LX2    2
          PL     X3,GAC      IF NON-DISPLAY, RETURN 
          SA3    GACA 
          SB4    X2 
          LX2    X3,B4       GET CHARACTER TYPE CODE
          AX2    56 
          SB4    X2 
          NZ     X2,GAC      IF NOT BLANK, RETURN 
          PL     X2,GAC 
          EQ     GAC1        IGNORE BLANK 
 GAC3     SB3    B3+B1
          LE     B3,B1,GAC1  IF NOT SECOND $ OF A PAIR IN STRING MODE 
          SB3    B0 
 GAC4     SB4    B0          STRING MODE, RETURN WITH CHARACTER TYPE = 0
          EQ     GAC
 GAC5     SA1    GACC 
          SB5    A0 
          SA5    A5+B1
          ZR     X1,GAC7     IF INITIAL ENTRY 
          NZ     X5,GAC1     IF NOT END OF CARD 
          MI     X5,GAC1
          SA6    GACB        SAVE (X6)
          SA3    RA.PGN      SAVE FILE NAME FROM RA+64
          IF     DEF,NOS,2
          CONTRLC GACC,,,CRACK  READ NEXT CONTROL STATEMENT 
          ELSE   1
          CONTRLC GACC       READ NEXT CARD 
          BX6    X3          RESTORE FILE NAME
          SA6    A3 
          SA1    RA.CCD 
          NZ     X1,GAC6
          PL     X1,GAC9     IF END OF CONTROL CARDS
 GAC6     MESSAGE RA.CCD,,R 
 GAC7     SX6    10B         SET *READ* REQUEST FOR NEXT CONTROL CARD 
          SB4    55 
          SA6    GACC 
          SA2    GACF 
          MX6    0           STORE ZERO WORD AFTER CARD IMAGE 
          SA6    RA.CCD+8 
          BX6    X2 
 GAC8     SA5    A6-B1       BLANK FILL CARD IMAGE
          SA6    A5 
          ZR     X5,GAC8
          MX1    -1 
          IX4    X5+X1
          SA2    GACD 
          BX1    -X5*X4 
          BX4    X1*X2
          LX1    X4,B4
          IX2    X4-X1
          BX1    X4+X2
          BX2    X1*X6
          IX6    X5+X2
          SA6    A6 
          SA1    GACB 
          BX6    X1          RESTORE (X6) 
          SA5    RA.CCD      SCAN NEW CARD
          EQ     GAC1 
  
 GAC9     MESSAGE GACE       *NO CONTROL CARD TERMINATOR.*
          SA1    GACB 
          SB4    -B1         FORCE TERMINATOR CODE
          BX6    X1          RESTORE (X6) 
          EQ     GAC         RETURN 
 GAV      SPACE  4
**        GAV - GET ARGUMENT VALUE. 
*         ENTRY  (X0) = MASK -6.
*                (X5) = CURRENT WORD OF CARD IMAGE. 
*                (A0) = 10. 
*                (A5) = ADDRESS OF (X5).
*                (B3) = $ MODE. 
*                (B5) = NUMBER OF CHARACTERS REMAINING IN (X5). 
*         EXIT   (X6) = VALUE SCANNED, LEFT JUSTIFIED WITH 00 FILL. 
*                (X4) = CHARACTER FOLLOWING ARGUMENT. 
*                (B4) = CHARACTER TYPE. 
*                (X5, A5, B3, B5)  UPDATED. 
*                IF VALUE SCANNED IS *0*, (X6) IS CLEARED TO 60 ZEROS.
*                IF VALUE SCANNED IS MORE THAN 7 CHARACTERS, ABORT. 
*         USES   X1-X3, A1-A3, A6, B6.
*         CALLS  GAC. 
  
  
 GAV      PS                 RETURN EXIT
          SX6    0
          SB6    54 
 GAV1     RJ     GAC         GET ARGUMENT CHARACTER 
          NZ     B4,GAV2
          LX4    B6 
          BX6    X6+X4
          SB6    B6-6 
          NZ     B6,GAV1     LOOP 
 GAV2     MX2    42 
          BX2    -X2*X6 
          NZ     X2,ARGE     IF MORE THAN 7 CHARACTERS
          LX6    18 
          SX2    X6-1L0 
          LX6    -18
          NZ     X2,GAV      IF NOT *0* 
          MX6    0
          EQ     GAV         RETURN 
 IFP      SPACE  4
 CDB      SPACE  4,10                                                    F4810A 
**        CDB - CONVERTS DECIMAL DISPLAY CODE TO BINARY                  F4810A 
*                                                                        F4810A 
*         ENTRY  (X6) = PARAMETER LEFT JUSTIFIED ZERO FILL.              F4810A 
*         EXIT   (X2) = BINARY EQUIVALENT, MINUS IF ERROR.               F4810A 
*         USES   X - 1,2,3,4,6.                                          F4810A 
*                B - 2.                                                  F4810A 
*                A - NONE.                                               F4810A 
*                                                                        F4810A 
*         CALLS  NONE.                                                   F4810A 
                                                                         F4810A 
                                                                         F4810A 
 CDB      PS     0           ENTRY/EXIT                                  F4810A 
          MX1    42          MASK FOR UPPER 7 CHARACTERS OF PARAMETER    F4810A 
          SB2    B1+B1       (B2) = 2                                    F4810A 
          BX4    X1*X6       EXTRACT UPPER SEVEN CHARACTERS              F4810A 
          SX2    B0          CLEAR ACCUMULATOR                           F4810A 
 CDB1     MX1    -6          MASK FOR LOWER 6 BITS                       F4810A 
          LX4    6           POSITION NEXT CHARACTER                     F4810A 
          BX6    -X1*X4      GET CHARACTER                               F4810A 
          ZR     X6,CDB      IF NO MORE DIGITS                           F4810A 
          SX3    X6-1R9-1    CHECK IF ALPHANUMERIC                       F4810A 
          PL     X3,CDB2     IF NOT ALPHANUMERIC                         F4810A 
          SX3    X6-1R0      CONVERT NEW DIGIT TO BINARY                 F4810A 
          MI     X3,CDB2     IF NOT A NUMBER                             F4810A 
          LX6    X2,B2       MULTIPLY BY FOUR                            F4810A 
          IX2    X2+X6       ADD IN NUMBER                               F4810A 
          LX2    1           MULTIPLY BY TWO                             F4810A 
          IX2    X2+X3       ADD IN NEW DIGIT                            F4810A 
          EQ     CDB1        LOOP FOR NEXT DIGIT                         F4810A 
                                                                         F4810A 
 CDB2     SX2    -B1                                                     F4810A 
          EQ     CDB         RETURN                                      F4810A 
 IFP      SPACE  4                                                       F4810A 
  
  
 IFP      PS                 RETURN EXIT
          SA1    ELFN 
          BX6    X1 
          SA6    E           SET ERROR FILE NAME
  
 RM       IFEQ   CP#RM,0
  
          MX0    42          SET INPUT FET
          SA1    I
          SX5    B1 
          BX2    X0*X1
          IX6    X2+X5
          SA6    A1 
          SA1    B           SET BINARY FET 
          SX7    7
          BX2    X0*X1
          IX6    X2+X7
          ZR     X2,IFP1     IF *B=0* 
          SA6    A1 
 IFP1     SA1    O           SET OUTPUT FET 
          SX5    5
          SB7    B1+B1
          BX2    X0*X1
          SX3    A1 
          IX6    X2+X5
          ZR     X2,IFP2     IF *L=0* 
          BX7    X2+X3
          SA6    A1 
          SA7    B7          STORE LIST POINTER 
          SB7    B7+B1
          EQ     IFP3 
 IFP2     MX7    0
          SA7    CP.LISTF    CLEAR LIST FLAG
          SX7    OBUF+120B
          SA7    O+4         SET INPUT TO LARGE BUFFER AND OUTPUT SMALL 
          SA7    I+1
          SA7    A7+B1
          SA7    A7+B1
 IFP3     SA1    E           SET ERROR FILE 
          BX3    X0*X1
          SX4    A1 
          ZR     X3,IFP5     IF *O=0* 
          BX7    X2-X3
          IX6    X3+X5
          NZ     X7,IFP4     IF NOT SAME FILE AS NORMAL LISTING 
          SA7    A1          CLEAR ERROR FILE 
          EQ     IFP5 
 IFP4     BX7    X3+X4
          SA6    A1 
          SA7    B7          STORE LIST POINTER 
          SB7    B7+B1
          SA1    O
          NZ     X1,IFP5     IF NORMAL OUTPUT FILE
          SA2    A1+B1       USE NORMAL OUTPUT BUFFER FOR ERROR FILE
          SA3    A2+B1
          BX6    X2 
          LX7    X3 
          SA6    E+1
          SA7    A6+B1
          SA7    A7+B1
          SA2    O+4
          BX6    X2 
          SA6    E+4
 IFP5     MX7    0           TERMINATE LIST POINTER LIST
          SA7    B7 
          EQ     IFP         RETURN 
  
 RM       ELSE
  
          SA1    O
          ZR     X1,IFP1     IF *L=0* 
          SA1    E           CHECK OUTPUT FILE NAMES
          SA2    O
          BX7    X1-X2
          NZ     X7,IFP      IF NOT SAME FILE 
          SA7    A1          SUPPRESS ERROR LISTING 
          EQ     IFP
 IFP1     MX7    0
          SA7    CP.LISTF    CLEAR LIST FLAG
          EQ     IFP         RETURN 
  
 RM       ENDIF 
 LOV      SPACE  4
**        LOV - LOAD OVERLAY. 
  
  
 LOV      IFNE   OVERLAY,0
  
 LOV      PS                 RETURN EXIT
  
          IF     -DEF,SCOPE2,3
 LOV1     RECALL
          SA4    RA.LDR      WAIT UNTIL LOADER IS FINISHED
          ZR     X4,LOV1
  
          SA4    LOVA+1 
          LX4    59-36
          PL     X4,LOV      IF LOADED
          MESSAGE LOVB,,R 
          ABORT  ,NODUMP
  
 LIB      IFC    EQ, "CP.OVLIB"                                         S028 224
 LOVA     DATA   0L"CP.NAME"       LOAD OVERLAY FROM GLOBAL LIBRARY SET 
          VFD    12/0100B,12/0140B,18/ENDA+1,18/CP.ORG                   F4810B 
 LIB      ELSE
 LOVA     DATA   0L"CP.OVLIB"      LOAD OVERLAY FROM SPECIFIED LIBRARY  S028 226
          VFD    12/0100B,12/2140B,18/ENDA+1,18/CP.ORG                   F4810B 
                                                                         F4810B 
 LIB      ENDIF 
          DATA   0L"CP.NAME"
  
 LOVB     DATA   C* CANT LOAD "CP.NAME"*
  
 LOV      ENDIF 
 SFV      SPACE  4
**        SFV - SET *F VALUE. 
*         EXIT TO ARGE ON BAD *F* ARGUMENT. 
  
  
 SFV      PS                 RETURN EXIT
          SA1    FVAL 
          ZR     X1,SFV      IF *F=0* 
          LX1    6
          SX6    X1-1R0 
          PL     X6,SFV2     IF *F=NUMBER*
          SX6    NFNAME 
          LX1    -6 
 SFV1     SA2    FNAME-1+X6  SEARCH TABLE OF PERMITTED *F=NAME* OPTIONS 
          SX6    X6-1 
          BX2    X1-X2
          ZR     X2,SFV2     IF FOUND 
          NZ     X6,SFV1     IF NOT END OF TALBE
          SX6    1RF
          LX6    -6 
          SA6    ARGM+3      *BAD CONTROL CARD ARGUMENT - F*
          EQ     ARGE 
 SFV2     SA1    CP.BATCH    STORE VALUE OF *F SPECIAL SYMBOL 
          BX6    X1+X6
          SA6    A1 
          EQ     SFV         RETURN 
**        SSP - START *SPY*.
*         EXIT TO ARGE ON BAD *W* ARGUMENT. 
  
  
 SPY      IFNE   SPY,0
  
 SSP      PS                 RETURN EXIT
          SA1    SPYPAR 
          MX0    -6 
          BX7    X7-X7
          ZR     X1,SSP      IF NO *W* ARGUMENT 
          SB7    7
 SSP1     LX1    6           CONVERT OCTAL TO BINARY
          BX3    -X0*X1 
          SB6    X3-1R0 
          MI     B6,SSP2     IF CHARACTER LESS THAN *0* 
          GT     B6,B7,SSP4  IF GREATER THAN *7*
          LX7    3
          SX2    B6 
          BX1    X1-X3
          IX7    X7+X2
          EQ     SSP1        LOOP 
 SSP2     NZ     X1,SSP4     IF NOT END OF ARGUMENT 
          SB6    20B
          SB7    X7 
          EQ     B7,B6,SSP3  IF *W=20*
          SB6    B6+B6
          EQ     B7,B6,SSP3  IF *W=40*
          SX7    100B        ASSUME *W=100* 
 SSP3     SX6    B1 
          SX1    ENDB+77B    FORM *SPY* PARAMETERS -
          LX7    24 
          AX1    6           12/ BINWIDTH,
          BX6    X7+X6       12/ 0, 
          LX6    12          12/ FIRST/100B,
          BX7    X6+X1       12/ LIMIT/100B,
          LX7    12          12/ 0
          SA7    A1 
          SYSTEM SPY,RCL,A7 
          EQ     SSP
  
 SSP4     SX6    1RW         ERROR EXIT 
          LX6    -6 
          SA6    ARGM+3      *BAD CONTROL CARD ARGUMENT - W*
          EQ     ARGE 
  
 SPY      ENDIF 
 TFL      SPACE  4
**        TFL - TEST FIELD LENGTH AND START LOADING OVERLAY.
  
  
 TFL2     BSS    0
  
 OVL      IFNE   OVERLAY,0
          SA1    RA.LWP 
          LX1    59-18
          MI     X1,TFL3     IF LOADED FROM A LIBRARY 
          SA1    RA.PGN 
          MX0    42 
          BX6    X0*X1
          SA6    LOVA        STORE FILE NAME IN LOADER CALL 
          SA1    A6+B1
          MX0    12 
          SX2    2040B       THREE-WORD CALL, LOAD OVERLAY FROM FILE
          LX0    47-59
          LX2    36 
          BX6    -X0*X1 
          BX6    X6+X2
          SA6    A1 
 TFL3     MX7    0           CLEAR LOADER REPLY WORD
          SA7    RA.LDR 
          LOADREQ LOVA       START LOADING OVERLAY
 OVL      ENDIF 
  
 DEBUG    IFNE   DEBUG
  
          MEMORY ECS,TFLB,R  FIND OUT WHAT IS ECS/LCM FIELD LENGTH
          SA1    TFLB 
          AX1    30 
          BX7    X1 
          SA7    CP.AFLL     SET LCM FIELD LENGTH WORDS 
          SA7    CP.NFLL
          EQ     TFL         RETURN 
  
 TFLB     DATA   0
  
 DEBUG    ENDIF 
  
 TFL      PS                 RETURN EXIT
          SA1    CP.NFLS     TEST FIELD LENGTH
          SX6    X1-MIN.FL
          PL     X6,TFL2     IF ENOUGH TO LOAD OVERLAY                  S028 229
          MEMORY CM,TFLBB,RECALL,,NABORT   REQUEST MIN.FL 
          SA2    TFLBB       GET RETURNED FL FROM REQUEST/REPLY WORD
          AX2    30-0                                                    F4810B 
          SX3    X2-MIN.FL                                               F4810B 
          BX6    X2                                                      F4810B 
          SA6    CP.NFLS     RESET FIELD LENGTHS                         F4810B 
          SA6    CP.AFLS                                                 F4810B 
          PL     X3,TFL2     IF ENOUGH FL NOW, GO START LOADING OVL      F4810B 
          SX2    MIN.FL+77B  ELSE, SEND ERROR MESSAGE AND ABORT          F4810B 
          SA1    TFLA+2 
          BX6    X1          WORD OF MESSAGE WHICH WILL CONTAIN FL
          MX0    -6 
          BX3    X0*X2       ROUND UP TO A MULTIPLE OF 100B 
          SB7    B0 
          MX0    -3 
 TFL1     BX4    -X0*X3      CONVERT TO OCTAL 
          LX5    X4,B7
          SB7    B7+6 
          AX3    3
          IX6    X6+X5       OR IN DIGIT
          NZ     X3,TFL1
          SA6    TFLA+2      STORE IN MESSAGE                            F4810B 
          MESSAGE TFLA,,R 
          ABORT  ,NODUMP
  
 TFLA     DIS    ,*  COMPASS NEEDS AT LEAST 00000B SCM.*
 TFLBB    VFD    30/MIN.FL,30/0    MEMORY REQUEST/REPLY WORD
                                                                        S028 246
 RM       ENDIF                                                         S028 247
**        END OF (0,0) OVERLAY. 
  
  
 R        ERRMI  CP.ORG-*    INITIALIZATION CODE IS TOO LARGE 
          TITLE  MAIN PROGRAM.
          IFEQ   OVERLAY,0   SEGMENT CONTROL
  
          ORG    CP.ORG+1 
          IDENT              MAIN PROGRAM.
  
          ELSE
  
          IDENT  "CP.NAME",CP.ORG+1,CMP           MAIN PROGRAM
          COMMENT   CYBER 70/ MODEL "MODEL" 
          COMMENT   COMPREHENSIVE ASSEMBLER PROGRAM VERSION "VERSION".
          ORG    CP.ORG+1 
  
          ENDIF 
  
          IFNE   DEBUG,0,1   PATCH SPACE
          BSSZ   100B 
          TITLE  BATCH CONTROL CELLS. 
**        FET/FIT EQUATES FOR INPUT/OUTPUT/LGO FILES. 
  
  
 RM       IFEQ   CP#RM,0
  
 I        EQU    CP.IFET
 O        EQU    CP.OFET
 B        EQU    CP.BFET
 E        EQU    CP.EFET
  
 RM       ELSE
  
 I        EQU    CP.IFIT
 O        EQU    CP.OFIT
 B        EQU    CP.BFIT
 E        EQU    CP.EFIT
  
 RM       ENDIF 
 SCRATCH  SPACE  4
**        FET/FIT FOR SCRATCH FILE. 
  
  
 SCR      FET    ZZZZZRL,,SBUFL,7 
  
 RM       IFEQ   CP#RM,0
 S        EQU    SCR
 RM       ELSE
 S        FILE   LFN=ZZZZZRL,FO=SQ,BT=,RT=U,MRL=2550,CM=NO
          BSSZ   SCR+40B-*
 RM       ENDIF 
 XTEXT    SPACE  4
**        FET/FIT FOR XTEXT FILES.
  
  
 XTF      FET    ,,BBUFL,3,4000B
  
 RM       IFEQ   CP#RM,0
 X        EQU    XTF
 RM       ELSE
 X        FILE   FO=SQ,BT=,RT=W,MRL=5120,CM=NO,WSA=VALUES,PD=INPUT
          BSSZ   XTF+40B-*
 RM       ENDIF 
 REF      SPACE  4
**        FET/FIT FOR CROSS-REFERENCE SCRATCH FILE. 
  
  
 REF      FET    ZZZZZRM,,RBUFL,7 
  
 RM       IFEQ   CP#RM,0
 R        EQU    REF
 RM       ELSE
 R        FILE   LFN=ZZZZZRM,FO=SQ,BT=C,RT=S,CM=NO
          BSSZ   REF+40B-*
 RM       ENDIF 
  
          IFEQ   CP#RM,0,1
 T        FET    ZZZZZRM,TBUF,RBUFL,7 
  
          IFEQ   OVERLAY,0,2
          IFEQ   CP#RM,0,1
 C        FET    ZZZZZRM,CBUF,BUCKET-CBUF,7 
 SNAPPER  SPACE  4
**        FET/FIT FOR DEBUG OUTPUT FILE.
  
  
 DEBUG    IFNE   DEBUG
  
 DBG      FET    SNAPPER,,DBUFL,5 
  
 RM       IFEQ   CP#RM,0
 D        EQU    DBG
 RM       ELSE
 D        FILE   LFN=SNAPPER,FO=SQ,BT=,RT=W,MRL=137,OF=N,CF=N,PD=OUTPUT 
          BSSZ   DBG+40B-*
 RM       ENDIF 
  
 DEBUG    ENDIF 
 TABLE    SPACE  4
**        ASSEMBLER CONTROL FLAGS.
  
  
 LSYSMAC  DATA   0           LENGTH OF SYSTEMS MACROS 
 LOCORE   VFD    60/BUCKET   FWA AVAILABLE STORAGE
 SIZCORE  DATA   0           SIZE OF AVAILABLE CORE 
 MAXCORE  CON    MIN.FL      MAXIMUM SCM USED DURING CURRENT ASSEMBLY 
 BLCM     DATA   0           BATCH MAXIMUM ECS/LCM USED                 S028 274
 FLLF     DATA   1           FIXED ECS/LCM FIELD LENGTH FLAG            S028 275
 LCMMIC   DATA   0           LCM SYSMIC POINTER 
 LCMSYM   DATA   0           LCM SSYMS  POINTER 
 LCMOPC   DATA   0           LCM OPTAB  POINTER 
 LCMMAC   DATA   0           LCM MACDEF POINTER 
 LCMSYS   DATA   200B        LWA+1 OF SYSTEM MACROS IN LCM              S028 277
 LCMPGM   DATA   200B        LWA+1 OF PROGRAM MACROS IN LCM 
 LCMEND   DATA   200B        LCM AVAILABLE SPACE POINTER
 LSTTHOU  DATA   0           =1 USE LAST 1000B WORDS (SET IN RFL,DFL) 
 MAXFL    VFD    30/-1,30/0  MAXIMUM FL AVAILABLE TO JOB                 F4810B 
 MIDFLN   CON    MIDFL       FL AT WHICH TABLES DUMPED TO FILES          F4810B 
  
 RM       IFEQ   CP#RM,7
 O.SYMTAB DATA   0           LCM SYMBOL TABLE ORIGIN
 L.SYMTAB DATA   0           LCM SYMBOL TABLE LENGTH
 LCMB     BSSZ   100B        LCM MOVE/CLEAR BUFFER
 RM       ELSE
 LCMB     BSS    0
 RM       ENDIF 
  
 EOFINP   DATA   0           FLAG FOR END OF RECORD ON INPUT
 FMODE    DATA   0           *F VALUE (COMPASS = 0, RUN = 1, FTN = 2) 
 XLIST    DATA   0           EXTERNAL LIST CONTROL
 FTNE     BSSZ   2           FIRST WORD OF EFET AND BUFFER LENGTH FROM F
 SHORTEJ  DATA   1L-         SHORT EJECT CARRIAGE CONTROL CHARACTER 
 LONGEJ   DATA   1L1         LONG EJECT CARRIAGE CONTROL CHARACTER
 COMPPD   DATA   0           SAVES COMPILER VALUE OF CP.PD               F4810A 
 COMPPS   DATA   0           SAVES COMPILER VALUE OF CP.PS               F4810A 
 COMPPW   DATA   0           SAVES COMPILER VALUE OF CP.PW
 NEJF     CON    5           SET TO ZERO IF *N* ARGUMENT SPECIFIED       F4810A 
 PSIZE    DATA   0           EJECT PAGE SIZE CP.PS+5(0 IF *BL* NOT SPEC)
 FRSTLIN  DATA   0           0   PRINT DENSITY NOT TO BE CHANGED         F4810A 
*                            NZ  CHAR. TO BE PRINTED TO CHANGE PRINT DEN F4810A 
 LASTLIN  DATA   1HS         STORES CHAR. TO RESET PRINTER TO SIX.
 BTIME    DATA   0           BATCH CPU TIME 
 TLINE    DATA   H* CDC TYPE CPU ASSEMBLY*
 FLAGS    SPACE  4
**        COMMON CELLS AND FLAGS. 
  
  
 CLP1     BSS    0
 LOCSYM   DATA   0           LOCATION SYMBOL
 IOP      DATA   0           OP CODE SYMBOL (MUST FOLLOW LOCSYM)
 ORGCTR   DATA   0,0         ORIGIN AND RELOCATION
 LOCCTR   DATA   0,0         LOCATION COUNTER AND RELOCATION
 POSCTR   DATA   0           INTERNAL POSITION COUNTER
 CLF      DATA   0           CONDITIONAL LOAD FLAG (BIT 59) 
 QVAL     DATA   0,0         SYMBOL QUAL VALUE
 MACHINE  DATA   0           0 FOR CP, 1 FOR PP 
 MTYPE    DATA   0           OBJECT PROCESSOR TYPE (0=ANY,1=6000,2=7000)
 PPTYPE   DATA   0           TYPE OF PP ASSEMBLY -
                              -3 IF 180 PPU 
                              -2 IF MCU 
                              -1 IF BCU 
                               0 IF 6XXX
                               1 IF 7600
 RMODE    DATA   0           REVERSED ADDRESS MODE FOR INTEL 8080 
 IDNAM    DATA   0           NAME FROM IDENT CARD 
 SYNAME   DATA   0           SYSTEXT GENERATION NAME
 INVENT   DATA   0R'?000000  8-CHAR INVENTED SYMBOL NAME
 LWORD    DATA   0           WORD LENGTH -
                               8 FOR MCU
                              12 FOR PPU (6XXX OR 7600) 
                              16 FOR BCU OR 180 
                              60 FOR CPU
 VWORD    DATA   0           VFD AND CON ASSEMBLY MODE -
                              0 - NORMAL ASSEMBLY 
                              4 - FOR 180 PPU ASSEMBLIES ONLY, USE ONLY 
                                  THE LOWER 12 BITS FOR *CON* AND *VFD* 
 WWORD    DATA   0           USED BY *CON* AND *VFD*
 PPMEMSZ  DATA   12          MEMORY SIZE FOR PP ASSEMBLIES (FIELD SIZE) 
 NCHARS   DATA   0           NUMBER OF CHARACTERS PER WORD (2 OR 10)
 ABSFG    DATA   0           ABSOLUTE ASSEMBLY FLAG 
 PPJUMP   DATA   0           PP JUMP FLAG 
 NOLFG    DATA   0           NO LABEL FLAG
 NBASE    DATA   10          RADIX FOR UNSPECIFIED CONSTANTS
 MBASE    DATA   10          RADIX FOR SPECIAL CONSTANTS
 ABASE    DATA   0           BASE TYPE
 NFOUP    DATA   0           FORCE NEXT UPPER 
 IFCDGP   DATA   0           FIRST CARD GROUP FLAG
 TITFG    DATA   0           TITLE FLAG 
 CCOL     VFD    60/COMCOL   COMMENT COLUMN 
 COL      BSS    2           COLUMN NUMBERS-1 OFOP, ADDR
 COLUMN   DATA   0           CURRENT COLUMN NUMBER
 CHAR     DATA   0           CURRENT CHARACTER
 INTERIO  DATA   0           INTERMEDIATE I/O FLAG
 ERCNT    DATA   0           ASSEMBLY ERROR COUNT 
 WECNT    DATA   0           WARNING ERROR COUNT
 CT       DATA   0,0         CHARACTER TYPE 
 UI       DATA   0,0,0       USETAB INDEX 
 LI       DATA   0,0         LITAB INDEX
 EI       DATA   0,0         EPTAB INDEX
 DI       DATA   0,0         DEFAULT SYMBOL INDEX 
 SI       DATA   0           SEGTAB INDEX 
 LCM      DATA   0           LCM LENGTH 
 LLB      DATA   0           LOCAL LCM BLOCK RELOCATION (BITS 32-24)
 NBLOCKS  DATA   0           COUNT OF COMMON BLOCKS 
 STCNT    DATA   0           STATEMENT COUNT
 SYMCNT   DATA   0           SYMBOL COUNT 
 ALCM     DATA   0           MAX ECS/LCM USED DURING CURRENT ASSEMBLY   S028 279
 ATIME    DATA   0           ASSEMBLY TIME
 REQC     DATA   0           R= SWITCH
 SSTCNT   DATA   0           NUMBER OF SYSTEM SYMBOLS DEFINED 
 XR       CON    XRDV        XREF TYPE (-1=PAGE/LINE, 0=ADDRESS, 1=BOTH)
 CRLF     DATA   0           RECURSION LIMIT EXCEEDED FLAG              S004   7
 IFDF     DATA   0           IF DEF/EXT/REG FLAG - TO AVOID U-ERRORS
 LCLP1    EQU    *-CLP1 
  
  
 TITBUF   DATA   1H1         TEXT OF TITLE
 TITBUFL  EQU    6
          BSS    TITBUFL
          DIS    2,COMPASS "VERSION".                                   S028 281
 DATE     BSS    1
 TIME     BSS    1
          DATA   4APAGE 
 PAGENO   BSS    1
 PGCNT    DATA   0           PAGE COUNT IN CODED FORM 
 EPCNT    DATA   0           ERROR FILE PAGE COUNT
 BLANKS   LIT    1H 
 ASMJ     DATA   20H ASSEMBLY ABORTED - 
 ASMK     DATA   12CPASS 1 TABLE
 ASML     DATA   10H OVERFLOW 
 ASMM     DATA   20CASSEMBLING XXXXXXX
 PRFX     BSS    0
 DPBA     DATA   77000016BS36 PRELIMINARY BINARY BUFFER 
          DATA   0L*******
          DIS    1,"DATE" 
          DIS    1,"TIME" 
          DIS    1,"OS.ID"
          DIS    2,COMPASS"PVERSION"
          DIS    1, 
 PRFXC    BSSZ   7           USER COMMENTS
 LPRFX    EQU    *-DPBA 
 OVLHDR   DATA   5000BS48    OVERLAY HEADER WORD
 ASC6T8   EQU    40B         FACTOR TO CONVERT 6-BIT TO 8-BIT ASCII 
 PCC      DATA   0           PRFX TABLE CHARACTER COUNT 
 TARGET   DATA   2R          TARGET OBJECT PROCESSOR
 VALID    DATA   0           VALID OBJECT PROCESSOR 
 HTYPE    DATA   9R          HARDWARE DEPENDENCIES
 EXVAL    DATA   0           EXPRESSION VALUE          *KINDLY
 EXREL    DATA   0           EXPRESSION RELOCATION     *MAINTAIN
 EXEXT    DATA   0           EXPRESSION EXTERNAL VALUE *THIS
 EXREG    DATA   0           EXPRESSION REGISTER       *ORDER 
 PASS     DATA   0           PASS NUMBER (1 OR 2) 
 LASTCOL  DATA   0           LAST COLUMN+1 OF STATEMENT 
 PPBYT    DATA   4           BYTES PER PP WORD, 4 OR 6
 SQLGN    DATA   0           LENGTH + FLAG OF SQUEEZED IMAGE
 BADLOC   DATA   0           BAD LOCATION FIELD FLAG
 LPGM     DATA   0           PROGRAM LENGTH AS COMPUTED AT END TIME 
 ENDP     DATA   0           VALUE OF END CARD SYMBOL 
 EDITFG   DATA   0           STATEMENT REQUIRES EDITING (IF NEG)
 PSIM     CON    36074176004B   PERIPHERAL STORE INSTRUCTION MASK 
 PSIM2    CON    0              PERIPHERAL STORE MASK FOR + ERROR CHECK 
          CON    36000176004B 
          IFNE   CP#RM,0,3
 T6RM1    DATA   0           6RM TEMPORARY 1
 T6RM2    DATA   0           6RM TEMPORARY 2
 EOD      EQU    #EOI#+#EOP#+#EOS#      END OF DATA MASK
 OPADS    BSS    7           OPERATION CODE DECOMPOSITION TEMPS 
 K.TLDS   DATA   0           LDSET CONTROL WORD POINTER 
 ERROR    SPACE  4
**        ERROR - CREATE ERROR FLAGS. 
*LET      ERROR  MSG
*         ENTRY  (LET) = ERROR LETTER.
*                (MSG) = ERROR MESSAGE. 
  
                                                                        S028 285
          PURGMAC ERROR                                                 S028 286
  
          MACRO  ERROR,A,B
          IFC    LT,*A*0* 
 ;AERR    CON    0
          ELSE   4
          IFC    LT,*A*+*,2 
 W;AERR   CON    0
          SKIP   1
          CON    0
 ERRLETS  RMT 
          CON    1R;A 
          RMT 
 ERDIR    RMT 
          DIS    5,;B 
          RMT 
          ENDM
 FLAGS    SPACE  4
**        STATEMENT FLAGS SAVED ON INTERMEDIATE.
  
  
 OPTYPE   DATA   0           OP CODE TABLE ENTRY
 FLAG     DATA   0           A GENERAL 60-BIT NUMBER
 IND      DATA   0           INDICATOR WORD FOR INTERMEDIATE FILE 
 CCT      DATA   0           CARD COUNT FOR THIS STATEMENT
 NOAS     DATA   0           NO-ASSEMBLY FLAG 
 TXTFLG   DATA   0           TEXT DEFINITION FLAG 
 MICFLG   DATA   0           MICRO/CONCATENATION SUBSTITUTION FLAG
 MACHFLG  DATA   0           O ERROR INDICATED *MACHINE* VIOLATION
  
*         MODE INDICATORS.
  
 SYSFLG   DATA   0           SYSTEMS MACRO FLAG 
 MACFLG   DATA   0           PROGRAMMER MACRO FLAG
 ECHFLG   DATA   0           DUPLICATION FLAG 
 RMTFLG   DATA   0           REMOTE GENERATED FLAG
 LIBFLG   DATA   0           LIBRARY SOURCE FLAG
 LFLG     EQU    *-SYSFLG 
  
*         ERROR FLAGS.
  
 ERFLAGS  BSS    0
 L        ERROR  (LOCATION FIELD BAD.)
 O        ERROR  (OPERATION FIELD BAD.) 
 A        ERROR  (ADDRESS FIELD BAD.) 
 D        ERROR  (DOUBLY DEFINED SYMBOL.  THE FIRST DEFINITION HOLDS.)
 E        ERROR  (ECHO, DUP, RMT, OR MACRO ILLEGALLY NESTED.) 
 R        ERROR  (DATA ORIGIN OUTSIDE BLOCK OR IN BLANK COMMON.)
 F        ERROR  (NUMBER OF ENTRIES EXCEEDS PERMISSIBLE AMOUNT.)
 U        ERROR  (UNDEFINED SYMBOL.  VALUE ASSUMED 0.)
 V        ERROR  (BIT COUNT ERROR ON VFD (MUST BE 0@COUNT@60).) 
 P        ERROR  (CONSULT LISTINGS FOR REASON BEHIND P-ERROR.)
 N        ERROR  (NEGATIVE RELOCATION ON ENTRY POINT.)
 NFERS    EQU    *-ERFLAGS   COUNT OF FATAL ERROR FLAGS 
  
*         NON-FATAL ERROR FLAGS.
  
 1        ERROR  (LOCATION SYMBOL BAD.  SYMBOL NOT DEFINED.)
 2        ERROR  (ADDRESS ERROR ON SYMBOL DEFINITION.)
 3        ERROR  (DUPLICATE MACRO DEFINITION.  NEW ONE OVERRIDES.)
 4        ERROR  (BAD FORMAL PARAMETER NAME IGNORED.) 
 5        ERROR  (CPU OPERATION SYNTAX INCORRECTLY SPECIFIED.)
 6        ERROR  (LOCATION FIELD MEANINGLESS.)
 7        ERROR  (ADDRESS VALUE EXCEEDS FIELD SIZE, RESULT TRUNCATED.)
 8        ERROR  (MISSING OR EXTRA ADDRESS SUBFIELD.) 
 9        ERROR  (MICRO SUBSTITUTION ERROR.  NO SUBSTITUTION.)
 WD45ERR  BSS    0
 +        ERROR  (STORE AT NEXT INSTR+1 FOR PIPELINED SYSTEM.)
 LEFLG    EQU    *-ERFLAGS   COUNT OF FATAL AND NON-FATAL FLAGS 
  
*         TOTAL ERROR FLAG. 
  
 EFLG     DATA   0           TOTAL ERROR FLAG 
 LERFLAGS EQU    *-ERFLAGS   TOTAL COUNT OF ERROR FLAGS 
 LISTOPS  SPACE  4
*         LIST CONTROL FLAGS. 
  
  
          MACRO  LISTOP,LET,VALUE 
 LET      VFD    12/2R_LET+2000B-1LL,48/VALUE 
          VFD    60/VALUE 
 LIST.    SET    LIST.*2
          IFNE   VALUE,,1 
 LIST.    SET    LIST.+1
          ENDM
  
  
 LIST.    SET    0
 LISTOPS  BSS    0
 LA       LISTOP 0           SUBSTITUTED MICRO/CONCAT LINES 
 LB       LISTOP 1           BINARY CONTROL CARDS 
 LC       LISTOP 0           CONTROL CARDS
 LD       LISTOP 0           DETAIL OF GENERATED CODE 
 LE       LISTOP 0           DUPLICATIONS 
 LF       LISTOP 0           IF-SKIPPED LINES 
 LG       LISTOP 0           GENERATED CODE 
 LL       LISTOP 1           MASTER LIST CONTROL
 LM       LISTOP 0           MACRO EXPANSIONS 
 LN       LISTOP 1           UNREFERENCED NON-SST SYMBOLS 
 LR       LISTOP 1           ACCUMULATE AND LIST REFERENCES 
 LS       LISTOP 0           SYSTEM MACRO EXPANSIONS
 LT       LISTOP 0           UNREFERENCED SST SYMBOLS 
 LX       LISTOP 0           XTEXT SOURCE CARDS 
 LLISTOPS EQU    *-LISTOPS
 NLISTOPS EQU    LLISTOPS/2 
 TABLES   TITLE  TABLE ALLOCATION.
**        MANAGED TABLES ARE USED TO CONTAIN ALL VARIABLE COMPASS DATA. 
*         THE TABLES ARE CONTROLED BY 2 POINTERS, O.TNAM AND L.TNAM.
*         (O.TNAM) = ORIGIN OF TABLE *TNAM*.
*         (L.TNAM) = LENGTH OF TABLE *TNAM*.
*         THE TABLES ARE MANAGED BY ROUTINE *ALC*.
  
  
 ORIGINS  BSS    0           TABLE OF ORIGIN ADDRESSES
 INTER    SPACE  4
**        INTER - INTERMEDIATE FILE.
*         INTER IS USED TO CONTAIN THE INTERMEDIATE FILE IF IT
*         WILL FIT IN CORE. 
* 
*         ENTRY = 3 WORDS, SEQUENCE NUMBERS, AND COMPRESSED TEXT. 
* 
*         WORD 1. 
* 
*         BITS   59-48       A COPY OF BITS 59-48 OF OPTYPE.  THIS
*                            IS THE SAME AS THE OPERATION CODE TABLE
*                            ENTRY. 
*         BIT    47          UNUSED AND ZERO. 
*         BITS   46-45       SEQ FLAG.  IF THIS IS 00, THEN THE SEQUENCE
*                            FIELDS OF THIS STATEMENT ARE BLANK AND ARE 
*                            NOT RECORDED ON THE INTERMEDIATE FILE. 
*                            IF THIS IS 01, THE SEQUENCE FIELDS ARE IN
*                            MODIFY FORMAT, ONE WORD PER CARD IMAGE.
*                            IF THIS IS 10, THE SEQUENCE FIELD IS TWO 
*                            WORDS AND IS THE SAME FOR ALL CARDS IN THE 
*                            STATEMENT (E.G. MACRO GENERATED), SO THE 
*                            TWO-WORD SEQUENCE FIELD IS RECORDED ONLY 
*                            ONCE ON THE INTERMEDIATE FILE. 
*                            IF THIS IS 11, THE INTERMEDIATE FILE 
*                            CONTAINS A TWO-WORD SEQUENCE FIELD FOR 
*                            EACH CARD IN THE STATEMENT.
*         BIT    44          FLAG FLAG.  IF THIS IS 0, THEN THE FLAG
*                            WORD IS ZERO, AND IS NOT INCLUDED ON 
*                            THE INTERMEDIATE FILE.  THE FLAG 
*                            WORD IS NON-ZERO ONLY FOR SOME PSEUDO
*                            INSTRUCTIONS.
*         BIT    43          IND FLAG.  IF THIS IS 0, THEN THE IND
*                            WORD IS ZERO, AND IS NOT INCLUDED ON 
*                            THE INTERMEDIATE FILE.  THE IND WORD 
*                            CONTAINS ERROR FLAGS AND OTHER INDICATORS. 
*         BIT    42          UNUSED.
*         BITS   41-34       LENGTH OF INTERMEDIATE RECORD. 
*         BITS   33-30       CCT - CARD COUNT, I.E., NUMBER OF CARDS
*                            WHICH COMPRISE THIS STATEMENT. 
*         BITS   29-00       COPY OF BITS 29-00 OF OPTYPE.
* 
* 
*         WORD 2 - PRESENT EXPLICITLY IF THE IND BIT IS 1 IN WORD 1.
*         IF IT IS 0, THEN WORD 2 CAN BE ASSUMED TO HAVE A VALUE ZERO.
* 
*         BITS   59-30       THESE CONTAIN A RECORD OF THE INDICATORS 
*                            WHICH WERE SET.  A 1-BIT INDICATES 
*                            THAT THE CORRESPONDING INDICATOR WAS ON. 
*         BITS   29-00       THESE CONTAIN A RECORD OF THE ERROR FLAGS
*                            WHICH WERE SET.  A 1-BIT INDICATES THAT
*                            AN ERROR FLAG WAS ON.  THE EXACT ORDER 
*                            OF THESE ERROR BITS DEPENDS UPON THE 
*                            ORDER IN WHICH THE ERROR ARE LISTED
*                            IN THE ERROR LIST. 
* 
* 
*         WORD 3 - PRESENT EXPLICITLY IF FLAG = 1 IN WORD 1.  IF
*         IT IS 0, THEN WORD 3 CAN BE ASSUMED TO BE ZERO. 
* 
*         BITS   59-00       CONTENTS OF FLAG.
* 
* 
*         WORDS 4-N - SEQUENCE NUMBER FIELD IF SEQ IN WORD 1 IS NOT 00. 
*         THE LENGTH OF THIS ENTRY DEPENDS ON THE VALUE OF SEQ AS 
*         FOLLOWS.
*                       SEQ = 00    0 WORDS.
*                       SEQ = 01    (CCT) WORDS.
*                       SEQ = 10    2 WORDS.
*                       SEQ = 11    2*(CCT) WORDS.
* 
*         WORD 4 - IF SEQ = 01 (MODIFY *A* MODE). 
* 
*         BITS   59-18       IDENTIFIER NAME LEFT JUSTIFIED WITH
*                            ZERO FILL. 
*         BITS   17-00       SEQUENCE NUMBER IN BINARY. 
* 
*         WORD 4 - IF SEQ = 10 OR 11. 
* 
*         BITS   59-48       ZERO.
*         BITS   47-00       COLUMNS 73-80 OF CARD IMAGE. 
* 
*         WORD 5 - IF SEQ = 10 OR 11. 
* 
*         BITS   59-00       COLUMNS 81-90 OF CARD IMAGE. 
* 
* 
*         WORDS N-M - COMPRESSED CARD TEXT TERMINATED WITH 12-BITS
*         OF ZERO.
  
  
 INTER    TABLE 
 OPTAB    SPACE  4
**        OPTAB - OPERATION CODE TABLE. 
*         CONTAINS THE NAME AND INFORMATION ABOUT EVERY OPERATION 
*         CODE. 
* 
*         ENTRY = 2 WORDS.
* 
*         WORD 1 (PPU, PSEUDO, MACRO, OR MACROE)
* 
*         BITS   59-48       LINK FIELD FOR HASHING.
*         BITS   47-00       OPERATION NAME RIGHT JUSTIFIED.
* 
* 
*         WORD 1 (CENTRAL PROCESSOR OR OPDEF) 
* 
*         BITS   59-48       LINK FIELD FOR HASHING.
*         BITS   47-36       2-CHARACTER MNEMONIC.
*         BITS   35-28       N1 
*         BITS   27-20       N2 
*         BITS   21-12       N3 
*         BITS   11-00       0055 
* 
*         WHERE N1, N2, AND N3 ARE -
* 
*         BIT    7           LEADING SIGN 
*                            0 - PLUS 
*                            1 - MINUS
*         BITS   6-5         REGISTER NAME. 
*                            0 - BLANK
*                            1 - A
*                            2 - B
*                            3 - X
*         BITS   4-3         OPERATOR.
*                            0 - BLANK OR PLUS (+)
*                            1 - MINUS (-)
*                            2 - MULITPLY (*) 
*                            3 - DIVIDE (/) 
*         BITS   2-1         REGISTER NAME. 
*                            0 - BLANK
*                            1 - A
*                            2 - B
*                            3 - X
*         BIT    0           CONSTANT (Q-FIELD) 
* 
* 
*         WORD 2. (CPU) 
* 
*         BITS   59-57       0
*         BITS   56-48       VALUE - UPPER 9 BITS OF OPCODE.
*         BIT    47          PROGRAM DEFINED FLAG.
*         BITS   46-33       UNUSED.
*         BITS   32-30       MACHINE (0=ALL, 1=6000-ONLY, 2=7000-ONLY,
*                                     3=6000/7000, 4=V-ONLY, 5=6000/V,
*                                     6=7000/V) 
*         BIT    29          FORCE UPPER AFTER INSTRUCTION. 
*         BIT    28          FORCE UPPER BEFORE INSTRUCTION.
*         BIT    27          30-BIT INSTRUCTION.
*         BITS   26-24       SOURCE OF I-FIELD. 
*         BITS   23-21       SOURCE OF J-FIELD. 
*         BITS   20-18       SOURCE OF K-FIELD. 
*         BITS   17-00       UNUSED.
* 
*         THE SOURCE OF A REGISTER NUMBER FIELD IS SPECIFIED BY ONE 
*         OF THE FOLLOWING CODES. 
* 
*                1    OPCODE FIELD. 
*                2    SECOND OR ONLY ADDRESS FIELD REGISTER.
*                3    FIRST OF TWO ADDRESS FIELD REGISTERS. 
* 
* 
*         WORD 2. (PPU) 
* 
*         BITS   59-57       1
*         BITS   56-48       UNUSED.
*         BIT    47          PROGRAM DEFINED FLAG.
*         BITS   46-32       UNUSED.
*         BITS   31-30       MACHINE (0=BOTH, 1=6000-ONLY, 2=7000-ONLY).
*         BITS   29-27       CTL. 
*                            0 - UNUSED.
*                            1 - 24-BIT INSTRUCTION WITH 12-BIT 
*                                ADDRESS AND NO INDEXING. 
*                            2 - 12-BIT INSTRUCTION WITH SIGNED 
*                                RELATIVE OR ABSOLUTE ADDRESS.
*                            3 - 24-BIT INSTRUCTION WITH 18-BIT 
*                                ADDRESS. 
*                            4 - 12-BIT INSTRUCTION WITH 6-BIT
*                                ADDRESS. 
*                            5 - 24-BIT INSTRUCTION WITH 12-BIT 
*                                ADDRESS AND OPTIONAL INDEXING. 
*                            6 - 12-BIT INSTRUCTION WITH SIGNED 
*                                RELATIVE ADDRESS.
*                            7 - 24-BIT INSTRUCTION WITH 12-BIT 
*                                ADDRESS AND REQUIRED SECOND FIELD. 
*         BITS   26-12       UNUSED.
*         BITS   11-00       VALUE. 
* 
* 
*         WORD 2. (BCU) 
* 
*         BITS   59-57       1
*         BIT    56          1
*         BITS   55-48       UNUSED.
*         BIT    47          OPDEF. 
*         BITS   46-30       UNUSED.
*         BITS   29-27       CTL. 
*                            0 - 4-BIT ADDRESS.  (SAB)
*                            1 - (16 - 4-BIT) ADDRESS.  (SLC) 
*                            2 - (15 - 4-BIT) ADDRESS.  (TAB) 
*                            3 - 8-BIT ADDRESS.  (ADN)
*                            4 - 9-BIT RELATIVE ADDRESS.  (UJR) 
*                            5 - 4-BIT CHANNEL AND NO ADDRESS.  (IAN) 
*                            6 - 8-BIT ADDRESS AND OPTIONAL 
*                                INDEXING. (LDD)
*                            7 - 4-BIT CHANNEL AND 4-BIT ADDRESS.  (INT)
*         BITS   26-16       UNUSED.
*         BITS   15-00       VALUE. 
* 
* 
*         WORD 2. (MCU) 
* 
*         BITS   59-57       1
*         BIT    56          1
*         BITS   55-48       UNUSED.
*         BIT    47          OPDEF. 
*         BITS   46-30       UNUSED.
*         BITS   29-27       CTL. 
*                            0 - NO ADDRESS.  (INX) 
*                            1 - 8-BIT ADDRESS.  (LDAAI)
*                            2 - 16-BIT ADDRESS.  (LDAAE) 
*                            3 - 8-BIT RELATIVE ADDRESS.  (BRA) 
*         BITS   26-08       UNUSED.
*         BITS   07-00       VALUE. 
* 
* 
*         WORD 2. (PSEUDO)
* 
*         BITS   59-57       PSEUDO OPERATION TYPE. 
*                            2 - CAN NOT OCCUR IN FIRST CARD GROUP. 
*                            3 - PROCESS WHILE IF SKIPPING. 
*                            4 - CAN OCCUR ANYWHERE.
*                            5 - FIRST CARD GROUP ONLY. 
*         BITS   56-48       UNUSED.
*         BIT    47          PROGRAM DEFINED FLAG.
*         BITS   46-36       UNUSED.
*         BITS   35-18       PASS 1 PSEUDO ADDRESS. 
*         BITS   17-00       PASS 2 PSEUDO ADDRESS. 
* 
* 
*         WORD 2. (MACRO, MACROE, OPDEF)
* 
*         BITS   59-57       MACRO OPERATION TYPE.
*                            6 - SYSTEXT MACRO. 
*                            7 - PROGRAMMER MACRO.
*         BITS   56-39       WORD COUNT OF TEXT IN MACDEF.
*         BIT    38          FLAG SET/USED BY *GSM*.
*         BIT    37          1 IF MACRO DEF TEXT IS IN ECS/LCM.         S028 288
*         BITS   36-32       UNUSED.                                    S028 289
*         BIT    31          MACROE FLAG. 
*         BITS   30-25       COUNT OF PARAMETERS IN MACRO.
*         BITS   24-19       COUNT OF SUBSTITUTABLE ARGUMENTS.
*         BIT    18          LOCATION ARGUMENT FLAG.
*         BITS   17-00       INDEX IN MACDEF OF START OF MACRO. 
  
  
 OPTAB    TABLE 
 MACDEF   SPACE  4
**        MACDEF - MACRO DEFINITION TABLE.
*         STORES THE DEFINITIONS OF THE MACROS AND OPDEFS FROM
*         SYSTEXT AND PROGRAMMER SOURCES. 
  
  
 MACDEF   TABLE 
 SSYMS    SPACE  4
**        SSYMS - SYSTEM SYMBOLS. 
*         STORES THE SYMBOLS DEFINED BY THE *SST* PSEUDO OPERATION. 
*         SYMBOLS COME FROM SYSTEXT.
* 
*         ENTRY = 2 WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-48       UNUSED.
*         BITS   47-00       SYMBOL RIGHT-JUSTIFIED WITH ZERO FILL. 
* 
*         WORD 2. 
* 
*         BITS   59-39       UNUSED.
*         BITS   38-36       SYSTEM TEXT ORDINAL. 
*         BITS   35-21       UNUSED.
*         BITS   20-00       SYMBOL VALUE.
  
  
 SSYMS    TABLE 
 SYSMIC   SPACE  4
**        SYSMIC - SYSTEM MICROS. 
*         STORES THE PORTION OF THE MICRO TABLE DEFINED BY SYSTEXT. 
* 
*         ENTRY = N WORDS (N = 1 IF MICRO VALUE IS NULL). 
* 
*         WORDS 1-(N-1) - VALUE OF MICRO - CHARACTER STRING PACKED
*         TEN CHARACTERS PER WORD.  IN LAST WORD (WORD N-1), BITS 
*         59-6 CONTAIN 0-9 CHARACTERS LEFT ADJUSTED WITH ZERO FILL
*         AND BITS 5-0 CONTAIN CHARACTER COUNT FOR THIS WORD. 
* 
*         WORD N. 
* 
*         BITS   59-48       2000B + N
*         BITS   47-00       MICRO NAME RIGHT ADJUSTED WITH ZERO FILL.
  
  
 SYSMIC   TABLE 
 CMPTAB   SPACE  4,10                                                    F4810B 
**        CMPTAB - COMPILER TABLE.                                       F4810B 
*         USED TO HOLD CP.NFLS, CP.AFLS AND THE CONTENTS OF CORE         F4810B 
*         INCLUDED BETWEEN THE ADDRESSES CONTAINED IN THESE CELLS WHEN   F4810B 
*         COMPASS IS CALLED BY A COMPILER.                               F4810B 
*                                                                        F4810B 
*         ENTRY = N WORDS.                                               F4810B 
*                                                                        F4810B 
*         WORD 1.                                                        F4810B 
*                                                                        F4810B 
*         BITS   59-30       CP.NFLS   FL AVAILABLE TO COMPASS           F4810B 
*         BITS   29-00       CP.AFLS   ACTUAL FL                         F4810B 
*                                                                        F4810B 
*         WORDS 2-N.         CONTENTS OF CORE INCLUDED BETWEEN ABOVE     F4810B 
                                                                         F4810B 
                                                                         F4810B 
 CMPTAB   TABLE                                                          F4810B 
 TABLE    SPACE  4
**        TABLES BELOW HERE ARE CLEARED AT THE END OF PASS 2. 
 SYMTAB   SPACE  4
**        SYMTAB - SYMBOL TABLE.
*         SYMBOLS DEFINED DURING AN ASSEMBLY. 
* 
*         ENTRY = 2 WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-48       QUALIFIER INDEX. 
*         BITS   47-00       SYMBOL NAME, RIGHT JUSTIFIED WITH
*                            LEADING ZEROS. 
* 
*         WORD 2. 
* 
*         BITS   59-42       LINK FIELD FOR HASHING.
*         BITS   41-39       UNUSED.
*         BITS   38-36       SYSTEXT ORDINAL. 
*         BIT    35          NO REFERENCE FLAG. 
*         BIT    34          XTEXT FLAG.
*         BIT    33          REDEFINITION FLAG. 
*         BIT    32          SST FLAG.
*         BIT    31          EXTERNAL FLAG. 
*         BIT    30          DEFINED FLAG.
*         BITS   29-21       RELOCATION OR EXTERNAL NUMBER. 
*         BITS   20-00       VALUE OF SYMBOL. 
  
  
 SYMTAB   TABLE 
 USETAB   SPACE  4
**        USETAB - PROGRAM BLOCK TABLE. 
*         COUNTERS FOR PROGRAM BLOCKS.
* 
*         ENTRY = 4 WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-00       BLOCK NAME RIGHT JUSTIFIED WITH ZERO FILL. 
*                            SPECIAL BLOCK NAMES -
*                            LCM BLOCK - COMPLEMENTED NAME. 
*                                        PASS 1        PASS 2 
*                            BLOCK 1 - ABSOLUTE*     PROGRAM* 
*                                                OR 
*                            BLOCK 1 - ABSOLUTE*     ABSOLUTE*
*                            BLOCK 2 - (ONE BLANK)   PROGRAM* 
*                            BLOCK 3 - LITERALS*     LITERAL* 
* 
* 
*         WORD 2. 
* 
*         BIT    59          CONDITIONAL LOAD FLAG (PASS 1 ONLY). 
*         BITS   58-42       CURRENT RELTAB HALFWORD INDEX (BINREL).
*         BITS   41-30       UNUSED.
*         BITS   29-24       CURRENT VALUE OF POSITION COUNTER. 
*         BIT    23          VALUE OF NFOUP FLAG. 
*         BITS   22-21       UNUSED.
*         BITS   20-00       VALUE OF ORIGIN COUNTER. 
* 
* 
*         WORD 3. (PASS 1)
* 
*         BITS   59-01       UNUSED.
*         BIT    00          COMMON FLAG. 
* 
* 
*         WORD 3. (PASS 2)
* 
*         BITS   59-54       UNUSED.
*         BITS   53-33       MAXIMUM ORIGIN OF BLOCK. 
*         BITS   32-24       RELOCATION OF BLOCK. 
*         BITS   23-21       UNUSED.
*         BITS   20-00       ORIGIN OF BLOCK. 
* 
* 
*         WORD 4. (PASS 1)
* 
*         BITS   59-21       UNUSED.
*         BITS   20-00       MAXIMUM ORIGIN OF BLOCK. 
* 
* 
*         WORD 4. (PASS 2)
* 
*         BITS   59-00       PARTIAL BINARY WORD (BINWORD)
  
  
 USETAB   TABLE 
 QVTAB    SPACE  4
**        QVTAB - QUALIFIER NAME TABLE. 
*         NAMES OF QUALIFIERS AS THEY OCCUR.
* 
*         ENTRY = 1 WORD. 
* 
*         BIT    59          NO REFERENCE FLAG. 
*         BITS   58-48       UNUSED AND ZERO. 
*         BITS   47-00       QUALIFIER NAME RIGHT ADJUSTED WITH 00 FILL.
  
  
 QVTAB    TABLE 
 SLITS    SPACE  4
**        SLITS - SYMBOL LITERALS.
*         NAMES OF SYMBOL LITERALS. 
* 
*         ENTRY = 1 WORD. 
* 
*         BIT    59          SET TO 1 IF DEFINED BY COMPASS.
*         BITS   58-57       TYPE.
*                            0 - =Y TYPE SYMBOL.
*                            1 - =S TYPE SYMBOL.
*                            2 - =X TYPE SYMBOL.
*                            3 - =S AND =X TYPE SYMBOL. 
*         BITS   56-48       CURRENT QUALIFIER INDEX. 
*         BITS   47-00       SYMBOL NAME RIGHT JUSTIFIED WITH LEADING 
*                            ZEROS. 
  
  
 SLITS    TABLE 
 LITAB    SPACE  4
**        LITAB - LITERAL TABLE.
*         LITERALS DEFINED DURING PASS 1. 
  
  
 LITAB    TABLE 
 EPTAB    SPACE  4
**        EPTAB - ENTRY POINT TABLE.
*         NAMES OF ENTRY POINTS DECLARED BY *ENTRY* AND *ENTRYC*
*         PSEUDO INSTRUCTIONS.
* 
*         ENTRY = 1 WORD. 
* 
*         BIT    59          CONDITIONAL (ENTRYC) FLAG. 
*         BITS   58-00       SYMBOL RIGHT JUSTIFIED WITH 00 FILL. 
  
  
 EPTAB    TABLE 
 RVTAB    SPACE  4,8
**        RVTAB - RELOCATION VECTOR.
*         RELOCATION VALUES FOR EACH BLOCK. 
*         LENGTH IS EQUAL TO THE NUMBER OF BLOCKS DEFINED.
* 
*         ENTRY = 1 WORD. 
* 
*         BITS 59-00         RELOCATION.
  
  
 RVTAB    TABLE 
 EXTAB    SPACE  4
**        EXTAB - EXTERNAL TABLE. 
*         RECORDS EACH EXTERNAL SYMBOL. 
* 
*         ENTRY = 1 WORD. 
* 
*         (PASS 1)
*         BIT    59          SET IF WEAK EXTERNAL (=Y TYPE).
*         BITS   58-00       SYMBOL NAME RIGHT JUSTIFIED WITH 00 FILL.
* 
*         (PASS 2)
*         BITS   59-01       SYMBOL NAME LEFT JUSTIFIED WITH 00 FILL. 
*         BIT    00          SET IF WEAK EXTERNAL.
  
  
 EXTAB    TABLE 
 SEGTAB   SPACE  4
**        SEGTAB - SEGMENT TABLE. 
*         RECORDS ALL RELEVENT INFORMATION ABOUT EACH SEGMENT OR
*         PARTIAL SEGMENT.
* 
*         ENTRY = 4 WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-30       UNUSED.
*         BITS   29-21       RELOCATION OF LWA OF SEGMENT.
*         BITS   20-00       RELATIVE LWA OF SEGMENT. 
* 
* 
*         WORD 2. 
* 
*         BITS   59-36       UNUSED.
*         BITS   35-18       USE TABLE INDEX. 
*         BITS   17-00       IDTAB INDEX. 
* 
* 
*         WORD  3. (PASS 1) 
* 
*         BITS   59-54       UNUSED.
*         BITS   53-36       SLITS INDEX. 
*         BITS   35-18       EPTAB INDEX. 
*         BITS   17-00       LITAB INDEX. 
* 
* 
*         WORD 3. (PASS 2)
* 
*         BITS   59-54       UNUSED.
*         BITS   53-36       SLITS FWA INDEX. 
*         BITS   35-18       EPTAB FWA INDEX. 
*         BITS   17-00       LITAB FWA INDEX. 
* 
* 
*         WORD 4. (PASS 2)
* 
*         BITS   59-54       UNUSED.
*         BITS   53-36       SLITS LWA INDEX. 
*         BITS   35-18       EPTAB LWA INDEX. 
*         BITS   17-00       LITAB LWA INDEX. 
  
  
 SEGTAB   TABLE 
 IDTAB    SPACE  4
**        IDTAB - IDENT CARD TABLE. 
*         USED TO HOLD THE TEXT OF BINARY CONTROL CARDS FOR LISTING 
*         AT THE START OF PASS 2. 
* 
*         ENTRY = M WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-48       QUALIFIER INDEX. 
*         BITS   47-18       UNUSED.
*         BITS   17-00       NUMBER BASE IN EFFECT (NBASE)
* 
* 
*         WORDS 2-N - COMPRESSED TEXT OF BINARY CONTROL CARD. 
*         WORDS N-M - TEXT OF COMMENT CARDS.
  
  
 IDTAB    TABLE 
 TLDS     SPACE  4
**        TLDS - LDSET TABLE. 
*         HOLDS LOADER OBJECT DIRECTIVES CREATED IN PASS 1 FOR
*         DUMPING TO THE BINARY FILE AT THE BEGINNING OF PASS 2.
* 
*         ENTRY = N WORDS. (SEE LOADER REF. MANUAL FOR DETAILS) 
  
  
 TLDS     TABLE 
 TABLE    SPACE  4
**        TABLES BELOW HERE CLEARED AT END OF PASS 1. 
 STACK    SPACE  4
**        STACK - RECURSION STACK.
*         CONTROL OF ASSEMBLER INPUT SOURCES. 
* 
*         ENTRY = 4 WORDS.
* 
*         WORD 1. 
* 
*         BITS   59-54       PERIOD IN DISPLAY CODE.
*         BITS   53-18       RECURSION LEVEL IN DECIMAL, LEFT 
*                            JUSTIFIED WITH BLANK FILL. 
*         BITS   17-00       RELATIVE ADDRESS OF NEXT CARD TO 
*                            BE UNPACKED. 
* 
* 
*         WORD 2. 
* 
*         BITS   59-56       TYPE OF STACK ENTRY. 
*                            1 - MACRO EXPANSION. 
*                            2 - DUPLICATION EXPANSION. 
*                            3 - REMOTE EXPANSION.
*                            4 - XTEXT EXPANSION. 
*                            5 - ECHO EXPANSION.
*         BITS   55-36       A RECORD OF INDICATORS SET WHEN
*                            STACK WAS PUSHED DOWN. 
*         BITS   35-18       LENGTH OF MARGS AT START OF EXPANSION. 
*         BITS   17-00       LENGTH OF MARDIS AT START OF EXPANSION.
* 
* 
*         WORD 3. 
* 
*         BITS   59-36       UNUSED.
*         BITS   35-18       DUP - ITERATION COUNT. 
*                            XTEXT - LENGTH OF LASTAB.
*                            ECHO - LENGTH OF ECHTAB. 
*         BITS   17-00       DUP - LENGTH OF DUPTAB.
* 
* 
*         WORD 4. 
* 
*         BITS   59-48       UNUSED.
*         BITS   47-00       NAME OF MACRO, OR WORDS *DUP*, *RMT*,
*                            OR *ECHO*, OR FILE NAME FOR XTEXT. 
  
  
 STACK    TABLE 
 RMTAB    SPACE  4
**        RMTAB - REMOTE CODE TABLE.
*         USED TO HOLD REMOTE CODE COMPRESSED TEXT. 
  
  
 RMTAB    TABLE 
 LRMTAB   SPACE  4
**        LRMTAB - LABELED REMOTE TABLE.
*         USED TO HOLD LABELED REMOTE NAMES AND COMPRESSED TEXT.
* 
*         ENTRY = N WORDS.
* 
*         WORD 1 - REMOTE NAME, RIGHT JUSTIFIED WITH ZERO FILL. 
* 
*         WORDS 2-N - COMPRESSED TEXT.
  
  
 LRMTAB   TABLE 
 RASTAB   SPACE  4
**        RASTAB - REMOTE ASSEMBLY TABLE. 
*         USED TO HOLD REMOTE COMPRESSED TEXT DURING ASSEMBLY.
  
  
 RASTAB   TABLE 
 LASTAB   SPACE  4
**        LASTAB - LIBRARY ASSEMBLY TABLE.
*         USED TO HOLD XTEXT COMPRESSED TEXT DURING ASSEMBLY. 
  
  
 LASTAB   TABLE 
 DUPTAB   SPACE  4
**        DUPTAB - DUPLICATION TABLE. 
*         USED TO HOLD DUP COMPRESSED TEXT DURING ASSEMBLY. 
  
  
 DUPTAB   TABLE 
 TEMTAB   SPACE  4
**        TEMTAB - TEMPORARY TABLE. 
*         TEMPORARY TABLE USED TO HOLD COMPRESSED TEXT DURING 
*         DEFINITION OPERATIONS.
  
  
 TEMTAB   TABLE 
 ECHTAB   SPACE  4
**        ECHTAB - ECHO TABLE.
*         USED TO HOLD ECHO COMPRESSED TEXT DURING ASSEMBLY.
  
  
 ECHTAB   TABLE 
 MARDIS   SPACE  4
**        MARDIS - MACRO ARGUMENT DISCRIPTORS.
*         CONTAINS POINTERS INTO MARGS FOR THE ACTUAL PARAMETERS
*         OF A MACRO EXPANSION. 
* 
*         ENTRY = 1 WORD. 
* 
*         NON-ITERATIVE FORM. 
* 
*         BITS   59-48       2000B + CHARACTER COUNT OF ARGUMENT. 
*         BITS   47-18       ZERO.
*         BITS   17-00       FWA OF ARGUMENT IN MARGS TABLE.
* 
*         ITERATIVE FORM. 
* 
*         BITS   59-48       1777B - CHARACTER COUNT OF ARGUMENT. 
*         BITS   47-42       54 - BIT POSITION FOR START OF CURRENT 
*                            SUBARGUMENT. 
*         BITS   41-30       2000B + COUNT OF CHARACTERS PRECEDING
*                            CURRENT SUBARGUMENT. 
*         BITS   29-18       2000B + FWA OF CURRENT SUBARGUMENT IN MARGS
*                            TABLE, RELATIVE TO FWA OF ARGUMENT.
*         BITS   17-00       FWA OF ARGUMENT IN MARGS TABLE.
  
  
 MARDIS   TABLE 
 MARGS    SPACE  4
**        MARGS - MACRO ARGUMENTS.
*         USED TO HOLD THE CHARACTER STRINGS OF MACRO ARGUMENTS.
*         EACH CHARACTER STRING STARTS IN A NEW WORD. 
  
  
 MARGS    TABLE 
 MICTAB   SPACE  4
**        MICTAB - MICRO TABLE. 
*         RECORDS THE NAMES AND CURRENT DEFINITION OF MICROS. 
*         IF TABLE IS NON-EMPTY, FIRST WORD IS USED AS SCRATCH
*         DURING TABLE LOOKUP.
* 
*         ENTRY = N WORDS (N = 1 IF MICRO VALUE IS NULL). 
* 
*         WORDS 1-(N-1) - VALUE OF MICRO - CHARACTER STRING PACKED
*         TEN CHARACTERS PER WORD.  IN LAST WORD (WORD N-1), BITS 
*         59-6 CONTAIN 0-9 CHARACTERS LEFT ADJUSTED WITH ZERO FILL
*         AND BITS 5-0 CONTAIN CHARACTER COUNT FOR THIS WORD. 
* 
*         WORD N. 
* 
*         BITS   59-48       2000B + N
*         BITS   47-00       MICRO NAME RIGHT ADJUSTED WITH ZERO FILL.
  
  
 MICTAB   TABLE 
 REFTAB   SPACE  4
**        REFTAB - SYMBOLIC REFERENCE TABLE.
*         RECORDS THE INFORMATION REQUIRED FOR GENERATING THE 
*         REFERENCE TABLE AT THE END OF ASSEMBLY. 
* 
*         ENTRY = 1 WORD. 
* 
*         BITS   59-42       INDEX OF THE SYMBOL IN SYMTAB. 
*         BITS   41-25       LOCATION COUNTER.
*         BITS   24-13       PAGE NUMBER. 
*         BITS   12-06       LINE NUMBER. 
*         BITS   05-00       USAGE LETTER.
  
  
 REFTAB   TABLE              SYMBOLIC REFERENCE TABLE 
 MEMORY   SPACE  4
**        MEMORY - MEMORY TABLE.
*         USED TO HOLD SYSTEXT DURING PASS 0 AND BINARY FOR ABSOLUTE
*         PROGRAMS DURING PASS 2. 
  
  
 MEMORY   TABLE 
 ENDTAB   SPACE  4
**        ENDTAB - END TABLE. 
*         DUMMY TABLE USED BY THE TABLE MANAGER.
  
  
 ENDTAB   TABLE 
 NTABLES  EQU    *-ORIGINS
 TABLE    SPACE  4
**        SHARED TABLES.
 ERRTAB   SPACE  4
**        ERRTAB - ERROR DIRCTORY TABLE.
*         USED TO RECORD PAGE OCCURRENCES OF ERRORS.
* 
*         ENTRY = 1 WORD. 
* 
*         BITS   59-30       ERROR TYPE (INDEX INTO ERFLAGS)
*         BITS   29-00       PAGE NUMBER. 
  
  
 ERRTAB   TABLE  MICTAB      ERROR DIRECTORY
 COMTAB   SPACE  4
**        COMTAB - COMMON LINKAGE TABLE.
*         USED IN PASS 2 TO RECORD THE COMMON LINKAGES IN THE 
*         BINARY OUTPUT.
* 
*         ENTRY = 1 WORD. 
* 
*         BASIC FORMAT - FILL (4200B) TABLE.
* 
*         BITS   59-48       ZEROS. 
*         BITS   47-39       SAME AS BITS 26-18 IF CONDITIONAL
*                            LOADING, ZEROS IF UNCONDITIONAL. 
*         BITS   38-30       COMMON BLOCK NUMBER, STARTING WITH 
*                            3 FOR INTERNAL BLOCK NUMBER 2. 
*         BIT    29          A 1-BIT FOR LATER TABLE CONSTRUCTION.
*         BITS   28-27       POSITION INFORMATION.
*                            2 - UPPER ADDRESS (BITS 47-30) 
*                            1 - MIDDLE ADDRESS (BITS 32-15)
*                            0 - LOWER ADDRESS (BITS 17-00) 
*         BITS   26-18       RELOCATION OF REFERENCE ADDRESS, 
*                            IN LOADER RELOCATION.
*                            0 - ABSOLUTE.
*                            1 - PLUS PROGRAM.
*                            3 - FIRST COMMON BLOCK.
*                            4 - SECOND COMMON BLOCK. 
*                            ETC. 
*         BITS   17-00       REFERENCE ADDRESS. 
* 
*         EXTENDED FORMAT - XFILL (4100B) TABLE, UNCONDITIONAL LOADING. 
* 
*         BITS   59-57       ZEROS. 
*         BITS   56-48       COMMON BLOCK NUMBER. 
*         BITS   47-39       RELOCATION OF REFERENCE ADDRESS. 
*         BITS   38-33       ZEROS. 
*         BITS   32-12       REFERENCE ADDRESS. 
*         BITS   11-06       LOW-ORDER BIT POSITION OF ADDRESS FIELD. 
*         BITS   05-00       LENGTH, IN BITS, OF ADDRESS FIELD. 
* 
*         EXTENDED FORMAT - XFILL (4100B) TABLE, CONDITIONAL LOADING. 
* 
*         BITS   59-57       001. 
*         BITS   56-48       RELOCATION OF REFERENCE ADDRESS. 
*         BITS   47-42       ZEROS. 
*         BITS   41-21       REFERENCE ADDRESS. 
*         BITS   20-15       LOW-ORDER BIT POSITION OF ADDRESS FIELD. 
*         BITS   14-09       LENGTH, IN BITS, OF ADDRESS FIELD. 
*         BITS   08-00       COMMON BLOCK NUMBER. 
* 
*         THE FIRST WORD OF COMTAB IS USED AS SCRATCH BY DLAST.  ANY
*         OR ALL OF THE ABOVE FORMATS MAY BE INTERMIXED IN COMTAB;
*         DLAST SORTS THEM OUT. 
  
  
 COMTAB   TABLE  RMTAB       COMMON LINKAGE TABLE 
 LNKTAB   SPACE  4
**        LNKTAB - EXTERNAL LINKAGE TABLE.
*         CONTAINS ALL REFERENCES TO EXTERNAL SYMBOLS IN THE
*         BINARY OUTPUT.
* 
*         ENTRY = 1 WORD. 
* 
*         BASIC FORMAT - LINK (4400B) TABLE.
* 
*         BITS   59-48       ZEROS. 
*         BITS   47-39       SAME AS BITS 26-18 IF CONDITIONAL
*                            LOADING, ZEROS IF UNCONDITIONAL. 
*         BITS   38-30       EXTERNAL SYMBOL ORDINAL (1 FOR THE FIRST). 
*         BIT    29          A 1-BIT FOR LATER TABLE CONSTRUCTION.
*         BITS   28-27       POSITION OF REFERENCE AS IN COMTAB.
*         BITS   26-18       RELOCATION OF REFERENCE ADDRESS
*                            AS IN COMTAB.
*         BITS   17-00       REFERENCE ADDRESS. 
* 
*         EXTENDED FORMAT - XLINK (4500B) TABLE, UNCONDITIONAL LOADING. 
* 
*         BITS   59-57       ZEROS. 
*         BITS   56-48       EXTERNAL SYMBOL ORDINAL. 
*         BITS   47-39       RELOCATION OF REFERENCE ADDRESS. 
*         BITS   38-33       ZEROS. 
*         BITS   32-12       REFERENCE ADDRESS. 
*         BITS   11-06       LOW-ORDER BIT POSITION OF ADDRESS FIELD. 
*         BITS   05-00       LENGTH, IN BITS, OF ADDRESS FIELD. 
* 
*         EXTENDED FORMAT - XLINK (4500B) TABLE, CONDITIONAL LOADING. 
* 
*         BITS   59-57       001. 
*         BITS   56-48       RELOCATION OF REFERENCE ADDRESS. 
*         BITS   47-42       ZEROS. 
*         BITS   41-21       REFERENCE ADDRESS. 
*         BITS   20-15       LOW-ORDER BIT POSITION OF ADDRESS FIELD. 
*         BITS   14-09       LENGTH, IN BITS, OF ADDRESS FIELD. 
*         BITS   08-00       EXTERNAL SYMBOL ORDINAL. 
* 
*         THE FIRST (L.EXTAB)+1 WORDS OF LNKTAB ARE USED AS SCRATCH BY
*         DLAST.  ANY OR ALL OF THE ABOVE FORMATS MAY BE INTERMIXED IN
*         LNKTAB; DLAST SORTS THEM OUT. 
  
  
 LNKTAB   TABLE  RASTAB      EXTERNAL LINKAGE TABLE 
 RELTAB   SPACE  4
**        RELTAB - RELOCATION INDICATOR TABLE.
*         FOR A RELOCATABLE ASSEMBLY, RELTAB STORES THE RELOCATION
*         INDICATORS FOR THE CURRENT PARTIAL BINARY WORD FOR EACH 
*         USE BLOCK.  RELTAB IS NOT USED FOR AN ABSOLUTE ASSEMBLY.
* 
*         ENTRY = 2 WORDS, COMPRISING FOUR 30-BIT FIELDS. 
* 
*         BIT    29          EXTERNAL FLAG. 
*         BITS   28-12       RELOCATION BASE OR EXTERNAL NUMBER.
*         BITS   11-06       LOW-ORDER BIT POSITION OF ADDRESS FIELD. 
*         BITS   05-00       LENGTH, IN BITS, OF ADDRESS FIELD. 
  
  
 RELTAB   TABLE  DUPTAB 
 TABLE    SPACE  4
**        TABLE LENGTHS.
  
  
          LIST   G
 SIZES    BSS    0
          HERE
          LIST   *
 STACKS   TITLE  PUSH-DOWN STACKS.
**        A STACK AREA BEGINS WITH A CONTROL WORD OF THE FORM 
*                      VFD   18/VAL,6/UBW,6/BPE,6/POS,6/WDN,18/AVL
*                (VAL) = VALUE RETURNED FROM POPPING AN EMPTY STACK,
*                            MUST BE NON-NEGATIVE AND LESS THAN 2**17.
*                (UBW) = NUMBER OF UNUSED BITS AT TOP OF EACH WORD. 
*                (BPE) = NUMBER OF BITS PER ENTRY.
*                (POS) = CURRENT BIT POSITION  )  POINT TO TOP OF STACK,
*                (WDN) = CURRENT WORD NUMBER   )  INITIALLY ZEROS.
*                (AVL) = NUMBER OF AVAILABLE ENTRIES, INITIALLY = (MAX).
*         FOLLOWED BY AS MANY WORDS AS NECESSARY TO HOLD (MAX) ENTRIES. 
*         WHEN STACK OVERFLOWS, BOTTOM-MOST ENTRY IS DISCARDED. 
 BASESTK  SPACE  4
**        BASESTK - PUSH-DOWN STACK FOR *BASE* PSEUDO INSTRUCTIONS. 
*         ENTRY VALUES -  0 = D,  1 = O,  2 = M.
  
  
 BASESTK  STACK  2,MSTACK,0 
 CODESTK  SPACE  4
**        CODESTK - PUSH-DOWN STACK FOR *CODE* PSEUDO INSTRUCTIONS. 
*         ENTRY VALUES -  0 = D,  1 = E,  2 = I,  3 = A,  4 = O.
  
  
 CODESTK  STACK  3,MSTACK,0 
 LISTSTK  SPACE  4
**        LISTSTK - PUSH-DOWN STACK FOR *LIST* PSEUDO INSTRUCTIONS. 
*         ENTRY VALUE = A FIELD LONG ENOUGH TO HOLD ONE BIT FOR 
*         EACH LIST OPTION -  0 = OFF,  1 = ON. 
  
  
 LISTSTK  STACK  NLISTOPS,MSTACK,LIST.
 QUALSTK  SPACE  4
**        QUALSTK - PUSH-DOWN STACK FOR *QUAL* PSEUDO INSTRUCTIONS. 
*         ENTRY VALUE = QUALIFIER INDEX.
  
  
 QUALSTK  STACK  9,MSTACK,0 
 USESTK   SPACE  4
**        USESTK - PUSH-DOWN STACK FOR *USE* AND *USELCM* PSEUDOS.
*         ENTRY VALUE = BLOCK NUMBER. 
  
  
 USESTK   STACK  8,MSTACK,0 
 STACKPTR SPACE  4
**        STACK POINTERS USED BY *CPS*. 
  
  
 STACKPTR BSS    0
 STACKPTR HERE
          DATA   0
 PASS1    TITLE  TEMPORARY STORAGE. 
  
  
          QUAL   PASS1
 IFCNT    DATA   0           IF SKIPPING COUNTER
 IFNAME   DATA   0           IF SKIPPINB BRACKET NAME 
 XLEV     DATA   0           XTEXT AND CTEXT/ENDX NESTING LEVEL         P036   8
  
*         THE FOLLOWING P1TEMPX CELLS MUST BE IN ORDER. 
  
 P1TEMP   DATA   0           GENERAL TEMPORARY
 P1TEMPA  DATA   0           GENERAL TEMPORARY
 P1TEMPB  DATA   0           GENERAL TEMPORARY
 P1TEMPC  DATA   0           GENERAL TEMPORARY
 P1TEMPD  DATA   0           GENERAL TEMPORARY
 P1TEMPE  DATA   0           GENERAL TEMPORARY
 PASS2    SPACE  4
  
  
          QUAL   PASS2
 CLP2     BSS    0
 CTYPE    DATA   0           CONTROL CARD TYPE FLAG 
 MAXORG   DATA   0           UPPER LIMIT FOR BINARY OUTPUT
 MINORG   DATA   0           LOWER LIMIT FOR BINARY OUTPUT
 ORGBASE  DATA   0           ORIGIN OF CURRENT OVERLAY
 SEGEPT   DATA   0           SEGMENT ENTRY POINT FOR ABS-CP CODE
 BINWORD  DATA   0           PARTIAL BINARY WORD
 BINREL   BSSZ   3           PARTIAL BINARY RELOCATION
 DKNAM    DATA   0           CURRENT DECK NAME
 DKCNT    DATA   0           DECK COUNT FOR ERASING BINARY OUTPUT 
 LPCNT    DATA   0           LINE COUNT FOR THIS PAGE 
 LPCX     DATA   0           LINE COUNT -- PRINTED LINES ONLY 
 PGCX     DATA   0           PAGE COUNT -- FOR CORRECT CROSS REFERENCING
 DETFLG   DATA   0           DETAIL LINE FLAG 
 LXRF     DATA   0           PERMANENT REFERENCE SUPPRESSION
 SUPREF   DATA   0           TEMPORARY REFERENCE SUPPRESSION
 SUBTIT   DATA   1H          TEXT OF SUBTITLE 
 SUBTITL  EQU    6
          BSS    SUBTITL
 SBNAME   DATA   1H          SUBROUTINE NAME LEFT ADJUSTED
 UNAME    DATA   1H          USE BLOCK NAME 
 QNAME    DATA   1H          QUALIFIER NAME 
 SUBL     EQU    *-SUBTIT 
 SUBNAME  DATA   0           SUBROUTINE NAME
 OCTAL    BSS    40          COLUMNS 1-40 OF PRINT LINE 
 LINE     BSS    9*NCARDS    PRINT LINE 
 BINREC   BSS    18          BINARY CARD IMAGE
 OPVAL    DATA   0           OPERATION CODE VALUE 
 ORGBSSZ  BSSZ   2           ORIGIN OF LAST BSSZ
 CNTBSSZ  DATA   0           COUNT OF ABOVE 
 LOSTREF  DATA   0           COUNT OF LOST REFERENCES 
 REFIO    DATA   0           CROSS REFERENCE OVERFLOW FLAG
 REFLET   DATA   0           CROSS REFERENCE USAGE LETTER 
 LCCT     DATA   0           LISTING CARD COUNT 
 FLIST    DATA   0           FORCED LISTING FLAG (C.F. LISTERF) 
 NLFLG    DATA   0           NO LIST FLAG 
 DLFLG    DATA   0           DEFERRED LIST FLAG 
 PLFLG    DATA   0           PRINT LINE READY FLAG
 ELCNT    DATA   0           ERROR LINE COUNT 
 RIFA     DATA   0           INTERMEDIATE HEADER WORD 
 LCLP2    EQU    *-CLP2 
 LLINE    VFD    60/LINE+9*NCARDS LAST PRINT LINE USED
  
 P2TEMP   DATA   0           PASS 2 GENERAL TEMPORARY 
 P2TEMPA  DATA   0           PASS 2 GENERAL TEMPORARY 
 P2TEMPB  DATA   0           PASS 2 GENERAL TEMPORARY 
 P2TEMPC  DATA   0           PASS 2 GENERAL TEMPORARY 
          SPACE  4
*         LETTER EQUIVALENTS OF ERROR FLAGS (MUST PARALLEL ERFLAGS) 
  
 ERRLETS  BSS    0
 ERRLETS  HERE
  
*         DIRECTORY FOR ERROR FLAG COMMENTARY 
  
 ERDIR    BSS    0
 ERDIR    HERE
          QUAL
 COMPASS  TITLE  COMPASS MAIN BATCH CONTROL.
 SYSTEM   TITLE  SYSTEM COMMUNICATION ROUTINES. 
          USE    SYSTEM 
          SEG    SYSTEM COMMUNICATION SUBROUTINES.
  
  
          LIST   "LISTRM"X,-F                                           S028 291
  
  
 RM       IFNE   CP#RM,7                                                S028 293
  
  
**        COMCCIO - CENTRAL CALLS FOR INPUT/OUTPUT. 
*         ENTRY  (X2) = FET ADDRESS.
*                (B6) = FWA OF DATA AREA. 
*                (B7) = WORD COUNT OF DATA. 
*         EXIT   (X2) = FET ADDRESS.
  
  
*CALL COMCCIO 
  
  
 RM       IFEQ   CP#RM,0
  
  
*CALL COMCRDC 
*CALL COMCRDW 
*CALL COMCWTH 
*CALL COMCWTW 
*CALL COMCSTF 
  
  
 RM       ENDIF 
  
  
          LIST   *
  
  
          USE    UTILITY
          SEG    UTILITY SUBROUTINES. 
 DEBUG    TITLE  DEBUGGING FACILITIES.
**        DEBUGGING FACILITIES. 
* 
*         A PATCH/SNAP DEBUGGING FACILITY IS INCLUDED IN COMPASS
*         BY ASSEMBLING IT WITH DEBUG = 1.  DURING INITIALIZATION,
*         THE FILE NAMED *PATCHES* IS REWOUND AND PATCH AND SNAP
*         DIRECTIVE CARDS ARE READ UNTIL END OF LOGICAL RECORD. 
*         EACH CARD IS COPIED TO THE FILE NAMED *SNAPPER*.
* 
*         PATCH DIRECTIVES PROVIDE FOR CHANGING CODE IN COMPASS 
*         WITHOUT REASSEMBLING.  A PATCH AREA IS PROVIDED STARTING
*         AT ORGOVER.  PATCH DIRECTIVE FORMAT IS AS FOLLOWS.
* 
*                COLUMNS  1-6  - *PATCH 
*                COLUMNS  7-10 - BLANKS 
*                COLUMNS 11-80 - TWO OCTAL NUMBERS SEPARATED BY 
*                                A COMMA (BLANKS ARE IGNORED).
*         THE FIRST NUMBER IS AN ADDRESS.  THE SECOND NUMBER IS THE 
*         VALUE TO BE STORED AT THAT ADDRESS. 
* 
*         EXAMPLE...     *PATCH    14106,51100 00173 73617 75001
* 
*         SNAP DIRECTIVES PROVIDE FOR DUMPING REGISTERS AND MEMORY
*         AREAS DYNAMICALLY.  SNAPSHOTS ARE FORMATTED AND WRITTEN 
*         TO THE FILE NAMED *SNAPPER* DURING COMPASS EXECUTION. 
*         AFTER ASSEMBLY, REWIND SNAPPER AND COPYCF TO A PRINT
*         FILE.  SNAP DIRECTIVE CARD FORMAT IS AS FOLLOWS.
* 
*                COLUMNS  1-5  - *SNAP
*                COLUMNS  6-10 - BLANKS 
*                COLUMNS 11-80 - ONE OR MORE OCTAL NUMBERS SEPARATED
*                                BY COMMAS (BLANKS ARE IGNORED).
*         THE FIRST NUMBER IS AN ADDRESS.  THE SNAPSHOT IS TAKEN
*         WHENEVER THE FIRST INSTRUCTION AT THAT ADDRESS IS ABOUT 
*         TO BE EXECUTED.  THE REMAINING NUMBERS (IF ANY) ARE PAIRS 
*         OF VALUES, EACH PAIR GIVING THE FIRST WORD ADDRESS AND
*         WORD COUNT OF A MEMORY AREA TO BE DUMPED.  AN ASTERISK
*         AFTER A NUMBER CAUSES INDIRECT ADDRESSING - THE VALUE IS
*         TAKEN FROM BITS 17-0 OF THE SPECIFIED WORD AT SNAP TIME.
*         A DOLLAR SIGN AFTER A NUMBER SPECIFIES ECS/LCM ADDRESSING.
*         A TABLE NAME MAY BE USED IN PLACE OF A PAIR OF NUMBERS.       S028 295
* 
*         EACH SNAPSHOT IS WRITTEN AS ONE LOGICAL RECORD CONTAINING 
*         A DUMP OF THE FIRST 72 CHARACTERS OF THE CARD AREA, A DUMP
*         OF ALL REGISTERS, AND DUMPS OF THE SPECIFIED MEMORY AREAS.
*         IN THE MEMORY DUMPS, ALL-ZERO LINES ARE OMITTED.
* 
*         EXAMPLE...     *SNAP     01774,216*,10
*         WILL DUMP EIGHT WORDS STARTING AT THE ADDRESS IN THE WORD 
*         AT LOCATION 216B. 
* 
*         SNAPPING SAVES AND RESTORES ALL REGISTERS EXCEPT B1.
*         IF B1 " 1, A JUMP OUT OF BOUNDS OCCURS.  OTHERWISE, 
*         A 1 IS REGENERATED. 
 DEBUG    SPACE  4,4
**        SNAPSHOT ROUTINES.
* 
*         ENTERED WHEN A SNAPSHOT LOCATION IS EXECUTED. 
  
  
 DEBUG    IFNE   DEBUG
          QUAL   DEBUG
  
 SNAPBUF  BSS    100         SNAP DESCRIPTORS 
 SNAPPTR  BSS    1           ADDRESS OF CURRENT DESCRIPTOR WORD 
  
 SNTEMP   BSS    1           TEMPORARY STORAGE
  
 SNLINE   BSS    14          PRINT LINE IMAGE 
  
 SNX      BSS    8           X REGISTERS
 SNB      DATA   0           B REGISTERS
          DATA   1
          BSS    6
 SNA      BSS    8           A REGISTERS
 SNP      BSS    1           P REGISTER (LOC OF WORD CONTAINING RJ) 
  
 SNINST   BSS    1           REPLACED INSTRUCTION WORD
  
 SNAPPER  PS                 RETURN EXIT
          NG     B1,-5       OUT OF BOUNDS IF B1 " 1
          SB1    B1-1 
          ZR     B1,SNAPPER1
          SB1    B1+1 
          EQ     -5 
 SNAPPER1 SB1    A6          SAVE REGISTERS 
          SA6    SNX+6
          SX6    B1 
          SA6    SNA+6
          SB1    1
          SX6    A7 
          SA6    A6+B1
          BX6    X7 
          SA6    SNX+7
          BX6    X0 
          LX7    X1 
          SA6    SNX
          SA7    A6+B1
          BX6    X2 
          LX7    X3 
          SA6    A7+B1
          SA7    A6+B1
          BX6    X4 
          LX7    X5 
          SA6    A7+B1
          SA7    A6+B1
          SX6    A0-B0
          SX7    A1 
          SA6    SNA
          SA7    A6+B1
          SX6    A2 
          SX7    A3 
          SA6    A7+B1
          SA7    A6+B1
          SX6    A4 
          SX7    A5 
          SA6    A7+B1
          SA7    A6+B1
          SX7    B2-B0
          SA7    SNB+2
          SX6    B3-B0
          SX7    B4-B0
          SA6    A7+B1
          SA7    A6+B1
          SX6    B5-B0
          SX7    B6-B0
          SA6    A7+B1
          SA7    A6+B1
          SX6    B7-B0
          SA6    A7+B1
          SA1    SNAPPER
          LX1    30 
          SX7    X1-1 
          SA7    SNP
          SB7    B0          PREPARE SNAP LINES 
          MX0    0
          SA0    B0 
          SX5    1R0         DOUBLE SPACE BETWEEN RANGES
          RJ     SNSCH
          RJ     SNWLIN 
          SX5    1R 
          RJ     SNSCH
          SA5    STYPE       PRINT STYPE
          RJ     SNSCH
          SA1    =8H CARD = 
          SB5    8
          RJ     SCHAR
          SB5    -72
 SNAP1    SA5    CARD+72+B5  PRINT FIRST 72 CHARACTERS OF CARD
          RJ     SNSCH
          SB5    B5+B1
          MI     B5,SNAP1 
          RJ     SNWLIN 
          SA1    =5H0P =     PRINT P
          SB5    5
          RJ     SCHAR
          SA1    SNP
          LX1    42 
          SB5    6
          RJ     SNUMB
          SB4    -6          PRINT B2 THRU B7 
 SNAP2    SA1    =9H    B8 =
          SX5    B4 
          SB5    9
          LX5    24 
          IX1    X1+X5
          RJ     SCHAR
          SA1    SNB+8+B4 
          SB5    6
          SB4    B4+B1
          LX1    42 
          RJ     SNUMB
          MI     B4,SNAP2 
          RJ     SNWLIN 
          SB4    -8          PRINT X, A, (A)
          SA1    =6H0X0 = 
 SNAP3    SB5    6
          RJ     SCHAR
          SA1    SNX+8+B4    PRINT X IN OCTAL 
          SB5    20 
          RJ     SNUMB
          SA1    =3H         PRINT 3 BLANKS 
          SB5    3
          RJ     SCHAR
          SA1    SNX+8+B4    PRINT X IN DISPLAY CODE
          SB5    10 
          RJ     SCHAR
          SA1    =10H      A8 = 
          SX5    B4 
          LX5    12 
          SB5    11 
          IX1    X1+X5
          RJ     SCHAR
          SA1    SNA+8+B4    PRINT A IN OCTAL 
          SB5    6
          LX1    42 
          RJ     SNUMB
          SX2    B4+8 
          ZR     X2,SNAP5    AVOID (A0) 
          SA1    =8H     (A0
          SB5    8
          LX2    12 
          IX1    X1+X2
          RJ     SCHAR
          SA1    =4H) = 
          SB5    4
          RJ     SCHAR
          SA1    SNA+8+B4    PRINT (A) IN OCTAL 
          SB5    20 
          SA1    X1 
          RJ     SNUMB
          SA1    =3H         PRINT 3 BLANKS 
          SB5    3
          RJ     SCHAR
          SA1    SNA+8+B4    PRINT (A) IN DISPLAY CODE
          SB5    10 
          SA1    X1 
          RJ     SCHAR
 SNAP5    SX6    B4+B1
          SA6    SNTEMP 
          RJ     SNWLIN 
          SA5    SNTEMP 
          SA1    =6H X8 = 
          SB4    X5 
          LX5    42 
          IX1    X1+X5
          MI     B4,SNAP3 
          SA1    SNP         START PROCESSING SNAP DESCRIPTORS
          SA1    X1 
          SA1    SNAPBUF+X1 
          SX7    A1 
          BX6    X1 
          SA6    SNINST      STORE REPLACED INSTRUCTION WORD
 SNAP6    SA1    X7+B1       SNAP DESCRIPTION 
          SX7    A1 
          LX1    30 
          SB6    X1          FWA OF SNAP
          PL     B6,SNAP7 
          SA2    B6-400000B 
          SB6    X2 
 SNAP7    LX1    30 
          SB2    X1          WORD COUNT 
          PL     B2,SNAP7A
          SA2    B2-400000B 
          SB2    X2 
 SNAP7A   ZR     B2,SNAP12   IF WORD COUNT IS ZERO
          SX5    1R0
          SB4    4
          SB3    B0 
          SA7    SNAPPTR
          LX1    59-48
          SX7    B0 
          PL     X1,SNAP8    IF NOT ECS/LCM 
          MX1    42 
          SX7    B6 
          BX7    X1+X7
 SNAP8    GE     B2,B4,SNAP8A 
          SB4    B2 
 SNAP8A   ZR     X7,SNAP8B   IF NOT ECS/LCM 
          SX0    X7 
          SA0    SNLCM+1     READ TO CM/SCM WORK AREA 
          SB6    A0 
 +        RE     B4 
 -        NO
 SNAP8B   EQ     B4,B2,SNAP9 IF LAST LINE 
          SA3    B6          DROP LINE IF ALL FOUR WORDS ARE ZERO 
          SA4    B6+B1
          BX3    X3+X4
          SA4    A4+B1
          BX3    X3+X4
          SA4    A4+B1
          BX3    X3+X4
          NZ     X3,SNAP9 
          MI     X3,SNAP9 
          SB6    B6+B4
          SB2    B2-B4
          ZR     X7,SNAP8    IF NOT ECS/LCM 
          SX7    X7+B4
          EQ     SNAP8
 SNAP9    SA7    SNLCM       SAVE ECS/LCM POINTER 
          MX0    0
          SA0    B0          STORE FORMS CONTROL CHARACTER
          RJ     SNSCH
          SX1    B6          PRINT ADDRESS IN OCTAL 
          ZR     X7,*+1 
          SX1    X7 
          SB5    6
          LX1    42 
          RJ     SNUMB
          SA2    SNLCM
          SA1    =3H         PRINT 3 BLANKS 
          SB5    3
          ZR     X2,SNAP9A   IF NOT ECS/LCM 
          SX5    1RL
          SB5    2           PRINT *L* AND 2 BLANKS 
          RJ     SNSCH
 SNAP9A   RJ     SCHAR
 SNAP10   SA1    B6          PRINT UP TO 4 WORDS IN OCTAL 
          SB5    20 
          RJ     SNUMB
          SX5    1R          PRINT 1 BLANK AFTER EACH WORD
          RJ     SNSCH
          SB3    B3+B1
          SB6    B6+B1
          LT     B3,B4,SNAP10 
          SX1    2R          PRINT 2 ADDITIONAL BLANKS
          SB5    B1+B1       AFTER LAST WORD
          LX1    48 
          RJ     SCHAR
          SB3    -B4
          SB6    B6-B4
          SB3    B3+4 
          ZR     B3,SNAP11   IF 4 WORDS PRINTED 
          SA1    =10H 
 SNAP10A  SB5    21          PRINT 21 BLANKS FOR EACH WORD
          RJ     SCHAR       NOT PRINTED OF THE 4 POSSIBLE
          SB3    B3-B1
          NZ     B3,SNAP10A 
 SNAP11   SA1    B6          PRINT UP TO 4 WORDS IN DISPLAY CODE
          SB5    10 
          RJ     SCHAR
          SB3    B3+B1
          SB6    B6+B1
          LT     B3,B4,SNAP11 
          SX6    B6 
          SX7    B2-B4
          LX6    30 
          BX6    X6+X7
          SA6    SNTEMP 
          RJ     SNWLIN 
          SA1    SNTEMP 
          SA2    SNLCM
          SB3    B0 
          SB4    4
          SX5    1R 
          SB2    X1 
          AX1    30 
          SB6    X1 
          BX7    X2 
          ZR     X2,SNAP11A  IF NOT ECS/LCM 
          SX7    X2+B4
 SNAP11A  NZ     B2,SNAP8    IF WORD COUNT NOT EXHAUSTED
          SA1    SNAPPTR
          SA1    X1 
          SX7    A1 
 SNAP12   PL     X1,SNAP6    IF NOT FINAL DESCRIPTOR
          WEOR   D           FLUSH BUFFER 
          CHECK  D
          MX0    42          RESTORE REGISTERS
          SB7    -6 
          SB6    B0 
 SNAP13   SX6    610B+B7
          SX7    X6+B1
          LX6    30 
          BX6    X7+X6
          LX6    21 
          SA1    SNB+8+B7 
          SA2    A1+B1
          BX1    -X0*X1 
          BX2    -X0*X2 
          LX1    30 
          BX1    X1+X2
          BX6    X6+X1
          SA6    SNR+B6 
          SB6    B6+B1
          SB7    B7+2 
          NG     B7,SNAP13
          SA1    SNA
          BX2    -X0*X1 
          SA3    SNPROT 
          LX2    30 
          BX6    X3+X2
          SA6    A6+B1
          SA1    SNA+6
          SA2    A1+B1
          SA1    X1 
          SA2    X2 
          BX6    X1 
          LX7    X2 
          SA6    A1 
          SA7    A2 
          SA1    SNX+6
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA2    A1-B1
          SA1    SNA+5
          SA5    X1 
          BX5    X2 
          SA1    A1-B1
          SA2    A2-B1
          SA4    X1 
          BX4    X2 
          SA1    A1-B1
          SA2    A2-B1
          SA3    X1 
          BX3    X2 
          SA1    SNX
          BX0    X1 
          SA2    SNA+2
          SA2    X2 
          SA1    SNX+2
          BX2    X1 
          MX1    60 
          SA0    X1-0        A0 = 777777B 
          SA1    SNX+1
          UX1,B2 X1 
          LX1    10 
          UX1,B3 X1 
          LX1    10 
          UX1,B4 X1 
          LX1    10 
          UX1,B5 X1 
          LX1    10 
          UX1,B6 X1 
          LX1    10 
          UX1,B7 X1 
          SB1    A0-B0
          SB1    X1+B1
          SA1    SNA+1
          SA1    X1 
          SX1    B1-B0
          PX1    X1,B7
          LX1    50 
          PX1    X1,B6
          LX1    50 
          PX1    X1,B5
          LX1    50 
          PX1    X1,B4
          LX1    50 
          PX1    X1,B3
          LX1    50 
          PX1    X1,B2
          SB1    1
 SNR      SB2    A0+**
          SB3    A0+**
          SB4    A0+**
          SB5    A0+**
          SB6    A0+**
          SB7    A0+**
          SA0    A0+**
          EQ     SNINST      GO EXECUTE REPLACED INSTRUCTION WORD 
 SNPROT   SA0    A0+0 
          EQ     SNINST 
 SCHAR    SPACE  4
**        SCHAR - STORE CHARACTER STRING. 
*         ENTRY  (X1) = CHARACTER STRING LEFT JUSTIFIED.
*                (B5) = NUMBER OF CHARACTERS. 
  
  
 SCHAR1   LX1    6
          BX5    -X2*X1 
          NZ     X5,SCHAR2
          SX5    1R 
 SCHAR2   RJ     SNSCH
          SB5    B5-B1
          NZ     B5,SCHAR1
 SCHAR    PS                 RETURN EXIT
          MX2    -6 
          EQ     SCHAR1 
 SNUMB    SPACE  4
**        SNUMB - STORE NUMBER. 
*         ENTRY  (X1) = BINARY NUMBER LEFT JUSTIFIED. 
*                (B5) = NUMBER OF OCTAL DIGITS. 
  
  
 SNUMB1   LX1    3
          BX3    -X2*X1 
          SX5    X3+1R0 
          RJ     SNSCH
          SB5    B5-B1
          NZ     B5,SNUMB1
 SNUMB    PS                 RETURN EXIT
          MX2    -3 
          EQ     SNUMB1 
 SNWLIN   SPACE  4
**        SNWLIN - WRITE END OF LINE. 
*         ENTRY  (X0) = CURRENT WORD. 
*                (B7) = NUMBER OF CHARACTERS IN X0. 
*                (A0) = NUMBER OF WORDS IN LINE, NOT COUNTING (X0). 
*         EXIT   X0, B7, A0 = 0.
  
  
 SNWLIN   PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          SB5    8
          EQ     B7,B5,SNWLIN2
 SNWLIN1  SX5    1R 
          RJ     SNSCH
          NE     B7,B5,SNWLIN1
 SNWLIN2  LX0    12 
          SB6    SNLINE 
          BX6    X0 
          SB7    A0+B1
          SA6    B6+A0
          WRITEW D,B6,B7     WRITE LINE 
  
 RM       ELSE
  
          SX5    A0 
          ZR     B7,SNWLIN1  IF AT END OF WORD
          SB5    -B7
          SB5    10+B5       LEFT JUSTIFY CHARACTERS
          SX6    B5+B5       AND STORE LAST WORD
          SB5    X6+B5
          SB5    B5+B5
          LX6    X0,B5
          SA6    SNLINE+A0
 SNWLIN1  IX6    X5+X5       COMPUTE LINE LENGTH IN CHARACTERS
          LX5    3
          IX5    X5+X6
          SX5    X5+B7
          PUT    D,SNLINE,X5 WRITE LINE 
  
 RM       ENDIF 
  
          SA0    B0 
          SB7    B0 
          MX0    0
          EQ     SNWLIN 
 SNSCH    SPACE  4
**        SNSCH - STORE SINGLE CHARACTER. 
*         ENTRY  (X0) = CURRENT WORD. 
*                (X5) = CHARACTER RIGHT JUSTIFIED WITH 00 FILL. 
*                (B7) = NUMBER OF CHARACTERS IN X0. 
*                (A0) = NUMBER OF WORDS IN LINE NOT COUNTING (X0).
*         EXIT   (X0) = NEW CURRENT WORD. 
*                (B7) = UPDATED CHARACTER COUNT.
*                (A0) = UPDATED WORD COUNT. 
  
  
 SNSCH1   SB7    B7+10
 SNSCH    PS                 RETURN EXIT
          LX0    6
          SB7    B7-9 
          BX0    X5+X0
          NZ     B7,SNSCH1
          BX6    X0 
          MX0    0
          SA6    SNLINE+A0
          SA0    A0+B1
          EQ     SNSCH
  
  
 SNLCM    BSSZ   5           LCM POINTER AND WORK AREA
  
  
          QUAL   *
 DEBUG    ENDIF 
 ACL      TITLE  COMMON AND UTILITY SUBROUTINES.
**        ACL - ADJUST LOW CORE LIMIT OF TABLES.
*         ENTRY  (X1) = NEW LOW LIMIT.
  
  
 ACL      PS                 RETURN EXIT
          SA2    LOCORE 
          IX6    X2-X1
          PL     X6,ACL1     IF NEW LOW LIMIT IS LOWER
          BX1    -X6
          SA6    ACLA 
          MANAGE MEMORY,X1   AUGMENT MEMORY BY REQUIRED AMOUNT
          SA2    ACLA 
          IX6    X3+X2       REMOVE EXCESS ALLOCATION 
          SA6    A3 
          SA1    LOCORE 
          SA4    CP.NFLS
          IX6    X1-X2
          SX0    X4-10
          IX7    X0-X6
          SA6    A1 
          SA7    SIZCORE
          RJ     MTU         PACK TABLES UP 
          EQ     ACL         RETURN 
  
 ACL1     SA3    SIZCORE     ADJUST CORE DESCRIPTORS
          IX7    X3+X6       AUGMENT CORE SIZE
          BX6    X1          RESET LOW CORE ADDRESS 
          SA7    A3 
          SA6    A2 
          EQ     ACL         RETURN 
  
 ACLA     DATA   0           NEW LOW LIMIT
 ADDWORD  SPACE  4
**        ADDWORD - ADD ONE WORD TO END OF MANAGED TABLE. 
*         ENTRY  (X1) = DATUM.
*                (A0) = TABLE INDEX.
*         MACRO FORM    ADDWORD  TABNAM      ALSO AVAILABLE.
*         EXIT   (X1) = DATUM.
*         EXIT   (X6) = DATUM.
  
  
 ADDWORD1 SA6    ADDWORDT 
          RJ     ALC
          IX3    X2+X3
          SA1    ADDWORDT 
          BX6    X1 
          SA6    X3-1 
  
 ADDWORD  PS                 RETURN EXIT
          BX6    X1 
          SX1    B1 
          EQ     ADDWORD1 
  
 ADDWORDT DATA   0           TEMPORARY STORAGE
 ALC      SPACE  4
**        ALC - TABLE MANAGER AND ALLOCATOR.
*         ALLOCATOR WILL MOVE TABLES TO ACQUIRE ROOM.  ALSO MAY DUMP
*         INTERMEDIATE OR CROSS-REFERENCES ONTO SCRATCH FILE. 
*         ENTRY  (A0) = TABLE INDEX.
*                (X1) = CHANGE (+ OR -) TO TABLE SIZE.
*         EXIT   (X2) = ORIGIN OF TABLE.
*                (X3) = NEW LENGTH OF TABLE.
  
  
 ALCX     SA2    ORIGINS+A0  RECLAIM VALUES FOR EXIT REPLY
          SA3    SIZES+A0 
  
 ALC      PS                 RETURN EXIT
 ALC1     SB2    NTABLES     PRESET INDEX REGISTERS 
          SA2    ORIGINS+A0  CURRENT ORIGIN 
          SA3    A2+B2       CURRENT LENGTH 
          SA4    A2+B1       NEXT TABLE ORIGIN
          IX6    X1+X3       NEW SIZE 
          IX0    X4-X2       TEST IF ROOM FOR EXPANSION 
          IX0    X0-X6
          NG     X0,ALC2     JUMP TO RE-ALLOCATE CORE 
          SA6    A3          STORE NEW SIZE 
          BX3    X6 
          EQ     ALC         RETURN 
  
*         MOVE TABLES.
  
 ALC2     SA2    SIZCORE     SEE IF ENOUGH ROOM 
          BX4    X1 
          SB7    B2-B1
 ALC3     SB7    B7-B1
          SA5    SIZES+B7 
          IX4    X4+X5
          NZ     B7,ALC3     LOOP 
          SA3    PASS 
          SB7    X3 
          IX0    X2-X4
          SB4    X4          (B4) = TOTAL LENGTH
          SB7    -B7
          SA2    LSTTHOU
          SA4    INTERIO
          ZR     X2,ALC4     IF NOT USING UP LAST 1000B WORDS 
          PL     X0,ALC5     ENOUGH SPACE FOR ENTRY 
          JP     ALCAA+B7    ELSE B7 = -PASS
  
 +        EQ     ALC18       PASS 3 - GET RID OF REFERENCES 
+         ZR     X4,ALC10A
          EQ     ALC13       PASS 2 - TABLE OVERFLOW MESSAGE
+         ZR     X4,ALC10A
          EQ     ALC17       PASS 1 - TABLE OVERFLOW MESSAGE
 ALCAA    EQ     LST7A       PASS 0 - INSUFF. FL FOR SYSTEM TEXT MESSAGE
  
 ALC4     SX3    X0-1000B 
          NG     X3,ALC10    IF < 1000 WORDS LEFT 
 ALC5     SB6    X1          (B6) = REQUESTED LENGTH
          SB5    X0          (B5) = SPACE AVAILABLE 
          RJ     MTD         MOVE TABLES DOWN TO LOW CORE 
          SB3    ORIGINS     RE-ALLOCATE UPWARDS
          SA3    SIZES+A0    INCREMENT SIZE 
          SX6    X3+B6
          SA6    A3 
          SA1    LOCORE 
          SA2    SIZCORE
          IX0    X1+X2       X0 = LWA+1 OF CORE 
          SB6    B2-B1
 ALC6     SB6    B6-B1       DECREMENT TABLE POINTER
          SA2    B3+B6       TABLE ORIGIN 
          SA1    A2+B2       TABLE LENGTH 
          SX4    B5          SPACE AVAILABLE
          SX3    B2-B1       NUMBER OF TABLES 
          AX5    X4,B1
          IX6    X4/X3
          ZR     B4,ALC7     IF NO LENGTH 
          SX3    B4          TOTAL LENGTH 
          DX7    X5*X1
          AX6    1
          IX7    X7/X3
          IX6    X6+X7
 ALC7     IX6    X0-X6
          UX1    X1 
          IX7    X6-X1
          BX3    X7 
          SA7    A2          SET NEW ORIGIN 
          LX0    X7 
          BX4    X2-X3
 +        ZR     X4,*+1      IF NO MOVE REQUESTED 
          RJ     MOVE 
          NE     B6,B1,ALC6  LOOP 
          SA3    LOCORE 
          SA2    B3          FETCH FWA
          SA1    A2+B2       FETCH SIZE 
          BX6    X3 
          SA6    A2 
          BX4    X2-X3
          ZR     X4,ALC8     IF NO MOVE REQUIRED
          RJ     MOVE 
 ALC8     RJ     ASU         ACCUMULATE STORAGE USED
          EQ     ALCX        RETURN 
  
*         CORE OVERFLOW.
  
 ALC10    SX6    A0          SAVE ENTRY CALL VALUES 
          BX7    X1 
          SA6    ALCC 
          SA7    A6+B1
          SA4    CP.NFLS     CURRENT FL                                  F4810B 
          SA2    MIDFLN      FL AT WHICH TABLES WILL BE DUMPED TO FILES  F4810B 
          IX4    X2-X4                                                   F4810B 
          MI     X4,ALC10A   IF READY TO DUMP TABLES                     F4810B 
          RJ     RFL         ELSE, REQUEST MORE CENTRAL MEMORY           F4810B 
          NZ     X3,ALC15    IF REQUEST COMPLETED, RESTORE AND TRY AGAIN F4810B 
 ALC10A   SA4    INTERIO     ELSE, TRY TO DUMP TABLES TO FILES           F4810B 
          JP     ALCB+B7
  
 +        EQ     ALC10B      PASS 3 - TRY TO GET MORE FL
 +        ZR     X4,ALC14    PASS 2 - IF INTERMEDIATE IN CORE 
          EQ     ALC11
 +        ZR     X4,ALC14    PASS 1 - IF INTERMEDIATE IN CORE 
 ALCB     EQ     ALC10B      PASS 0 - TRY TO GET MORE FL
  
 ALC10B   SA1    ALCC+1      GET REQUESTED TABLE INCREASE 
          RJ     RFL         MAKE LAST ATTEMPT TO GET MORE FL.
          EQ     ALC15       LSTTHOU.NE.0 INDICATES FAILURE OF REQUEST
  
*         PASS 2 OVERFLOW.
  
 ALC11    SA2    L.COMTAB    TRY DUMPING COMMON AND EXTERNAL            S005   7
          SA3    L.LNKTAB    LINKAGE TABLES TO BINARY OUTPUT            S005   8
          SA4    L.EXTAB                                                S005   9
          SB2    X2                                                     S005  10
          GT     B2,B1,ALC11A IF COMMON TABLE NOT EMPTY                 S005  11
          SB3    X3                                                     S005  12
          SB4    X4+B1                                                  S005  13
          LE     B3,B4,ALC12  IF NO EXTERNAL LINKAGES                   S005  14
 ALC11A   RJ     /PASS2/DLAST STRIP THOSE TABLES                        S005  15
          EQ     ALC15       AND TRY AGAIN
  
 ALC12    SA1    L.REFTAB    TRY TO DUMP REFERENCES TO DISK 
          ZR     X1,ALC10B   IF NO REFRENCES TRY TO GET MORE FL.
          SA2    O.REFTAB 
  
 RM       IFEQ   CP#RM,0
          WRITEW R,X2,X1     DUMP REFERENCES
 RM       ELSE
          FETCH  R,OC,X3
          SX6    X3-#YES# 
          ZR     X6,ALC12A   IF FILE IS ALREADY OPEN
          OPENM  R,I-O,R
          SA1    L.REFTAB 
          SA2    O.REFTAB 
 ALC12A   IX3    X1+X1
          LX1    3
          IX7    X1+X3
          PUTP   R,X2,X7     DUMP REFERENCES
 RM       ENDIF 
  
          SX6    B1 
          MX7    0
          SA6    /PASS2/REFIO 
          SA7    L.REFTAB 
          EQ     ALC15
  
 ALC13    SA1    =10HPASS 2 TAB 
          BX6    X1 
          SA6    ASMK 
          EQ     ALC17
  
*         DUMP INTERMEDIATE TO DISK.
  
 ALC14    BSS    0                                                       CPS135 
  
 RM       IFEQ   CP#RM,0
  
          SX2    S           ENSURE SCRATCH FILE IS NOT BUSY             CPS135 
          RECALL X2                                                      CPS135 
          SX2    S
          REWIND X2,R        INSURE FILE IS POSITIONED AT BOI.
          SA1    O.INTER     ORIGIN OF INTERMEDIATE TABLE                CPS135 
          SA3    L.INTER     ITS LENGTH                                  CPS135 
          MX6    0
          SX7    B1 
          SA6    A3          ZERO LENGTH OF INTERMEDIATE
          SA7    A4          SET INTERMEDIATE FLAG
          SX0    B7+B1
          SX2    S
          WRITEW X2,X1,X3 
          ZR     X0,ALC15    IF PASS 1
          WRITER X2 
          REWIND X2 
          READ   X2 
  
 RM       ELSE
  
          FETCH  S,OC,X2
          SX6    X2-#YES# 
          ZR     X6,ALC14A   IF FILE IS ALREADY OPEN
          OPENM  S,I-O,R
 ALC14A   SA1    O.INTER     ORIGIN OF INTERMIDATE TABLE                 CPS135 
          SA3    L.INTER     ITS LENGTH                                  CPS135 
          SX2    S
          REWINDM X2,R       INSURE FILE IS POSITIONED AT BOI.
          MX6    0                                                       CPS135 
          SX7    B1 
          SA6    A3          ZERO LENGTH OF INTERMEDIATE
          IX4    X3+X3
          LX3    3
          SA7    INTERIO     SET INTERMEDIATE FLAG                       CPS135 
          IX3    X3+X4
          PUT    S,X1,X3
          SA3    PASS 
          SB7    X3 
          EQ     B7,B1,ALC15 IF PASS 1
          PUT    S,BLANKS,10 JUNK WORD FOR RINTER READ AHEAD
          REWINDM S 
  
 RM       ENDIF 
  
 ALC15    SA2    ALCC        RESTORE ENTRY VALUES 
          SA1    A2+B1
          SA0    X2 
          EQ     ALC1        AND TRY AGAIN
  
 ALC17    BSS    0
          MESSAGE ASMJ,,R     *ASSEMBLY ABORTED - PASS N TABLE*          F4810B 
          MESSAGE ASML,,R    *OVERFLOW ASSEMBLING XXXXXXX*
          RJ     RPD         RESTORE DEFAULT PRINT DENSITY IF NECESSARY  F4810A 
          SA2    ALCC 
          SA3    A2+B1
          ABORT  ,NODUMP
  
*         PASS 3 OVERFLOW.
  
 ALC18    SA1    /PASS2/LOSTREF  UPDATE LOSTREF AND DISCARD MEMORY
          SA2    L.MEMORY 
          IX6    X1+X2
          SX7    B0 
          SA6    A1 
          SA7    A2 
          EQ     ALC15       EXIT 
  
 ALCC     DATA   0,0         TEMPORARY STORAGE FOR OVERFLOW 
 ASU      SPACE  4
**        ASU - ACCUMULATE STORAGE USED.
*         (A0) IS PRESERVED.
  
  
 ASU      PS                 RETURN EXIT
          SB7    NTABLES-4   COUNT STORAGE USED 
          SA3    LOCORE 
          SA2    MAXCORE
          SA1    SIZES+1
 ASU1     SB7    B7-B1       IGNORE INTER AND REFTAB
          IX3    X3+X1
          SA1    A1+B1
          NZ     B7,ASU1     LOOP 
          SA1    A1+B1       ADD IN L.MEMORY
          IX6    X3+X1
          IX2    X6-X2
          NG     X2,ASU      IF NEW MAX < OLD MAX 
          SA6    A2 
          EQ     ASU         RETURN 
 ATS      SPACE  4
**        ATS - ACCUMULATE TOTAL STORAGE USED.
  
  
 ATS      PS                 RETURN EXIT
          SA1    MAXCORE
          SA2    CP.MAXFL 
          IX3    X2-X1
          BX6    X1 
          PL     X3,ATS1     IF OLD MAX \ NEW MAX                       S028 297
          SA6    A2                                                     S028 298
 ATS1     SA1    ALCM        ECS/LCM USED                               S028 299
          SA2    BLCM                                                   S028 300
          IX3    X2-X1                                                  S028 301
          BX6    X1                                                     S028 302
          PL     X3,ATS      IF OLD MAX \ NEW MAX 
          SA6    A2 
          EQ     ATS         RETURN 
 CBC      SPACE  4
**        CBC - CHECK BASE CHARACTER. 
*         ASSUMED NUMBER RADIX IS CHANGED TO THAT SPECIFIED.
*         ENTRY  (X1) = CHARACTER OR ASTERISK OR BLANK. 
*         EXIT   (X1) = CHARACTER.
*                (X6) < 0 IF ERROR. 
  
  
 CBC      PS                 RETURN EXIT
          SB7    X1-1R* 
          SA2    CBCA+2 
          SB6    X1-1R
          ZR     B7,CBC3     IF ASTERISK
          ZR     B6,CBC4     IF BLANK 
          SB7    3
 CBC1     UX6,B6 X2          SEARCH LIST OF VALID BASE LETTERS
          SB5    X1+B6
          SB7    B7-B1
          SA2    A2-B1
          ZR     B5,CBC2     IF FOUND 
          NZ     B7,CBC1
          SX7    B1          NOT FOUND, SET *A* ERROR AND RETURN
          MX6    1
          SA7    EFLG 
          SA7    AERR 
          EQ     CBC
 CBC2     SA1    BASESTK
          SA2    ABASE
          SX7    X6 
          AX6    18 
          SA7    NBASE       STORE NEW RADICES
          SA6    MBASE
          SX7    B7 
          BX6    X2 
          SA7    A2 
          RJ     PUSH        PUSH DOWN BASE STACK 
          SA1    ABASE
          SA2    CBCA+X1
          UX6,B6 X2 
          SX1    -B6         RESTORE (X1) 
          EQ     CBC
 CBC3     SA1    BASESTK
          RJ     PULL        PUSH UP BASE STACK 
          SA2    CBCA+X6
          UX7,B7 X2 
          SX1    -B7         (X1) = CHARACTER 
          SA6    ABASE
          SX6    X7 
          AX7    18 
          SA6    NBASE       SET RADICES
          SA7    MBASE
          EQ     CBC         RETURN 
 CBC4     SA1    ABASE
          SA2    CBCA+X1
          UX6,B7 X2 
          SX1    -B7         (X1) = CURRENT BASE
          EQ     CBC         RETURN 
  
 CBCA     VFD    2/0,10/-1RD,30/10,18/10     -CHAR, MBASE, NBASE
          VFD    2/0,10/-1RO,30/8,18/8
          VFD    2/0,10/-1RM,30/10,18/8 
 CCC      SPACE  4
**        CCC - CHECK CODE CHARACTER. 
*         CHARACTER CODE TYPE IS CHANGED TO THAT SPECIFIED. 
*         ENTRY  (X1) = CHARACTER OR ASTERISK OR BLANK. 
*         EXIT   (X1) = CHARACTER.
*                (X6) < 0 IF ERROR. 
  
  
 CCC      PS                 RETURN EXIT
          SB7    X1-1R* 
          SA2    CCCA+5 
          SB6    X1-1R
          ZR     B7,CCC3     IF ASTERISK
          ZR     B6,CCC4     IF BLANK 
          SB7    6
 CCC1     UX6,B6 X2          SEARCH LIST OF VALID CODE LETTERS
          SB5    X1+B6
          SB7    B7-B1
          SA2    A2-B1
          ZR     B5,CCC2     IF FOUND 
          NZ     B7,CCC1
 CCC1A    BSS    0
          SX7    B1          NOT FOUND, SET *A* ERROR AND RETURN
          MX6    1
          SA7    EFLG 
          SA7    AERR 
          EQ     CCC
 CCC2     SX1    B7-5 
          SA2    PPTYPE      (X2) = 0 IF 180 PP ASSEMBLY
          SX2    X2+3 
          NZ     X1,CCC2A    IF NOT CODE *N*
          NZ     X2,CCC1A    *N* VALID FOR 180 PP ASSEMBLY ONLY 
          SA3    /DATA/STCZ  SET FOR CHARACTER STORE OF 8-BIT/ASCII 
          EQ     CCC2B
  
 CCC2A    NZ     X2,CCC2C    IF NOT 180 PP ASSEMBLY 
          SA3    /DATA/STCW  SET FOR CHARACTER STORE OF 6-BIT/NON-ASCII 
 CCC2B    BX7    X3          SET CHARACTER STORE
          SA7    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
 CCC2C    SA1    CODESTK
          SA2    CT+1 
          SX7    B7 
          SA6    A2-B1       STORE NEW CODE 
          SA7    A2 
          BX6    X2 
          RJ     PUSH        PUSH DOWN CODE STACK 
          SA1    CT+1 
          SA2    CCCA+X1
          UX6,B6 X2 
          SX1    -B6         RESTORE (X1) 
          EQ     CCC         RETURN 
 CCC3     SA1    CODESTK
          RJ     PULL        PUSH UP CODE STACK 
          SA2    CCCA+X6
          UX7,B7 X2 
          SX1    -B7         (X1) = LETTER
          SA6    CT+1        SET CODE TYPE
          SA7    A6-B1
          SA2    PPTYPE 
          SX2    X2+3 
          NZ     X2,CCC      RETURN IF NOT 180 PP ASSEMBLY
          SA3    /DATA/STCZ  SET FOR CHARACTER STORE OF 8-BIT/ASCII 
          SX7    X6-5 
          ZR     X7,CCC3A    IF SETTING BACK TO CODE *N*
          SA3    /DATA/STCW  SET FOR CHARACTER STORE OF 6-BIT/NON-ASCII 
 CCC3A    BX7    X3          SET CHARACTER STORE
          SA7    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          EQ     CCC         RETURN 
 CCC4     SA1    CT+1 
          SA2    CCCA+X1
          UX6,B7 X2 
          SX1    -B7         (X1) = CURRENT CODE
          EQ     CCC         RETURN 
  
 CCCA     VFD    2/0,10/-1RD,48/0        -CHAR, CT VALUE
          VFD    2/0,10/-1RE,48/9 
          VFD    2/0,10/-1RI,48/18
          VFD    2/0,10/-1RA,48/27
          VFD    2/0,10/-1RO,48/36
          VFD    2/0,10/-1RN,48/45
 CDEC     SPACE  4
**        CDEC - CONVERT DECIMAL NUMBER.
*         ENTRY  (X1) = DECIMAL NUMBER. 
*         EXIT   (X6) = DISPLAY CODE FOR DECIMAL NUMBER.
  
  
 CDEC     PS                 RETURN EXIT
          SA2    =0.10000000001P48
          SA3    =10.0P0
          SA4    =10H0000000000 
          SB6    6
          PX1    X1 
          SB7    X3 
          BX6    X4 
 CDC1     DX4    X1*X2
          FX1    X1*X2
          SB7    B7-B1
          FX5    X4*X3       CALCULATE REMAINDER
          SX0    X5 
          IX6    X6+X0
          LX6    54 
          NZ     B7,CDC1     LOOP 
          EQ     CDEC        RETURN 
 CIF      SPACE  4
**        CIF - CHECK INPUT FORMAT. 
*         ENTRY  (X2) = FET/FIT ADDRESS.
*                (A0) = FWA OF CARD BUFFER. 
*         EXIT   (AMODE) = INPUT FILE FORMAT. 
*                (CARD BUFFER) = FIRST CARD.
*                (EOFINP) " 0 IF NO DATA. 
*         X2 AND A0 ARE PRESERVED.
  
  
 CIF      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          MX6    0
          SA6    A0+10
          RJ     /PASS1/RNC  READ FIRST CARD OR 7700 HEADER WORD
          SA1    A0 
          LX1    6
          SB7    X1-77B 
          LX1    18 
          NZ     B7,CIF      IF NOT COMPRESSED SOURCE INPUT 
          SB7    X1          (I.E., FIRST CHARACTER NOT 77B)
          AX1    24 
          SX6    B1+B1       CP.IFORM = +2 (UPDATE) 
          ZR     B7,CIF1     IF WORD COUNT IN HEADER WORD IS ZERO 
          SX6    B1          CP.IFORM = +1 (MODIFY) 
          ZR     X1,CIF1     IF REMAINDER OF HEADER WORD IS ZERO
          SX7    64B
          LX7    24          CHECK FOR 0064B IN BITS 35-24
          SX6    3           CP.IFORM = +3 (MODIFY 64-CHAR) 
          BX1    X1-X7
 CIF1     NZ     X1,CIF      IF NOT COMPRESSED
          SA6    CP.IFORM    SET INPUT FORMAT 
  
 RM       ELSE
  
          MX6    0
          SX7    A0 
          SA6    A0+10
          SA7    T6RM1       SAVE FWA OF CARD BUFFER
          SA0    X2 
          FETCH  X2,RT,X1    CHECK FOR RECORD TYPE Z
          SB7    X1-3 
          ZR     B7,CIF4     IF RT=Z, INPUT IS NOT COMPRESSED 
          SX2    A0 
          SA1    T6RM1       FWA OF CARD BUFFER 
          GETP   X2,X1,10    READ FIRST WORD
          SX2    A0 
          FETCH  X2,FP,X4 
          SX0    EOD
          BX6    X0*X4
          SA6    EOFINP 
          NZ     X6,CIF5     IF END OF DATA 
 +        ZR     X4,*+1      IF NOT END OF RECORD 
          SX4    1
          SKIPBL X2,X4       BACKSPACE OVER WORD
          SA4    T6RM1
          SX2    A0 
          SA1    X4          FETCH WORD 
          BX3    X1 
          AX1    -6 
          NZ     X1,CIF4     IF NOT COMPRESSED SOURCE INPUT 
          PL     X1,CIF4     (I.E., FIRST CHARACTER NOT 77B)
          MX0    -36
          SX6    B1+B1       CP.IFORM = +2 (UPDATE) 
          BX4    -X0*X3 
          SA5    =6R
          NZ     X4,CIF1     IF NOT ZEROS IN BITS 35-00 
          LX3    24 
          SX5    X3 
          EQ     CIF2 
 CIF1     BX4    X4-X5
          AX3    18                                                     S028 304
          NZ     X4,CIF4     IF NOT BLANKS IN BITS 35-00
          BX4    -X0*X3 
          BX5    X5-X4
 CIF2     NZ     X5,CIF4     IF NOT ZEROS NOR BLANKS IN BITS 53-36
          SA6    CP.IFORM    SET INPUT FORMAT 
 CIF3     SA1    CP.IFORM                                               S028 306
          SA4    T6RM1                                                  S028 307
          SB7    X1-2                                                   S028 308
          ZR     B7,CIF3A    IF UPDATE COMPRESSED COMPILE FILE          S028 309
          GETP   X2,X4,10    SKIP HEADER WORD 
          EQ     CIF5 
 CIF3A    GETP   X2,X4,30                                               S028 311
          SA4    T6RM1       MOVE HEADER WORDS FOR FIRST CARD           S028 312
          SA1    X4+B1       TO END OF CARD BUFFER AREA                 S028 313
          SA3    A1+B1                                                  S028 314
          BX6    X1                                                     S028 315
          LX7    X3                                                     S028 316
          SA6    X4+14                                                  S028 317
          SA7    A6+B1                                                  S028 318
          EQ     CIF5                                                   S028 319
 CIF4     STORE  X2,MRL=160  NOT COMPRESSED, REDUCE MAX RECORD LENGTH 
 CIF5     SA4    T6RM1
          SX2    A0          RESTORE (X2) 
          SA0    X4          RESTORE (A0) 
  
 RM       ENDIF 
  
          RJ     /PASS1/RNC  READ FIRST CARD
          EQ     CIF         RETURN 
 CLL      SPACE  4,8
**        CLL - CLEAR LCM AREA TO ZEROS.
*         ENTRY  (X2) = FWA OF AREA.
*                (X3) = LWA+1 OF AREA.
*         CALLS  RLC, WLC.
  
  
 CLL      PS                 RETURN EXIT
          IX7    X3-X2
          MI     X7,*+1S17   IF FWA IS GREATER THAN LWA+1 
          SX1    B0 
          BX4    X2 
          SX2    LCMB        CLEAR BUFFER BY READING FROM RAL+0 
          SX3    100B 
          RJ     RLC
 CLL1     SX3    100B        DECREMENT WORD COUNT 
          IX6    X7-X3
          BX1    X4 
          PL     X6,CLL2     IF AT LEAST 100B WORDS REMAIN
          SX6    B0 
          BX3    X7          SET REDUCED WORD COUNT 
 CLL2     SX7    X6 
          IX4    X1+X3       WRITE LCM
          RJ     WLC
          NZ     X7,CLL1     LOOP 
          EQ     CLL         RETURN 
 CLS      SPACE  4
**        CLS - CLEAR SCM AREA TO ZEROS.
*         DISASTER IF FWA IS GREATER THAN LWA.
*         ENTRY  (X2) = FWA OF AREA.
*                (X3) = LWA+1 OF AREA.
*         EXIT   (X6) = (X7) = 0. 
*         USES   X0-X3, A0, A6, A7, B5, B6, B7. 
*         CALLS  PRESET OR RLC. 
  
  
 CLS1     MX1    0           NO LCM, USE PRESET 
          BX7    X7-X7
          RJ     PRESET 
  
 CLS      PS                 RETURN EXIT
          IX7    X3-X2
          SA1    CP.AFLL                                                S028 321
          MI     X7,*+1S17   IF FWA IS GREATER THAN LWA+1 
          ZR     X1,CLS1     IF NO LCM
 CLS2     SX6    X7-100B
          SX3    100B 
          PL     X6,CLS3     IF AT LEAST 100B WORDS REMAIN
          SX6    B0 
          SX3    X7          SET REDUCED WORD COUNT 
 CLS3     SX7    X6 
          SX1    B0          READ LCM STARTING AT RAL+0 
          RJ     RLC
          SX2    X2+100B     INCREMENT SCM ADDRESS
          NZ     X7,CLS2     LOOP 
          EQ     CLS         RETURN 
 COCT     SPACE  4
**        COCT - CONVERT OCTAL NUMBER.
*         ENTRY  (X1) = OCTAL NUMBER. 
*         EXIT   (X6) = DISPLAY CODE FOR OCTAL NUMBER.
  
  
 COCT     PS                 RETURN EXIT
          SB7    10 
          MX0    60-3 
          SX6    B0 
 COCT1    SB7    B7-B1
          BX3    -X0*X1 
          AX1    3
          SX3    X3+1R0 
          IX6    X6+X3
          LX6    54 
          NZ     B7,COCT1 
          EQ     COCT 
 CONDEC   SPACE  4
**        CONDEC - CONVERT INTEGER TO DECIMAL DISPLAY CODE. 
*         ENTRY  (X1) = INTEGER IN LOW ORDER (LESS THAN 2**18). 
*         EXIT   (X6) = DECIMAL FORM WITH LEADING BLANKS. 
*                (B2) = 6*COUNT OF DIGITS IN X6.
*                (B6) = 6.
*         SAVES  A0, A5, A6, X5.
  
  
 CONDEC1  DX4    X1*X2
          FX1    X1*X2
          SB7    X1 
          LX6    54 
          SB2    B2+B6
          FX7    X4*X3       CALCULATE REMAINDER DIGIT
          SX0    X7+B5
          IX6    X0+X6
          NZ     B7,CONDEC1 
          LX6    54 
          LX6    X6,B2       POSITION IN LOW ORDER
  
 CONDEC   PS                 RETURN EXIT
          SA2    =0.1000000001P48 
          SA3    =10.0P0
          SA4    =1H
          SB6    6
          SB5    1R0-1R 
          SB2    B0 
          PX1    X1 
          BX6    X4 
          EQ     CONDEC1
 CONOCT   SPACE  4
**        CONOCT - CONVERT TO OCTAL/HEX.
*         ENTRY  (X1) = INTEGER IN LOW ORDER (LESS THAN 2**30). 
*         EXIT   (X6) = OCTAL FORM WITH LEADING BLANKS. 
  
  
 CONOCT1  BX3    -X0*X1      EXTRACT DIGIT
          AX1    X1,B6
          SB5    X3-10
 +        NG     B5,*+1      IF NOT UPPER HEX DIGIT 
          SX3    B5+1RA-1R0 
          SX7    X3+1R0-1R
          LX3    X7,B7       POSITION DIGIT 
          SB7    B7+6 
          IX2    X2+X3
          NZ     X1,CONOCT1  LOOP 
          LX3    X6,B7
          IX6    X2+X3       ADD SIGN IF MINUS
  
 CONOCT   PS                 RETURN EXIT
          SA4    PPTYPE      CHECK IF HEX CONVERSION
          SB6    3
          MX0    -3 
          SB7    B0 
          SA2    =1H
          MX6    0
          PL     X1,CONOCT2  IF NOT NEGITIVE
          BX1     -X1         COMPLEMENT VALUE
          SX6    1R--1R 
 CONOCT2  PL     X4,CONOCT1  IF NOT HEX ASSEMBLY
          SX4    X4+2 
          MI     X4,CONOCT1  IF NOT BCU/MCU.
          MX0    -4 
          SB6    B6+B1
          EQ    CONOCT1 
 CPS      SPACE  4
**        CPS - CLEAR PUSH-DOWN STACKS. 
  
  
 CPS      PS                 RETURN EXIT
          SA1    STACKPTR 
          MX0    30 
 CPS1     SA2    X1          GET STACK CONTROL WORD 
          AX1    18          MAX ENTRY COUNT
          BX3    X0*X2
          IX6    X3+X1
          SA1    A1+B1
          SA6    A2 
          NZ     X1,CPS1     IF NOT END OF LIST 
          EQ     CPS         RETURN 
 CPTIME   SPACE  4
**        CPTIME - CONVERT CPU TIME.
*         ENTRY  (B7) = ADDRESS OF STARTING TIME. 
*         EXIT   (X6) = *SSSSS.MMM *  ELAPSED CPU TIME. 
  
  
 CPTIME   PS                 RETURN EXIT
          TIME   CPTIMEA     GET CURRENT TIME 
          SA5    B7 
          SA1    CPTIMEA
          IX2    X1-X5       TIME DIFFERENCE
          BX5    X2 
          LX2    -12
          SX3    1000-1S12
 +        MX0    -12
          PL     X2,*+1      IF NO BORROW 
          IX5    X5+X3
          BX1    -X0*X5      MILLISECONDS 
          SX1    X1+1000     FORCE LEADING ZEROS
          RJ     CONDEC      CONVERT TO DECIMAL 
          AX5    12 
          SX1    X5          SECONDS
          SA2    CPTIMEB
          LX6    6
          BX5    X6-X2       CHANGE *1* TO *.*
          RJ     CONDEC      CONVERT SECONDS TO DECIMAL 
          LX6    30 
          BX6    X6-X5
          EQ     CPTIME      RETURN 
  
 CPTIMEA  DATA   0           STORAGE FOR CURRENT TIME 
 CPTIMEB  VFD    36/6R      &1R1&1R.,24/4R
 DFL      SPACE  4                                                       F4810B 
**        DFL - DECREASE FIELD LENGTH.                                   F4810B 
*         REQUESTS FL OF (LWA+1 TABLES + 1000B MGMT SPACE + 10 SLOP)
*         OR OF *MIDFLN* (LARGER OF *MIDFL* AND *CP.AFLS*), WHICHEVER IS
*         GREATER, UNLESS CURRENT FL IS .LE. CALCULATED REQUEST.
*         CLEARS *LSTTHOU* IF REQUEST IS MADE.
                                                                         F4810B 
                                                                         F4810B 
 DFL      PS                 RETURN EXIT                                 F4810B 
          RJ     MTD         MOVE TABLES DOWN                            F4810B 
          SA1    O.MEMORY    ORGIN OF LAST TABLE                         F4810B 
          SA2    L.MEMORY    LENGTH OF LAST TABLE                        F4810B 
          IX1    X1+X2       LWA OF TABLES                               F4810B 
          SX2    1000B+10    LSTTHOU + SLOP 
          IX1    X2+X1       LWA TABLES+FLINC                            F4810B 
          SA4    CP.NFLS     CURRENT FL 
          IX2    X4-X1       COMPARE CURRENT TO CALC. FL
          SX6    0
          MI     X2,DFL      IF CURRENT .LE. CALC FL, EXIT
          SA6    LSTTHOU     CLEAR LAST 1000B FLAG
          SA3    MIDFLN      GET MINIMUM FL. TO BE REDUCED TO 
          IX2    X1-X3       COMPARE TABLE SPACE TO MIDFLN
          PL     X2,DFL1     USE THE GREATER OF THE TWO 
          BX1    X3          MIDFLN 
          IX4    X3-X4       MIDFLN - CURRENT FL
          PL     X4,DFL      IF CURRENT .LE. MIDFLN, EXIT 
 DFL1     MX2    -6          FOR ROUNDING UP
          IX1    X1-X2       FL + 77B 
          BX1    X1*X2       ROUND
          BX1    -X1         SET UP TO MAKE SPECIFIC FL REQUEST          F4810B 
          RJ     RFL         REQUEST (LWA TABLES+FLINC) WORDS CM         F4810B 
          EQ     DFL         RETURN                                      F4810B 
 DIM      SPACE  4
**        DIM - DISPLAY IDENT MESSAGE.
*         ENTRY  (X1) = PROGRAM NAME LEFT JUSTIFIED ZERO FILL.
  
  
 DIM      PS                 RETURN EXIT
          LX1    -6 
          RJ     LJUST
          MX0    -6 
          SB7    10 
          SX2    1R 
          SB6    -60B 
 DIM1     LX7    6
          SB7    B7-B1
          BX6    -X0*X7 
          SX1    X6+B6
          NG     X1,DIM2     IF CHARACTER LEGAL 
          BX7    X0*X7
          IX7    X7+X2
 DIM2     NZ     B7,DIM1     LOOP 
          BX6    X7+X2
          LX6    -6 
          MX0    48 
          BX6    X0*X6
          SA6    ASMM+1 
          MESSAGE ASMM,1,R   *ASSEMBLING XXXXXXX* 
          EQ     DIM         RETURN 
 ENTOP    SPACE  4
**        ENTOP - ENTER OPERATION CODE ENTRY INTO OPTAB.
*         DISASTER IF OVERFLOW. 
*         ENTRY  (X1) = OPCODE NAME (RESTRICT PLEASE TO 48 BITS). 
*                (X2) = EQUIVALENT. 
  
  
 ENTOP1   SA6    ENTOPT      SAVE ENTRY 
          SA7    A6+B1
          SX6    X4+2 
          SA6    A7+B1
          MANAGE OPTAB,2     GET TWO WORDS IN OVERFLOW AREA 
          SA1    ENTOPT 
          SA4    A1+B1
          SA5    A4+B1
          SB7    X2-2 
          SA2    X5+B7       RECLAIM OLD ENTRY IN BASE SECTION
          BX0    X1 
          SA1    A2+B1       AND ITS EQUIVALENT 
          LX6    X2 
          BX7    X1 
          SA6    X3+B7       STORE OLD ENTRY IN NEW POSITION
          SA7    A6+B1
          SX3    X3-2*NOPCT 
          LX3    47 
          BX6    X0+X3
          LX7    X4 
          SA6    X5+B7
          SA7    A6+B1
  
 ENTOP    PS                 RETURN EXIT
          PX0    X1 
          SA4    HASH 
          DX3    X0*X4
          SA5    O.OPTAB
          SX0    2*NOPCT-2
          AX3    47-TLUOPSHF
          BX4    X0*X3
          MX0    12 
          SB7    X5 
          SA5    X4+B7       CHECK BASE TABLE ENTRY 
          BX6    X1 
          LX7    X2 
          NZ     X5,ENTOP1   IF ALREADY OCCUPIED
          SA6    A5          OCCUPY BASE ENTRY
          SA7    A5+B1
          EQ     ENTOP
  
 ENTOPT   BSS    3           TEMPORARY STORAGE
 ENTSYMT  SPACE  4
**        ENTSYMT - ENTER SYMBOL INTO SYMBOL TABLE. 
*         ENTRY  (X1) = SYMBOL. 
*                (X2) = EQUIVALENT. 
*         EXIT   (X1) = SYMBOL UNTOUCHED. 
  
  
 ENTSYMTX SA5    SYMCNT      UP SYMBOL COUNT
          SX7    X5+B1
          SA7    A5 
  
 ENTSYMT  PS                 RETURN EXIT
          SA3    HASH        HASHING CONSTANT 
          SA5    QVAL        QUALIFIER VALUE
          BX6    X1 
          PX0    X1 
          SX7    B0 
          AX6    36 
          DX4    X3*X0       MULTIPLY SYMBOL BY HASHING CONSTANT
          SB7    X6-2R'?
          BX6    X1+X5       ADD QUALIFIER VALUE TO SYMBOL
          LX5    12 
          SX0    NSYMT*2-2   MASK FOR BASE INDEX
          SB6    X5 
          AX4    47-SHIFTQ
          SA5    O.QVTAB
          SB6    B6-B1
          BX3    X0*X4       BASE INDEX 
          SA4    O.SYMTAB 
          SB5    X3 
          ZR     B7,ENS1     IF INVENTED SYMBOL 
          NG     B6,ENS2     IF BLANK QUALIFIER 
          SA5    X5+B6
          NO
          PL     X5,ENS2     IF NOREF FLAG NOT SET FOR QUALIFIER
 ENS1     SX7    B1 
          SB0    0           SET NOREF FLAG IN SYMTAB ENTRY 
          LX7    35 
 ENS2     SX0    X4+B5       BASE TABLE ENTRY 
          RX4    X0 
          BX7    X2+X7
          NZ     X4,ENTSYMT1 IF BASE ENTRY OCCUPIED 
          WX6    X0          OCCUPY BASE ENTRY
          SX0    X0+B1
          WX7    X0 
          EQ     ENTSYMTX 
 ENTSYMT1 SA6    ENTSYMTT    SAVE SYMBOL, EQUIV AND HASHED KEY
          SA7    A6+B1
          BX6    X3 
          SA6    A7+B1
  
 RM       IFNE   CP#RM,7
          MANAGE SYMTAB,2 
          SX4    X3-2        INDEX OF NEW ENTRY 
 RM       ELSE
          SX1    B1+B1
          RJ     ILF         INCREASE LCM FIELD LENGTH
          SA4    L.SYMTAB 
          SA2    O.SYMTAB 
          MI     X6,ILC      IF INSUFFICIENT LCM AVAILABLE
          IX7    X4+X1
          SA7    A4          UPDATE L.SYMTAB
 RM       ENDIF 
  
          SB7    X2+B1       STORE NEW ENTRY
          SA3    ENTSYMTT+2 
          SB6    42 
 ENTSYMT2 SX0    B7+X3       SEARCH SYMBOL TABLE
          RX5    X0 
          AX3    X5,B6
          NZ     X3,ENTSYMT2 LOOP TO END OF CHAIN 
          LX6    X4,B6
          BX6    X5+X6       OR IN NEW CHAIN NUMBER 
          WX6    X0 
          SA2    A3-B1
          SA1    A2-B1
          SX0    B7+X4       STORE NEW ENTRY
          LX7    X2 
          BX6    X1 
          SX3    X0-1 
          WX7    X0 
          WX6    X3 
          EQ     ENTSYMTX 
  
 ENTSYMTT BSS    3           TEMPORARY STORAGE
  
 HASH     DATA   2525001001001001.BP0 
 GETCH    SPACE  4
**        GETCH - GET NEXT CHARACTER FROM CARD IMAGE. 
*         UPDATES COLUMN, AND CHECKS AGAINST LASTCOL. 
*         EXIT   (X1) = (X6) = NEXT CHARACTER.
*                (X2) = NEGATIVE IF END OF STATEMENT. 
  
  
 GNC1     SA6    A1          STORE NEW COLUMN NUMBER
          NO
          SA1    X6+CARD-1   FETCH NEW CHARACTER
 GNC2     BX6    X1 
          NO
          SA6    CHAR 
  
 GETCH    PS                 RETURN EXIT
          SA1    COLUMN      SEE WHERE WE ARE 
          SA2    LASTCOL     COMPARED TO END OF STATEMENT 
          SX6    X1+B1       INCREMENT COLUMN NUMBER
          IX2    X2-X1
          SX1    1R 
          PL     X2,GNC1
          EQ     GNC2 
 ILC      SPACE  4,8
**        ILC - INSUFFICIENT LCM AVALILABLE.
*         ENTRY  (X7) = FIELD LENGTH NEEDED (SET BY *ILF*). 
  
  
 RM       IFEQ   CP#RM,7
  
 ILC      BX1    X7          CONVERT TO OCTAL 
          RJ     CONOCT 
          SA1    ILCA        INSERT IN MESSAGE
          MX0    -24
          LX6    24 
          BX6    X0*X6
          BX1    -X0*X1 
          BX6    X1+X6
          SA6    A1 
          MESSAGE ILCA,,R 
          SA1    PASS 
          SB7    X1-2 
          ZR     B7,ALC13    IF PASS 2
          JP     ALC17       GO ISSUE TABLE OVERFLOW MESSAGE
  
 ILCA     DATA   C* 00000B LCM NEEDED TO CONTINUE. *
  
 RM       ENDIF 
 ILF      SPACE  4,8                                                    S028 323
**        ILF - INCREASE LCM FIELD LENGTH.                              S028 324
*         ENTRY  (X1) = WORD COUNT OF INCREASE.                         S028 325
*         EXIT   (X1) = UNCHANGED.                                      S028 326
*                (X6) = (LCMEND) = UPDATED IF POSSIBLE.                 S028 327
*                (X6) < 0 IF INCREASE IS NOT POSSIBLE.                  S028 328
                                                                        S028 329
                                                                        S028 330
 ILF      PS                 RETURN EXIT                                S028 331
          SA3    LCMEND                                                 S028 332
          SA2    CP.AFLL                                                S028 333
          IX6    X3+X1                                                  S028 334
          IX2    X6-X2                                                  S028 335
          PL     X2,ILF1     IF FIELD LENGTH INCREASE NEEDED            S028 336
          SA6    A3          UPDATE (LCMEND)                            S028 337
          EQ     ILF2                                                   S028 338
 ILF1     SA2    FLLF                                                   S028 339
          SX7    9+1S12      ADD 10 FOR SLOP AND ROUND UP               S028 340
          IX7    X6+X7       TO A MULTIPLE OF 10000B                    S028 341
          BX3    X6                                                     S028 342
          SX4    MFLL                                                   S028 343
          AX7    12                                                     S028 344
          SX6    -B1         (X6) < 0                                   S028 345
          LX7    12                                                     S028 346
          IX4    X4-X7                                                  S028 347
          NZ     X2,ILF      RETURN IF FIXED FLL MODE                   S028 348
          MI     X4,ILF      RETURN IF GREATER THAN MAX FLL ALLOWED     S028 349
          BX6    X3                                                     S028 350
          LX7    30                                                     S028 351
          SA6    A3          UPDATE (LCMEND)                            S028 352
          BX4    X1                                                     S028 353
          SA7    CP.AFLL                                                S028 354
          MEMORY ECS,CP.AFLL,R     REQUEST FIELD LENGTH                 S028 355
          SA2    A7                                                     S028 356
          BX6    X3          (X6) = (LCMEND)                            S028 357
          LX1    X4                                                     S028 358
          BX7    X2                                                     S028 359
          AX7    30          UPDATE (CP.AFLL)                           S028 360
          SA7    A2                                                     S028 361
 ILF2     SA3    ALCM                                                   S028 362
          IX4    X3-X6                                                  S028 363
          PL     X4,ILF      IF OLD MAX \ NEW (LCMEND)                  S028 364
          SA6    A3                                                     S028 365
          EQ     ILF         RETURN                                     S028 366
 RM       IFEQ   CP#RM,0
 LDHDR    SPACE  4
**        LDHDR - LDSET HEADER. 
*         CONTROL WORD FOR 7000 (LDSET) TABLE GENERATOR.
*         ENTRY  K.TLDR = POSITION OF LAST CONTROL WORD 
*         EXIT   K.TLDR = POSITION OF CURRENT 70 TABLE (L.TLDR-1) 
*                NEW CONTROL WORD ADDED TO TLDR.
*                WC INSERTED IN LAST CONTROL WORD FOR TABLE JUST
*                FILLED.
*         USES   A - 2,3,4,7
*                B - 2,4
*                X - 1,2,3,4,7
  
 LDHDR    PS                 RETURN EXIT
          SA2    L.TLDS      LENGTH OF TABLE
          SA3    K.TLDS      POSITION OF LAST CONTROL WORD
          MX1    3           7000 TABLE 
          ZR     X2,LDHDR1   IF FIRST 7000 TABLE
          IX4    X2-X3       WORD COUNT OF TLDS SINCE LAST CONTROL WORD 
          SB2    36          SHIFT FOR WORD COUNT 
          SX4    X4-1        WORD COUNT OF PREVIOUS TABLE 
          LX4    X4,B2       POSITION WC
          BX7    X1+X4       INSERT WC IN CONTROL WORD
          SA4    O.TLDS      ORIGIN ADDRESS 
          IX4    X4+X3
          SA7    X4          REPLACE CONTROL WORD OF PREVIOUS TABLE 
 LDHDR1   BX7    X2          POSITION OF NEW CONTROL WORD 
          SA7    A3          K.TLDS 
          ADDWORD TLDS       NEW CONTROL WORD GETS CORRECT WC LATER 
          EQ     LDHDR       RETURN 
 RM       ENDIF 
 MOVE     SPACE  4
**        MOVE - MOVE BLOCK OF DATA.
*         MOVE MOVES EITHER UPWARDS OR DOWNWARDS TO AVOID OVER-STORES.
*         ENTRY  (X1) = WORD COUNT. 
*                (X2) = SOURCE ADDRESS. 
*                (X3) = DESTINATION ADDRESS.
  
  
 MOVEI    SB7    -2          UPWARD MOVE
          SX2    X2+B7
          SX3    X3+B7
          SB7    B1+B1
          ZR     X6,MOVER    IF EVEN NUMBER OF WORDS
          SA5    X2+B7       MOVE THE ONE ODD WORD
          IX2    X2+X6
          BX7    X5 
          SA7    X3+B7
          IX3    X3+X6
 MOVER    ZR     X1,MOVE     IF MOVE IS NOW COMPLETE
          SX5    B1+B1       MOVE FIRST TWO WORDS 
          IX1    X1-X5
          SA2    X2+B7       FETCH FIRST DATA PAIR
          SA4    A2+B1
          BX6    X2 
          LX7    X4 
          SA6    X3+B7
          SA7    A6+B1
          ZR     X1,MOVE     QUIT IF ONLY TWO WORDS MOVED 
          SA2    A2+B7       FETCH NEW DATA FOR NEXT MOVE 
          SA4    A4+B7
 MOVEL    BX6    X2          GENERAL MOVE LOOP
          SA2    A2+B7
          LX7    X4 
          SA4    A4+B7
          IX1    X1-X5
          NO
          SA6    A6+B7
          SA7    A7+B7
          NZ     X1,MOVEL 
  
 MOVE     PS                 RETURN EXIT
          IX4    X2-X3       TEST DIRECTION OF MOVE 
          MX5    59 
          BX6    -X5*X1 
          IX1    X1-X6       REDUCE COUNT DOWN TO EVEN NUMBER 
          PL     X4,MOVEI    JUMP IF UPWARD MOVE
          ZR     X6,MOVED1   IF EVEN NUMBER 
          SB7    X1 
          SA4    X2+B7       MOVE INITIAL WORD
          BX6    X4 
          SA6    X3+B7
 MOVED1   IX2    X2+X1
          IX3    X3+X1
          SB7    -2 
          EQ     MOVER
 MTD      SPACE  4
**        MTD - MOVE ALL TABLES TO LOW CORE.
  
  
 MTD      PS                 RETURN EXIT
          SB2    NTABLES
          SA1    LOCORE 
          LX0    X1 
          SB3    B1 
 MTD1     SA2    ORIGINS-1+B3 
          SA1    SIZES-1+B3 
          LX3    X0 
          IX0    X0+X1
          LX7    X3 
          BX4    X2-X3
          SA7    A2 
          SB3    B3+B1
          ZR     X4,MTD2     AVOID NULL MOVE
          RJ     MOVE 
 MTD2     NE     B3,B2,MTD1  LOOP 
          EQ     MTD         EXIT 
 MTU      SPACE  4
**        MTU - MOVE ALL TABLES TO HIGH CORE. 
  
  
 MTU      PS                 RETURN EXIT
          SB2    NTABLES
          SA1    LOCORE 
          SA2    SIZCORE
          IX0    X1+X2       LWA+1 OF TABLE SPACE AVAILABLE 
          SB3    B2-B1
 MTU1     SB3    B3-B1
          SA2    ORIGINS+B3 
          SA1    SIZES+B3 
          IX7    X0-X1
          LX0    X7 
          SA7    A2 
          BX3    X0 
          RJ     MOVE 
          NZ     B3,MTU1     LOOP 
          EQ     MTU         EXIT 
 MVL      SPACE  4,8
**        MVL - MOVE BLOCK OF LCM DATA (SCOPE 2 ONLY).
* 
*         ENTRY  (X1) = WORD COUNT. 
*                (X2) = SOURCE FWA. 
*                (X3) = DESTINATION FWA.
* 
*         EXIT   (X1) = WORD COUNT. 
* 
*         USES   X - 0, 2, 3, 6.
*                B - 5, 6, 7. 
*                A - 0. 
* 
*         CALLS  NONE.
  
  
 MVL      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,7
  
          SB7    X1 
          IX6    X3-X2
          SB6    100B        MOVE 100B WORDS AT A TIME
          SB5    B6 
          MI     X6,MVL1     IF MOVE DOWN 
          SB5    B7-B6
          SX2    X2+B5       PREPARE FOR UPWARD MOVE
          SX3    X3+B5
          SB5    -B6
 MVL1     SA0    LCMB 
          LE     B7,B6,MVL3  IF ONLY ONE MOVE NEEDED
 MVL2     SX0    X2          READ BLOCK 
          RL     B6 
          SX2    X2+B5
          SX0    X3          WRITE BLOCK
          WL     B6 
          SB7    B7-B6       COUNT WORDS
          SX3    X3+B5
          GT     B7,B6,MVL2  LOOP 
 MVL3     LE     B7,B0,MVL   RETURN IF FINISHED 
          SB5    B6-B7       SETUP FOR LAST MOVE
          SB6    B7 
          MI     X6,MVL2     IF DOWNWARD MOVE 
          SX2    X2+B5
          SX3    X3+B5
          EQ     MVL2 
  
 RM       ELSE
  
          EQ     *+1S17      ERROR IF NOT SCOPE 2 
  
 RM       ENDIF 
 OVL      SPACE  4,8
**        OVL - LOAD OVERLAY. 
*         ENTRY  (X1) = OVERLAY NAME. 
*                (X2) = 12/ LEVEL, 12/ 0, 18/ LWA+1, 18/ ORIGIN.
  
  
 OVL      IFNE   OVERLAY,0
  
 OVL      PS                 RETURN EXIT
          SA3    OVLY+1 
          LX6    X1 
          BX7    X2+X3       SETUP SECOND WORD OF LADER CALL
          SA7    OVLZ+1 
          SA6    A7+B1       STORE OVERLAY NAME 
          LX3    59-46
          PL     X3,OVL1     IF TWO-WORD CALL 
          SA3    A3-B1
          BX6    X3          SET LIBRARY OR FILE NAME 
 OVL1     SA6    A7-B1
          MX7    0           CLEAR LOADER REPLY WORD
          SA7    RA.LDR 
          LOADREQ OVLZ       REQUEST OVERLAY LOAD 
  
 RM       IFNE   CP#RM,7
 OVL2     RECALL             WAIT FOR LOADER
          SA4    RA.LDR 
          ZR     X4,OVL2
 RM       ENDIF 
  
          SA1    OVLZ+1      GET STATUS RESPONSE
          LX1    59-36
          PL     X1,OVL      IF NO FATAL ERROR
          SA1    OVLZ+2 
          SX6    1R 
          BX6    X1+X6       PUT OVERLAY NAME IN MESSAGE
          LX6    -6 
          SA6    OVLM+1 
          MESSAGE OVLM       *CANT LOAD -------*
          RJ     RPD         RESTORE DEFAULT PRINT DENSITY IF NECESSARY  F4810A 
          ABORT  ,NODUMP
  
 OVLA     CON    0L"OVLA" 
          VFD    12/0101B,12/,18/ENDA+1,18/ORGA 
  
 OVLM     DIS    ,* CANT LOAD -------*
  
 OVLY     BSS    0           LOADER PARAMETERS, SET BY *SFL* IN PASS 0
 LIB      IFC    EQ, "CP.OVLIB" 
          CON    0L"OVLA"    USE GLOBAL LIBRARY SET 
          VFD    12/,12/0140B,18/,18/ 
 LIB      ELSE
          CON    0L"CP.OVLIB"  USE SPECIFIED LIBRARY
          VFD    12/,12/2140B,18/,18/ 
 LIB      ENDIF 
  
 OVLZ     BSS    3           SPACE FOR LOADER PARAMETER LIST
  
 OVL      ENDIF 
 PRESET   SPACE  4
**        PRESET - PRESET AREA OF STORAGE.
*         DISASTER IF FWA IS GREATER THAN LWA.
*         ENTRY  (X1) = DATA. 
*                (X2) = FWA.
*                (X3) = LWA+1.
  
  
 PRESET   PS                 RETURN EXIT
          BX6    X1 
          IX0    X3-X2
          SX3    B1 
          SA6    X2 
          BX2    X0*X3
          AX0    1
          ZR     X0,PRESET
 +        BX7    X1 
          ZR     X2,*+1 
          SA6    A6+B1
          IX0    X0-X3
          SA6    A6+B1
          ZR     X0,PRESET
 +        IX0    X0-X3
          SA7    A6+B1
          SA6    A7+1 
          NZ     X0,*-1 
          EQ     PRESET 
 PULL     SPACE  4
**        PULL - REMOVE TOP ENTRY FROM A PUSH-DOWN STACK. 
*         ENTRY  (X1) = STACK CONTROL WORD. 
*                (A1) = ADDRESS OF SAME.
*         EXIT   (X1) = (X6) = TOP ENTRY IN STACK.
*                THE ENTRY IS DELETED FROM THE STACK. 
  
  
 PULL1    AX1    24          RETURN DEFAULT VALUE 
          BX6    X1 
  
 PULL     PS                 RETURN EXIT
          MX0    -6 
          SB7    X1          AVAILABLE ENTRY COUNT
          AX1    18 
          BX7    -X0*X1 
          ZR     X7,PULL1    IF STACK IS EMPTY
          AX1    6
          SB6    X7          CURRENT WORD NUMBER
          BX7    -X0*X1 
          SA2    A1+B6       CURRENT WORD 
          AX1    6
          SB5    X7          CURRENT BIT POSITION 
          BX3    -X0*X1 
          MX0    1
          SB4    X3          BITS PER ENTRY 
          SX3    X3+B5       NEW BIT POSITION 
          SB4    B4-59
          LX0    X0,B4       MX0  -BPE
          SB4    B4-B1
          LX0    X0,B5       POSITION MASK
          SB4    X3+B4
          BX7    X0*X2       ERASE ENTRY
          SX4    B6 
          LE     B4,B0,PULL2 IF NOT END OF WORD 
          MX3    0
          SX4    B6-B1
 PULL2    BX6    -X0*X2      RETURN VALUE 
          LX1    6
          SA7    A2          RESTORE STACK WORD 
          BX2    X1+X3
          SB6    60 
          SB5    B6-B5
          LX6    B5 
          SX3    B7+B1       BUMP AVAILABLE ENTRY COUNT 
          LX4    18 
          BX1    X4+X3
          LX2    24 
          BX7    X2+X1       RESTORE CONTROL WORD 
          LX1    X6 
          SA7    A1 
          EQ     PULL        RETURN 
 PUSH     SPACE  4
**        PUSH - ADD NEW ENTRY AT TOP OF A PUSH-DOWN STACK. 
*         ENTRY  (X1) = STACK CONTROL WORD. 
*                (A1) = ADDRESS OF SAME.
*                (X6) = VALUE TO BE ADDED TO STACK. 
*         EXIT   IF STACK OVERFLOWS, BOTTOM-MOST ENTRY IS LOST. 
  
  
 PUSH1    SX3    B5 
          LX7    18 
          BX2    X1+X3
          SX1    B7-B1       DECREMENT AVAILABLE ENTRY COUNT
          BX6    X7+X1
          LX2    24 
          BX6    X2+X6       RESTORE CONTROL WORD 
          SA6    A1 
  
 PUSH     PS                 RETURN EXIT
          MX0    -6 
          SB7    X1          AVAILABLE ENTRY COUNT
          AX1    18 
          BX7    -X0*X1 
          ZR     B7,PUSH3    IF STACK IS FULL 
          AX1    6
          SB6    X7          CURRENT WORD NUMBER
          BX3    -X0*X1      CURRENT BIT POSITION 
          AX1    6
          BX2    -X0*X1 
          SB5    X2          BITS PER ENTRY 
          ZR     X3,PUSH2    IF WORD IS FULL
          SA2    A1+B6
          SB6    -B5
          SB5    X3+B6       NEW BIT POSITION 
          LX3    X6,B5       POSITION NEW ENTRY VALUE 
          BX6    X2+X3       APPEND TO CURRENT WORD 
          SA6    A2          STORE IT BACK
          LX1    6
          EQ     PUSH1       GO RESTORE CONTROL WORD
 PUSH2    LX1    -6 
          SB6    B6+B1       BUMP WORD NUMBER 
          BX2    -X0*X1      UNUSED BITS AT TOP OF WORD 
          SB5    X2+B5
          SB4    60 
          LX1    12 
          SB5    B4-B5       NEW BIT POSITION 
          LX6    X6,B5       POSITION NEW ENTRY VALUE 
          SX7    B6 
          NO
          SA6    A1+B6       STORE NEW WORD 
          EQ     PUSH1       GO RESTORE CONTROL WORD
 PUSH3    AX1    6
          SB7    X7          CURRENT WORD NUMBER
          BX7    -X0*X1 
          AX1    6
          SB6    X7          CURRENT BIT POSITION 
          BX7    -X0*X1 
          AX1    6
          SB5    X7          BITS PER ENTRY 
          BX7    -X0*X1 
          MX0    1
          SB4    B5-59
          LX0    X0,B4       MX0  -BPE
          SA3    A1+B1
          SA2    A3+B1
          LX1    X3,B5
          EQ     B7,B1,PUSH5 IF ONE-WORD STACK
          SB4    X7+B5
          BX1    X0*X1
          LX3    X2,B4
          SB3    X7          UNUSED BITS AT TOP OF WORD 
 PUSH4    BX2    -X0*X3 
          BX7    X1+X2
          AX1    X3,B3
          SA7    A2-B1       OFFSET MOVE LOOP TO SLIDE STACK DOWN 
          SB7    B7-B1
          SA2    A2+B1
          BX1    X0*X1
          LX3    X2,B4
          NE     B7,B1,PUSH4 LOOP 
 PUSH5    SB4    B5+B6
          MX0    1
          SB5    B4-59
          LX0    X0,B5
          BX2    X0*X1       MASK SIGNIFICANT BITS IN LAST WORD OF STACK
          LX1    X6,B6       POSITION NEW ENTRY VALUE 
          BX7    X2+X1       APPEND TO WORD 
          SA7    A2-B1       STORE IT BACK
          EQ     PUSH        RETURN 
 RCS      SPACE  4,10                                                    F4810B 
**        RCS - RESTORE COMPILER SPACE.                                  F4810B 
*         RESTORES THE CELLS CP.NFLS AND CP.AFLS AND THE SPACE INCLUDED  F4810B 
*         BETWEEN  THE ADDRESSES CONTAINED IN THESE CELLS TO THEIR       F4810B 
*         ORIGINAL STATE (ON ENTERING COMPASS FROM A COMPILER CALL)      F4810B 
*         BEFORE RETURNING CONTROL TO THE COMPILER.                      F4810B 
                                                                         F4810B 
                                                                         F4810B 
 RCS      PS                 RETURN EXIT                                 F4810B 
          SA1    L.CMPTAB 
          ZR     X1,RCS      IF NOT CALLED BY A COMPILER
          SA1    FTNE+1 
          ZR     X1,RCS05    IF WE DIDNT SET UP E FILE BUFFER ADDRESSES.
          BX6    X1 
          SA6    E+4         RESTORE BUFFER LENGTH
          SA1    E+1
          MX6    -18
          BX6    X6*X1       CLEAR FIRST ADDRESS IN FET 
          SA6    A1 
          MX6    0
          SA6    A6+B1       CLEAR IN ADDRESS IN FET
          SA6    A6+B1       CLEAR OUT ADDRESS IN FET.
 RCS05    SA1    FTNE 
          BX6    X1 
          SA6    E           RESTORE E FET FOR FTN. 
          SA1    O.CMPTAB    ELSE GET ORIGINAL CP.AFLS AND CP.NFLS
          SA3    X1 
          BX6    X3 
          SA6    CP.AFLS     SAVE TO LATER RESTORE CP.NFLS AND CP.AFLS
          SX1    X3 
          AX3    30 
          IX3    X1-X3       ORIGINAL CP.AFLS-ORIGINAL CP.NFLS
          ZR     X3,RCS2     IF NO SPACE SAVED, GO RESTORE FL.
          SB3    5           ELSE EMPTY ALL TABLES EXCEPT CMPTAB
          MX6    0
          SA6    L.INTER     FIRST TABLE TO BE EMPTIED
 RCS1     SB3    B3-B1
          SA6    A6+B1       SET NEXT TABLE LENGTH TO ZERO
          GT     B3,B1,RCS1  IF NOT THROUGH 
          RJ     MTD         MOVE TABLES DOWN 
          SA2    O.CMPTAB    GET ORGIN OF COMPILER TABLE
          SA1    X2          GET ORIGINAL CONTENTS OF CP.AFLS, CP.NFLS
          SX1    X1          GET RID OF TOP PART OF WORD
 RCS2     BX1    -X1
          RJ     RFL         RESTORE ORIGINAL FL TO ORIGINAL CP.AFLS
          SA2    O.CMPTAB 
          SA1    L.CMPTAB 
          SX1    X1-1        WORD COUNT FOR MOVE (IGNORE FIRST WORD)
          ZR     X1,RCS3     IF NONE SAVED, GO RESTORE CP.NFLS, CP.AFLS 
          SA3    X2          FWA OF CMPTAB
          SX2    X2+B1       SKIP CELL STORING CP.AFLS AND CP.NFLS
          AX3    30-0        DESTINATION ADDRESS (CP.NFLS)
          RJ     MOVE        RESTORE COMPILER SPACE 
 RCS3     SA3    CP.AFLS     GET ORIGINAL CP.NFLS, CP.AFLS
          SX7    X3 
          AX3    30 
          BX6    X3 
          SA6    CP.NFLS     RESTORE ORIGINAL CP.NFLS 
          SA7    CP.AFLS     RESTORE ORIGINAL CP.AFLS 
          EQ     RCS         RETURN 
 RFL      SPACE  4,10                                                    F4810B 
**        RFL - REQUEST FIELD LENGTH                                     F4810B 
*         ENTRY  (X1) = +    REQUESTS MIN(X1+FLINC+CP.NFLS,MAXFL)        F4810B 
*                            WHERE X1 IS NUMBER OF ADDITIONAL WORDS REQ. F4810B 
*                       -    REQUESTS MIN(-X1,MAXFL)                     F4810B 
*                            WHERE -X1 IS A SPECIFIC FL REQUIRED         F4810B 
*         EXIT   (X3) = NZ   FIELD LENGTH REQUEST COMPLETED              F4810B 
*                       0    INDICATES FIELD LENGTH ALREADY = MAXFL      F4810B 
*                                                                        F4810B 
*         USES   A           2,3,4,6                                     F4810B 
*                B           NONE                                        F4810B 
*                X           1,2,3,4,6                                   F4810B 
                                                                         F4810B 
                                                                         F4810B 
 RFL      PS                 RETURN EXIT                                 F4810B 
          SA2    MAXFL       MAXIMUM FL                                  F4810B 
          BX6    -X1                                                     F4810B 
          SA4    CP.NFLS     CURRENT FL                                  F4810B 
          MI     X1,RFL1     IF REQUESTING SPECIFIC FIELD LENGTH         F4810B 
          IX3    X2-X4       ELSE REQUESTING X ADDITIONAL WORDS FL       F4810B 
          NZ     X3,RFL0     IF NOT ALREADY AT MAX. FL. 
          SX6    B1          ELSE SET FLAG TO USE LAST 1000 WORDS 
          SA6    LSTTHOU
          EQ     RFL         RETURN 
  
 RFL0     BSS    0
          IX6    X4+X1       WORDS REQUESTED + CURRENT FL                F4810B 
          SX3    FLINC       FL INCREMENT                                F4810B 
          IX6    X6+X3       WORDS REQUESTED + CURRENT FL + FLINC        F4810B 
 RFL1     MX3    -6          ROUND UP REQUEST 
          IX6    X6-X3
          BX6    X3*X6                                                   F4810B 
          IX3    X2-X6
          PL     X3,RFL2     IF REQUEST NOT GREATER THAN MAXIMUM JOB FL  F4810B 
          BX6    X2          ELSE REQUEST MAXIMUM JOB FL                 F4810B 
 RFL2     IX2    X4-X6       COMPARE REQUESTED FL TO CURRENT
          ZR     X2,RFL      IF REQUEST = CURRENT, RETURN 
          LX6    30-0 
          SA6    A4          PREPARE REQUEST/REPLY WORD                  F4810B 
          MEMORY CM,CP.NFLS,RECALL MAKE MEMORY REQUEST                   F4810B 
          SA2    CP.NFLS     GET REPLY WORD                              F4810B 
          AX2    30-0        SHIFT RETURNED FL INTO LOWER 30 BITS        F4810B 
          BX6    X2                                                      F4810B 
          SA6    CP.NFLS     SET UP NEW CURRENT FL                       F4810B 
          SA3    LOCORE      UNUSABLE SPACE                              F4810B 
          SX6    X6-10       ALLOW TEN WORDS FOR SLOP                    F4810B 
          SA6    O.ENDTAB    RESET END OF TABLES POINTER                 F4810B 
          IX6    X6-X3       NEW FL - UNUSABLE SPACE - 10 WORDS SLOP     F4810B 
          SA6    SIZCORE     SET TABLE SPACE                             F4810B 
          EQ     RFL         RETURN                                      F4810B 
 RLC      SPACE  4
**        RLC - READ LARGE CORE MEMORY. 
*         ENTRY  (X1) = LCM FWA.
*                (X2) = SCM FWA.
*                (X3) = WORD COUNT. 
*         USES   X - 0, 1, 3. 
*                B - 5, 6, 7. 
*                A - 0. 
  
  
 RLC1     SB7    X3-1000B 
          SB6    1000B
          PL     B7,RLC2     IF AT LEAST 1000B WORDS REMAIN 
          SB7    B0 
          SB6    X3          SET REDUCED WORD COUNT 
 RLC2     BSS    0
  
          IF     DEF,HAFEXIT
 +        RE     B6 
 -        RJ     RLC3        IF ERROR 
          ELSE   1
          RL     B6 
  
          IX0    X0+X1       INCREMENT ADDRESSES
          SA0    A0+B6
          SX3    B7 
          GT     B7,B0,RLC1  LOOP 
  
 RLC      PS                 RETURN EXIT
          BX0    X1 
          SA0    X2 
          SB5    3           RETRY COUNTER
          SX1    1000B
          MI     X3,RLC 
          NZ     X3,RLC1     IF WORD COUNT GREATER THAN ZERO
          EQ     RLC         RETURN 
  
 ECS      IF     DEF,HAFEXIT
  
 RLC3     PS                 RETURN EXIT
          SB5    B5-B1
          MI     B5,RLC4     IF FAILURE AFTER 4 ATTEMPTS
 +        RE     B6 
 -        EQ     RLC3+1      IF ERROR 
          SB5    3           RESET RETRY COUNT
          EQ     RLC3        RETURN 
 RLC4     MESSAGE RLCM,,R 
          RJ     RPD         RESTORE DEFAULT PRINT DENSITY IF NECESSARY  F4810A 
          ABORT  ,NODUMP
  
 RLCM     DATA   C* ASSEMBLY ABORTED - ECS READ ERROR.* 
  
 ECS      ENDIF 
 RPD      SPACE  4,10                                                    F4810A 
**        RPD - RESTORE PRINT DENSITY.                                   F4810A 
*         RESTORE PRINTER DENSITY TO DEFAULT IF IT HAS BEEN CHANGED.     F4810A 
                                                                         F4810A 
                                                                         F4810A 
 RPD      PS                 RETURN EXIT                                 F4810A 
          SA2    FRSTLIN     CHECK IF PRINT DENSITY IS EIGHT
          ZR     X2,RPD      IF PRINT DENSITY IS SIX, LEAVE IT. 
                                                                         F4810A 
 RM       IFEQ   CP#RM,0                                                 F4810A 
          SA2    CP.LISTF                                                F4810A 
          ZR     X2,RPD1     IF NO LONG LIST                             F4810A 
          SA1    LASTLIN
          ZR     X1,RDP0     IF PRINT DENSITY AT DEFAULT
          WRITEH O,A1,1 
 RDP0     BSS    0
          WRITER O,RECALL                                                F4810A 
 RPD1     SA1    CP.EPAG     TEST *WRITTEN TO* FLAG (58)
          LX1    B1 
          PL     X1,RPD      IF NOTHING WAS WRITTEN TO ERROR FILE.
          SA1    LASTLIN
          ZR     X1,RDP2     IF PRINT DENSITY AT DEFAULT
          WRITEH E,A1,1 
 RDP2     BSS    0
          WRITER E,RECALL                                                F4810A 
          EQ     RPD         RETURN                                      F4810A 
                                                                         F4810A 
 RM       ELSE                                                           F4810A 
          SA1    LASTLIN
          ZR     X1,RPD      IF PRINT DENSITY AT DEFAULT
          SA2    CP.LISTF                                                F4810A 
          ZR     X2,RPD1     IF NO LONG LIST                             F4810A 
          PUT    O,LASTLIN,10  RESTORE PRINTER TO SIX LPI DENSITY 
 RPD1     SA1    CP.EPAG     TEST *WRITTEN TO* FLAG (58). 
          LX1    B1 
          PL     X1,RPD      IF NOTHING WAS WRITTEN TO ERROR FILE.
          PUT    E,LASTLIN,10  RESTORE PRINTER TO SIX LPI DENSITY 
          EQ     RPD         RETURN                                      F4810A 
                                                                         F4810A 
 RM       ENDIF                                                          F4810A 
 SCE      SPACE  4
**        SCE - SCAN ELEMENT. 
*         ENTRY  (B2) = MASK CODE FOR DELIMITERS TO BE RECOGNIZED AS
*                       SEPARATORS. ALL OTHERS ARE TREATED AS CHARACTERS
*                            0     , = / - SPACE
*                            1     , / - SPACE
*                            2     , / SPACE
* 
*         EXIT   (X1) = (X6) = ELEMENT, LEFT JUSTIFIED, ZERO FILLED,
*                TRUNCATED TO 7 CHARACTERS. 
*                (B2) = SEPARATOR CODE. 
*                            0     SPACE OR COMMA 
*                            1     =
*                            2     /
*                            3     -
*                            -1    OTHER
  
  
 SCE      PS                 RETURN EXIT
          SA1    COLUMN      FETCH POINTER TO 1ST CHAR OF ELEM
          SA2    =1216BS12   MASK FOR -/=SPACE, 
          ZR     B2,SCEA     IF PROPER MASK.
          SA2    =1206BS12   ELSE MASK FOR - / SPACE ,
          EQ     B2,B1,SCEA  IF PROPER MASK.
          SA2    =206BS12    ELSE MASK FOR / SPACE ,
 SCEA     SA1    X1+CARD-1   FETCH 1ST CHAR OF ELEM 
          BX6    X6-X6
          SB5    60          SET LEFT JUSTIFY SHIFT COUNT 
          SB4    18 
          SB6    6
 SCE1     SB7    X1 
          LX3    X2,B7
          SB5    B5-B6
          LX4    X1,B5       LEFT JUSTIFY CHARACTER 
          MI     X3,SCE2     IF SEPARATOR 
          BX6    X6+X4       INSERT CHARACTER 
          SA1    A1+B1       FETCH NEXT CHARACTER 
          GE     B5,B4,SCE1  LOOP 
          SA1    A1-B1       POINT TO EIGHTH CHARACTER
          BX6    X6-X4       REMOVE EIGHTH CHARACTER
          SX7    B1 
          SB2    -B1
          SA7    AERR        NOTE ERROR 
          SA7    EFLG 
          EQ     SCE3 
  
 SCE2     SA3    =440700002463BS24  CODES FOR -/=SPACE, 
          MX4    -3 
          SX7    B7 
          SA7    CHAR        UPDATE CURRENT CHARACTER CELL
          LX7    2           SHIFT COUNT = 4*(CHAR)-4*1R+-1 
          SB3    X7-1R+*4-1 
          LX3    B3 
          BX5    -X4*X3 
          SB2    X5-1        SEPARATOR CODE 
 SCE3     SX7    A1-CARD+1   UPDATE POINTER TO CARD IMAGE 
          SA7    COLUMN 
          BX1    X6 
          EQ     SCE         EXIT 
 SCITEM   SPACE  4
**        SCITEM - SCAN ITEM IN ADDRESS FIELD.
*         AERR NOTED IF GREATER THAN 8 CHARS, AND SYMBOL TRUNCATED. 
*         SEPARATORS ARE + - *  BLANK COMMA & 
*         * AND / APPLY ONLY IF NOT FIRST CHARACTER.
*         EXIT   (X6) = SCANNED ITEM. 
*                (X1) = TERMINATOR CHARACTER. 
  
  
 SCITEM1  LX6    6
          BX6    X1+X6       APPEND CHARACTER 
          SA1    A1+B1       FETCH NEW CHARACTER
          LX2    X3 
 SCITEM2  SB7    X1 
          AX2    X2,B7
          LX2    59 
          PL     X2,SCITEM1 
          SX7    A1-CARD+1
          SA7    COLUMN 
          BX7    X1 
          MX2    12 
          SA7    CHAR 
          BX3    X2*X6       CHECK FOR MORE THAN 8 CHARACTERS 
          SX7    B1 
          ZR     X3,SCITEM
          BX6    -X2*X6      TRUNCATE TO 8 CHARACTERS 
          SA7    AERR        NOTE ERROR 
          SA7    EFLG 
  
 SCITEM   PS                 RETURN EXIT
          SA1    COLUMN 
          SA2    =2003006BS36 MASK FOR +-,B&
          SA1    X1+CARD-1   FETCH CURRENT CHARACTER
          SA3    =2003036BS36 MASK FOR +-*/,B&
          BX6    X6-X6
          EQ     SCITEM2
 SCLIST   SPACE  4
**        SCLIST - SCAN ITEMS SEPARATED BY COMMA AND TERMINATED BY
*         A BLANK.
*         AERR NOTED IF GREATER THAN 8 CHARACTERS.
*         COMMA THROWN AWAY.
*         EXIT   (X6) = SCANNED ITEM. 
  
  
 SCL2     RJ     GETCH       THROW COMMA AWAY 
 SCL3     MX1    12          CHECK FOR LESS THAN 9 CHARACTERS 
          BX6    -X1*X0 
          IX2    X6-X0
          ZR     X2,SCLIST   IF LESS THAN 8 CHARACTERS
          SX7    B1 
          SA7    EFLG 
          SA7    AERR        NOTE A ERROR 
          SX6    B0          AND FORCE ITEM TO BE ZERO
  
 SCLIST   PS
          SX0    B0          CLEAR OUT ACCUMULATION CELL
          SA1    CHAR 
 SCL1     SB7    X1-1R       TEST BLANK 
          ZR     B7,SCL3     IF BLANK 
          EQ     B7,B1,SCL2  IF COMMA 
          LX0    6
          BX0    X1+X0
          RJ     GETCH       GO TO NEXT CHARACTER 
          EQ     SCL1        LOOP 
 SETUP    SPACE  4
**        SETUP - PREPARE LINE FOR ASSEMBLY.
*         THIS ROUTINE SCANS THE CARD AND ESTABLISHES THE CELLS...
*                LOCSYM            LOCATION SYMBOL. 
*                BADLOC            FLAGGED IF LOCATION EXCEEDS 8 CHARS. 
*                IOP               OPERATION FIELD SYMBOL.
*                COL               COLUMN NUMBER BEFORE OP CODE.
*                COL+1             COLUMN NUMBER BEFORE ADDRESS.
*                STYPE             TYPE OF CARD - BLANK OR ASTERISK.
*                COLUMN            COLUMN NUMBER OF FIRST ADDR. CHAR. 
*                CHAR              FIRST CHARACTER OF ADDRESS FIELD.
  
  
 SETUP0   SB4    -1R
          MX6    0
          SB7    X1+B4       TEST COLUMN 1 FOR BLANK
          SA1    A1+B1       FETCH COLUMN 2 
          NZ     B7,SETUP1   IF COLUMN 1 NON-BLANK
          SB7    B4          FORCE FIRST CHARACTER TO BE BLANK
 SETUP1   SB5    CARD+X5-1
          SA0    COL+1
          SB2    A1-B5       PRESET B2 = -COMCOL+2
          SB3    -2 
 SETUP3   LX6    6
          SX2    B7-B4       RESTORE CHARACTER VALUE
          SB7    X1+B4       PREPARE NEW CHARACTER TEST 
          BX6    X6+X2       APPEND CHARACTER VALUE 
          SA1    A1+B1       FETCH NEXT CHARACTER 
          NZ     B7,SETUP3   KEEP ACCUMULATING IF OLD NON-BLANK 
          SB3    B3+B1       INCREMENT FIELD COUNTER
          SA6    B3+1+LOCSYM STORE LOCATION OR OP-CODE SYMBOL 
          SB6    A1-B5       NUMBER OF COLUMNS LEFT 
          MX6    0
 SETUP4   SB7    X1+B4       PREPARE CHARACTER TEST 
          PL     B6,SETUP5   IF (CCOL) IS REACHED 
          SA1    A1+B1       FETCH NEXT CHARACTER 
          SB6    B6+B1       UPDATE REMAINING COLUMN COUNT
          ZR     B7,SETUP4
          SX7    B6-B2       ADD TO GET FINAL COLUMN NUMBER 
          SA7    B3+A0       STORE IN COL 
          MI     B3,SETUP3   IF MORE TO SCAN
          EQ     SETUP6 
 SETUP5   ZR     B6,SETUP6   IF (CCOL)-1 IS BLANK 
          SB6    B6+X4       MOVE (CCOL) BEYOND (LASTCOL) 
          SB2    B2+X4
          SX7    B6-B2       COLUMN PREVIOUSLY SCANNED
          SA7    B3+A0
          EQ     SETUP4 
 SETUP6   SX7    B6-B2       COLUMN PREVIOUSLY SCANNED
          SX6    X7+B1       CURRENT COLUMN 
          SA1    LOCSYM      RECLAIM LOCATION SYMBOL TO TEST VALIDITY 
          MX0    12 
          BX7    X0*X1
          SA6    COLUMN 
          SA7    BADLOC 
          SX7    -B4
          SA7    CARD+1+X3   RESTORE (LASTCOL)+2 TO BLANK 
          SA1    X6+CARD-1
          BX6    X1 
          SA6    CHAR 
  
 SETUP    PS                 RETURN EXIT
          SA5    CCOL 
          SA3    LASTCOL
          SX6    B1 
          SA6    CARD+1+X3   SET LASTCOL+2 TO NON-BLANK 
          IX4    X5-X3       (CCOL)-(LASTCOL) 
          SX6    X5-2 
          SX7    2R 
          SB2    -1R* 
          SA1    CARD        FETCH COLUMN 1 
          SA6    COL+1
          SA7    IOP
          SB7    X1+B2
          SB6    X1-1R, 
          ZR     B7,SETUPC   TEST FOR A COMMENTS CARD 
          NZ     B6,SETUP0   IF NOT COMMA 
 SETUPC   SX6    -B2         IF COL 1 IS * OR , AND STYPE IS BLANK
          SA1    STYPE       BLANK (FROM INPUT1), SET STYPE = * 
          SB7    X1-1R
          NZ     B7,SETUP 
          SA6    A1 
          EQ     SETUP
 SLO      SPACE  4
**        SLO - SET LIST OPTIONS. 
  
  
 SLO      PS                 RETURN EXIT
          SA1    XLIST
          NZ     X1,SLO      IF EXTERNAL LIST IN CONTROL
          SA1    CHAR 
          SB7    X1-1R* 
          ZR     B7,SLO5     IF LIST *
          SA1    LISTOPS+1
          SB7    LLISTOPS-2 
          SB2    B1+B1
          BX6    X1 
 +        SA1    A1+B2       COLLECT LIST FLAGS 
          LX6    1
          SB7    B7-B2
          BX6    X6+X1
          NZ     B7,*-1      LOOP 
          SA1    LISTSTK
          RJ     PUSH        PUSH DOWN LIST STACK 
          SA2    COLUMN 
          SA1    X2+CARD-1
          SA0    LLISTOPS/2 
          SB4    -1R- 
 SLO1     SX7    B1          CHECK LIST OPTION
          SB3    A0 
          SB2    B1+B1
          SB7    X1+B4
          NZ     B7,SLO2     IF NOT - OPTION
          SX7    B0 
          SA1    A1+B1
 SLO2     SA2    LISTOPS
          SB6    X1 
 SLO3     UX6    X2,B7       SEARCH FOR OPTION
          SB3    B3-B1
          SA2    A2+B2
          NG     B3,SLO7     IF NOT FOUND 
          NE     B6,B7,SLO3  IF NOT LIST OPTION 
          SA7    A2-B1       SET OPTION 
          SB7    -1R
 SLO4     SB6    X1+B7       SCAN OFF EXTRA CHARACTERS
          SA1    A1+B1
          EQ     B6,B1,SLO1  IF *,* 
          NZ     B6,SLO4     IF NOT * * 
          EQ     SLO         RETURN 
 SLO5     SA1    LISTSTK
          RJ     PULL        PUSH UP LIST STACK 
          SX7    B1 
          BX6    X7*X1
          SA6    LISTOPS+LLISTOPS-1 
          SB7    NLISTOPS-1 
          SB2    B1+B1       RESET LIST FLAGS 
 SLO6     AX1    1
          BX6    X7*X1
          SB7    B7-B1
          SA6    A6-B2
          NZ     B7,SLO6     LOOP 
          EQ     SLO         RETURN 
 SLO7     SB7    B6-1R$ 
          SB3    A0-B1
          NZ     B7,SLO8     IF NOT $ 
          SA7    LISTOPS+1
 +        SB3    B3-B1       SET ALL OPTIONS
          SA7    A7+B2
          NZ     B3,* 
          SB7    -1R
          EQ     SLO4        LOOP 
 SLO8     SX6    B1          SET *8* ERROR
          SA6    W8ERR
          SA6    EFLG 
          SB7    -1R
          EQ     SLO4        LOOP 
 SNT      SPACE  4
**        SNT - SET NEW TITLE.
*         ENTRY  (A1) = TITLE BUFFER ADDRESS. 
*                (X1) = FIRST WORD OF TITLE.
*         EXIT   (X6) = 1 IF IN XTEXT AND LIST X IS OFF.                P036  10
*                     = 0 OTHERWISE.                                    P036  11
  
  
 SNT      PS                 RETURN EXIT
          SA3    LIBFLG                                                 P036  13
          SA4    LX+1                                                   P036  14
          BX6    -X4*X3                                                 P036  15
          NZ     X6,SNT      IF TITLE SHOULD NOT BE CHANGED             P036  16
          SA2    COL+1
          SB6    3
          SB7    TITBUFL+1   TITLE WORD COUNT 
          MX0    18 
          LX1    -18
          BX6    -X0*X1 
          SB5    A1 
          SA1    X2+CARD-1
 SNT1     LX6    6           ASSEMBLE TITLE 
          SB6    B6-B1
          BX6    X6+X1
          SA1    A1+B1
          NZ     B6,SNT1     LOOP 
          SA6    B5 
          SB7    B7-B1
          SB6    10 
          SB5    B5+B1
          MX6    0
          NZ     B7,SNT1     LOOP 
          EQ     SNT         RETURN 
 SQV      SPACE  4
**        SQV - SET QUAL VALUE. 
*         ENTRY  (X1) = NEW QUAL SYMBOL.
*         EXIT   (QVAL) = INDEX OF SYMBOL.
*                (QVAL+1) = INDEX OF PREVIOUS QVALUE. 
  
  
 SQV      PS                 RETURN EXIT
          SA2    O.QVTAB
          SA3    L.QVTAB
          SB7    B0 
          ZR     X1,SQV2     IF BLANK QUALIFIER 
          SA2    X2 
          SB6    X3 
          MX3    -48
 SQV1     BX2    -X3*X2 
          EQ     B7,B6,SQV3  IF END OF TABLE
          BX6    X2-X1
          SB7    B7+B1
          SA2    A2+B1
          NZ     X6,SQV1     IF QUALIFIER NOT FOUND YET 
 SQV2     SX6    B7 
          SA2    QVAL 
          LX6    48 
          BX7    X2 
          SA6    A2 
          SA7    A6+B1
          EQ     SQV         RETURN 
 SQV3     ADDWORD QVTAB 
          SA3    L.QVTAB
          SB7    X3 
          EQ     SQV2 
 TLUOP    SPACE  4
**        TLUOP - LOOK UP ENTRY IN OPTAB. 
*         ENTRY  (X1) = OPCODE NAME.
*         EXIT   (X6) = EQUIVALENT (NON ZERO IF FOUND). 
*                (X6) = 0 IF NOT IN TABLE.
*                (OPTYPE) EQUALS X6.
*                (A2) = LOCATION OF EQUIVALENT IF FOUND.
  
  
 TLUOP2   SA2    A5+B1       FETCH EQUIVALENT 
          BX6    X2 
          SA6    OPTYPE 
  
 TLUOP    PS                 RETURN EXIT
          PX0    X1 
          SA2    HASH 
          DX3    X0*X2
          SA5    O.OPTAB
          SX0    2*NOPCT-2
          SX6    B0          CLEAR OUT OPERATION CODE ERROR 
          AX3    47-TLUOPSHF
          BX4    X0*X3
          SB7    X5 
          MX2    12 
          SA6    OERR 
 TLUOP1   SA5    X4+B7       FETCH NEXT ENTRY IN CHAIN
          BX6    X2*X5       EXTRACT LINK 
          IX3    X5-X6       ISOLATE ACTUAL SYMBOL
          BX7    X1-X3
          LX6    13          POSITION LINK FOR LATER TESTING
          ZR     X7,TLUOP2   IF MATCH FOUND 
          IX4    X6+X0       CALCULATE ADDRESS OF CHAIN ENTRY 
          NZ     X6,TLUOP1
          SA6    OPTYPE 
          EQ     TLUOP
 TLUSYMT  SPACE  4,8
**        TLUSYMT - LOOK UP SYMBOL IN SYMBOL TABLE. 
*         ENTRY  (X1) = SYMBOL RIGHT JUSTIFIED. 
*         EXIT   (X1) = SYMBOL. 
*                (X2) = TABLE ENTRY.
*                (X3) = LOCATION OF EQUIVALENT (0 IF NOT FOUND).
*                (X4) = INDEX OF EQUIVALENT IN SYMTAB.
*                (X5) = SYMBOL WITH QUALIFIER.
  
  
 SLU3     SX4    B7 
          SX3    X0+
          IX4    X0-X4
  
 TLUSYMT  PS                 RETURN EXIT
          SA2    HASH        HASHING CONSTANT 
          SA5    QVAL        QUALIFIER VALUE
          PX0    X1          FORM HASH INDEX
          SB5    -B1
          DX3    X0*X2
          SA2    O.SYMTAB    (B7) = TABLE ORIGIN
          SX0    NSYMT*2-2
          BX5    X5+X1       ADD QUALIFIER VALUE TO SYMBOL
          SB6    42 
          AX3    47-SHIFTQ
          SB7    X2          TABLE ORIGIN 
          BX4    X0*X3       BASE INDEX 
 SLU1     SX0    B7+X4
          RX3    X0 
          SX0    X0+B1
          RX2    X0 
          BX6    X3-X5
          AX4    X2,B6
          ZR     X6,SLU3     IF MATCH FOUND 
          BX6    X3-X1
          NZ     X6,SLU2     IF NOT WITH QUAL OF ZERO 
          SB5    X0 
 SLU2     NZ     X4,SLU1     IF LINK " 0
          MX2    0           END OF SYMBOL TABLE
          SX3    B0 
          NG     B5,TLUSYMT  IF NOT FOUND 
          SX0    B5 
          RX2    X0 
          EQ     SLU3 
 UPPOS    SPACE  4
**        UPPOS - INCREMENT POSITION COUNTER. 
*         ENTRY  (X1) = INCREMENT.
  
  
 UPPOS    PS                 RETURN EXIT
          SA2    POSCTR 
          IX6    X2-X1       DECREMENT POSITION COUNTER 
          SA6    A2 
          SA3    LWORD       WORD LENGTH - 12, 16, OR 60
 UPPOS1   PL     X6,UPPOS    EXIT IF STILL IN THIS WORD 
          SA4    ORGCTR      ADJUST ORIGIN AND LOCATION COUNTERS
          SA5    LOCCTR 
          IX6    X6+X3
          MX0    59 
          IX7    X4-X0
          SA7    A4 
          IX7    X5-X0
          SA7    A5 
          SA6    A6 
          EQ     UPPOS1 
 VFYLINK  SPACE  4
**        VFYLINK - VERIFY LINKAGE SYMBOL.
*         VALID LINKAGE SYMBOLS MUST BE...
*                1)  7 OR FEWER CHARACTERS (3 OR FEWER IF PP).
*                2)  BEGIN WITH A-Z IF CP.
*         ENTRY  (X6) = SYMBOL TO BE CHECKED. 
*         EXIT   (X1) = (X6) = SYMBOL, TRUNCATED IF NECESSARY.          S002   6
*                (X7) = 0 IF OK,  "0 IF BAD.
  
  
 VFYLINK  PS                 RETURN EXIT
          SA4    MACHINE                                                S002   9
          SA5    PPTYPE                                                 S002  10
          MX3    6                                                      S002  11
          BX1    -X5*X4                                                 S002  12
          MX0    -7*6        SET FOR 7-CHARACTER NAME                   S002  13
          MI     X5,VFL1     IF BCU, MCU, OR 180 PPU
          ZR     X1,VFL1     IF CPU OR 7000 PPU ASSEMBLY                S002  15
          MX0    -3*6        6000 PERIPH, SET FOR 3-CHARACTER NAME      S002  16
 VFL1     BX7    X0*X6                                                  S002  17
          BX5    X6 
          LX1    X6                                                     S002  18
          ZR     X7,VFL3     IF NAME NOT TOO LONG                       S002  19
 VFL2     AX6    6                                                      S002  20
          BX6    -X3*X6      TRUNCATE EXCESS CHARACTERS FROM RIGHT      S002  21
          BX5    X0*X6                                                  S002  22
          NZ     X5,VFL2     LOOP                                       S002  23
          BX1    X6                                                     S002  24
          LX5    X6                                                     S002  25
 VFL3     NZ     X4,VFYLINK  IF PPU ASSEMBLY                            S002  26
          ZR     X6,VFYLINK  IF EMPTY NAME                              S002  27
 VFL4     BX4    X3*X5                                                  S002  28
          LX5    6           LEFT JUSTIFY NAME                          S002  29
          ZR     X4,VFL4                                                S002  30
          SX5    X5-1R0                                                 S002  31
          MI     X5,VFYLINK  IF FIRST CHARACTER IS A-Z                  S002  32
          MX7    6                                                      S002  33
          JP     VFYLINK     RETURN WITH ERROR                          S002  34
 WLC      SPACE  4
**        WLC - WRITE LARGE CORE MEMORY.
*         ENTRY  (X1) = LCM FWA.
*                (X2) = SCM FWA.
*                (X3) = WORD COUNT. 
*         USES   X - 0, 1, 3. 
*                B - 6, 7.
*                A - 0. 
  
  
 WLC1     SB7    X3-1000B 
          SB6    1000B
          PL     B7,WLC2     IF AT LEAST 1000B WORDS REMAIN 
          SB7    B0 
          SB6    X3          SET REDUCED WORD COUNT 
 WLC2     BSS    0
  
          IF     DEF,HAFEXIT
 +        WE     B6 
 -        EQ     WLC3        IF ERROR 
          ELSE   1
          WL     B6 
  
          IX0    X0+X1       INCREMENT ADDRESSES
          SA0    A0+B6
          SX3    B7 
          GT     B7,B0,WLC1  LOOP 
  
 WLC      PS                 RETURN EXIT
          BX0    X1 
          SA0    X2 
          SX1    1000B
          NZ     X3,WLC1     IF WORD COUNT NON-ZERO 
          EQ     WLC         RETURN 
  
 ECS      IF     DEF,HAFEXIT
 WLC3     MESSAGE WLCM,,R 
          RJ     RPD         RESTORE DEFAULT PRINT DENSITY IF NECESSARY  F4810A 
          ABORT  ,NODUMP
  
 WLCM     DATA   C* ASSEMBLY ABORTED - ECS WRITE ERROR.*
  
 ECS      ENDIF 
 LJUST    TITLE  COMMON SECTION - ADDRESS SCANNING ROUTINES.
**        LJUST - LEFT JUSTIFY SYMBOL.
*         ENTRY  (X1) = NAME. 
*         EXIT   (X1) = NAME UNCHANGED. 
*                (X6) = BLANK FILL NAME LEFT JUSTIFIED. 
*                (X7) = ZERO FILL NAME LEFT JUSTIFIED.
  
  
 LJUST    PS                 RETURN EXIT
          MX0    6
          SX2    1R 
          BX6    X1 
          LX7    X1 
 +        LX6    6
          LX7    6
          BX3    X0*X6
          BX6    X2+X6
          ZR     X3,*-1 
          EQ     LJUST
 SCAD     SPACE  4
**        SCAD - SCAN ADDRESS FIELD.
*         ENTRY  (X1) = FIELD WIDTH OF INSTRUCTION. 
*         EXIT VALUES IN EXVAL, EXREL, EXREG, EXEXT, EXERR. 
  
  
          USE    SCAN 
          SEG    ADDRESS SCANNING ROUTINES. 
 TEOP     DATA   0           TERM OPERATOR
 TEVAL    DATA   0           TERM VALUE 
 TEREL    DATA   0           TERM RELOCATION
 TECOE    DATA   0           TERM CO-EFFICIENT
 TEEXT    DATA   0           TERM EXTERNAL
  
 ELOP     DATA   0           ELEMENT OPERATOR 
 ELVAL    DATA   0           ELEMENT VALUE
 ELREL    DATA   0           ELEMENT RELOCATION 
 ELEXT    DATA   0           ELEMENT EXTERNAL 
 ELREG    DATA   0           ELEMENT REGISTER 
  
 KADFLAG  DATA   0           ADDRESS TERM FLAG
 EXERR    DATA   0           ADDRESS FIELD ERROR
 EXLGN    DATA   0           EXPRESSION FIELD LENGTH
 EXSTOP   DATA   0           STOP CHARACTER. 0=BLANK, 1=COMMA 
  
  
 SCAD     PS                 RETURN EXIT
          BX7    X1          SAVE EXPRESSION LENGTH 
          SA7    EXLGN
          SX6    B0          INITIALIZE FLAGS 
          LX7    X6 
          SA7    A7-B1       EXERR
          SA6    KADFLAG
          SA7    EXREL
          SA6    A7+B1       EXEXT
          SA7    A6+B1       EXREG
          BX6    -X6                                                    029A   6
          SA6    EXVAL       EXVAL = -0                                 029A   7
          SA2    UI+1        CLEAR RELEVANT PORTION OF *RVTAB*
          SA3    UI+2 
          SB6    X2 
          SB7    X3 
          SA1    O.RVTAB
          IX1    X1+X2
          SA7    X1-1        ENTRY FOR FIRST BLOCK
 +        SB6    B6+B1
          SA7    A7+B1
          LT     B6,B7,*
          SA1    CHAR 
  
*         ENTRY ON NEW TERM.
  
 SCAD1    SB7    X1-1R       TEST FOR BLANK OR COMMA
          ZR     B7,SCADX    IF BLANK 
          EQ     B7,B1,SCADX1 IF COMMA
          SX6    B0 
          BX7    X6 
          SA6    TEVAL       CLEAR TEVAL
          SA7    A6+B1       TREL 
          SA6    A7+B1       TECOE
          SX7    B1 
          SA7    TEOP        SET TEOP TO 1
  
*         ENTRY ON NEW ELEMENT. 
  
 SCAD2    SB7    X1-1R+ 
          ZR     B7,SCAD900  JUMP IF +
          EQ     B1,B7,SCAD900 JUMP IF -
          SB7    X1-1R& 
          ZR     B7,SCAD901  JUMP IF &
          SX6    B1          SET ELEMENT OPERATOR 
          SA6    ELOP 
 SCAD3    SX6    B0 
          MX7    60 
          SA6    ELREL
          SA7    A6-B1       SET ELVAL = -0 
          SA6    A6+B1       AND ELEXT = 0
          SA2    =30060020B  CHECK FOR BLANK, COMMA, PLUS, MINUS, & 
          SB7    X1 
          LX0    X2,B7
          NG     X0,SCAD4 
 SCANEV   BSSZ   1           RJ YEVITEM OR ZEVITEM TO EVAL. ITEM
          SA1    CHAR        RESTORE CHARACTER
          SA2    ELREG       TEST FOR A REGISTER
          ZR     X2,SCAD40   JUMP IF NOT A REGISTER 
          SA3    EXREG
          LX3    9
          BX6    X3+X2       OR ELREG INTO EXREG
          SA6    A3 
          EQ     SCAD4
 SCAD40   MX6    60          SET ADDRESS FLAG 
          SA6    KADFLAG
 SCAD4    SA2    ELOP        JUMP ON ELEMENT OPERATOR 
          SB7    X2 
          JP     B7+* 
  
 +        EQ     SCAD21      INITIAL OPERATION
 +        EQ     SCAD22      MULTIPLICATION 
 +        SA2    ELEXT       DIVISION 
          SA4    TEEXT
  
          SA5    TEREL
          SA3    A2-B1       ELREL
          BX2    X2+X3
          IX4    X4+X5
          BX2    X4+X2
          NZ     X2,SCAD225  JUMP IF ILLEGAL DIVISION 
          SA3    ELVAL       PERFORM DIVISION IF DENOMINATOR
          SA4    TECOE       IS NON-ZERO
          ZR     X3,SCAD220 
          BX6    X4          PERFORM TECOE = TECOE/ELVAL
          AX4    48          HIGH 12 BITS OF NUMERATOR
          ZR     X6,SCAD23A  IF NUMERATOR IS ZERO 
          BX7    X3 
          AX3    48          HIGH 12 BITS OF DENOMINATOR
          PX5    X7          FLOAT LOW DENOMINATOR = DD 
          SB7    48 
          PX3    B7,X3       FLOAT D
          NX3    X3,B6       NORMALIZE D
          NX7    X5,B5
          DX5    X3+X7       JUSTIFY EXPONENTS OF D AND DD
          PX4    X4,B7       FLOAT, NORMALIZE AND JUSTIFY N 
          FX2    X3+X7
          NX7    X4,B7
          PX3    X6 
          NX3    X3,B6
          FX4    X3+X7
          DX3    X3+X7
          FX6    X4/X2       N/D
          FX7    X6*X2       N/D*D
          FX0    X4-X7       REMAINDER OF N/D IN BOTH PRECISIONS
          DX7    X4-X7
          NX0    X0,B6       NORMALIZE AND JUSTIFY REMAINDER
          FX0    X7+X0
          DX7    X6*X2       N/D*D IN LOW PRECISION 
          FX4    X6*X5
          FX5    X3-X7
          FX5    X0+X5
          FX5    X5-X4
          FX3    X5/X2
          DX7    X6+X3
          FX6    X6+X3
          UX6    X6,B7
          LX6    X6,B7
          PL     B7,SCAD23B  JUMP IF NO LOW-ORDER PART
 SCAD23A  MX0    0
          IX6    X0+X6
          EQ     SCAD23C
 SCAD23B  UX7    X7,B7
          LX7    B7,X7
          IX6    X6+X7
 SCAD23C  SA6    TECOE       STORE RESULT 
          EQ     SCAD24 
 SCAD21   SA2    ELREL       ENTRY ON FIRST ELEMENT OF TERM 
          SA3    ELEXT
          NZ     X2,SCAD210  JUMP IF ELEMENT RELOCATABLE
          SA4    ELVAL       STORE ABSOLUTE VALUE OF ELEMENT
          BX6    X4 
          LX7    X3 
 +        SA6    TECOE
          SA7    TEEXT
          EQ     SCAD24 
 SCAD210  SX6    B1          NON-ABSOLUTE VALUES
          SA6    TECOE       SET TERM COEFFICIENT TO 1
 SCAD215  SA2    ELVAL       MOVE ELEMENT TO TERM 
          SA3    ELREL
          SA4    ELEXT
          BX6    X2 
          LX7    X3 
          SA6    TEVAL
          SA7    A6+B1       TEREL
          BX6    X4 
 +        SA6    TEEXT
          EQ     SCAD24 
 SCAD22   SA2    ELREL       ENTRY ON MULTIPLICATION
          SA3    ELEXT
          IX2    X3+X2
          ZR     X2,SCAD220  CHECK ABSOLUTE MULTIPLY
          SA2    TEREL
          SA3    TEEXT
          IX2    X2+X3
          ZR     X2,SCAD215  CHECK FOR REL TIMES EXT
 SCAD225  SX6    B1          COMPLAIN IF ERROR
          SA6    EXERR
          SA6    EFLG 
          SA6    AERR 
 SCAD24   SB7    X1-1R*      ENTRY AFTER ELEMENT
          ZR     B7,SCAD800  CHECK FOR * OR / OPERATORS 
          EQ     B1,B7,SCAD800
          SA2    TEOP        END OF TERM
          SA3    TECOE
          SX4    X2-1 
          SA2    TEEXT
          LX4    59-1 
          AX4    60 
          BX3    X3-X4
          SA4    A3-B1       TEREL
          NZ     X2,SCAD110  JUMP IF TERM EXTERNAL
          NZ     X4,SCAD112  JUMP IF TERM RELOCATABLE 
          SA4    TEOP 
          SX4    X4-5 
          SA5    EXVAL
          ZR     X4,SCAD24A  IF & OPERATOR
          IX6    X3+X5       ADD TERM VALUE INTO EXPRESSION 
          SA6    A5          EXVAL
          EQ     SCAD1
 SCAD24A  BX6    X3-X5       ADD TERM INTO EXPRESSION 
          SA6    A5 EXVAL 
          EQ     SCAD1
 SCAD110  SX6    B1          TERM IS EXTERNAL 
          BX7    X3 
          SA4    TEOP 
          SX4    X4-3 
          ZR     X4,SCAD110E IF - RELOC 
          SA4    EXEXT
          ZR     X4,SCAD111  COMPLAIN IF NOT FIRST EXTERNAL 
 SCAD110E SA6    AERR        ERROR
          SA6    EXERR
          SA6    EFLG 
 SCAD111  SA5    EXVAL
          IX7    X5+X7
          BX6    X2 
          SA7    A5          EXVAL          STORE NEW EXPRESSION VALUE
          SA6    A4          AND EXT NO 
          EQ     SCAD1
 SCAD112  SX0    256
          IX5    X4-X0       CHECK FOR NEGATIVE RELOCATION
          NG     X5,SCAD113 
          BX3    -X3
          LX4    X5 
 SCAD113  SA2    O.RVTAB     RECORD RELOCATION IN RELEVANT RVTAB ENTRY
          SB6    X2-1 
          SA2    B6+X4
          IX6    X2+X3
          SA6    A2 
          SA2    TEVAL       MULTIPLY COEFFICIENT BY VALUE
          RJ     SCADMU      PERFORM X7 = X2*X3 
          SA3    EXVAL
          IX6    X7+X3
 +        SA6    A3 
          EQ     SCAD1
 SCAD220  SA2    TECOE
          SA3    ELVAL
          RJ     SCADMU      PERFORM X7 = X2*X3 
 +        SA7    A2 
          EQ     SCAD24 
 SCADCON  SPACE  4
**        SCADCON - CALL SCAD AND RESTRICT RESULTS. 
*         ENTRY  (X6) = 1 TO OUTLAW REGISTER. 
*                (X6) = 2 TO OUTLAW REGISTER + EXTERNAL.
*                (X6) = 3 TO OUTLAW REGISTER + EXTERNAL + RELOCATABLE.
*                (X1) = FIELD WIDTH.
*         EXIT   (X1) = 0 IF NO ERRORS. 
  
  
 SCADCON  PS                 RETURN EXIT
          BX6    -X6
          SA6    SCADCONT    SAVE ENTRY PARAMETER 
          RJ     SCAD 
          SA1    EXERR       CHECK FOR ERROR IN EXPRESSION
          SA2    SCADCONT 
          SB7    X2 
          SX6    B1 
          MX7    0
 SCADCON1 SB7    B7+B1
          SA2    EXREG+B7 
          BX1    X2+X1
          NZ     B7,SCADCON1
          ZR     X1,SCADCON  IF NO ERRORS 
          SA6    AERR        SET AERR 
          SA6    EFLG 
          SA7    EXVAL       CLEAR OUT REPLY
          SA7    A7+B1       EXREL
          SA7    A7+B1       EXEXT
          SA7    A7+B1       EXREG
          EQ     SCADCON     RETURN 
  
 SCADCONT DATA   0           TEMPORARY STORAGE
 SCADMU   SPACE  4
**        SCADMU - 60-BIT INTEGER MULTIPLY FOR ADDRESS SCAN.
*         ENTRY  (X2) = MULTIPLIER. 
*                (X3) = MULTIPLICAND. 
*         EXIT   (X7) = PRODUCT.
  
  
 SCADMU   PS                 RETURN EXIT
          SB7    30 
          SB6    B7+B7       PRESET B6 = 60 
          AX7    B6,X2       GET HIGH ORDER SIGN BIT
          BX2    X7-X2       ABSOLUTE VALUE OF X2 
          AX6    X3,B6
          BX3    X6-X3       ABSOLUTE VALUE OF X3 
          MX0    30 
          BX7    X6-X7       SIGN OF RESULT 
          BX5    -X0*X3 
          AX3    30 
          BX6    -X0*X2 
          AX2    30 
          PX2    B7,X2       PACK AU WITH EXPONENT 30 
          PX5    X5          PACK BL WITH EXPONENT 00 
          DX2    X2*X5       1.  AU*BL,D   EXP = 30 
          PX4    X6          FORM AL
          DX6    X4*X5       2.  AL*BL,D   EXP = 0
          PX3    X3,B7       FORM BU
          DX3    X3*X4       3.  AL*BU,D  EXP = 30
          IX2    X2+X3       4.   1+ 3,I EXP = 30 
          FX4    X4*X5       5.  AL*BL,S  EXP = 48
          BX5    -X0*X4      TRUNCATE AL*BL,S 
          UX6    X6,B7       UNPACK 00 TERM 
          LX2    30 
          LX5    48          ALIGN DECIMAL POINTS 
          IX2    X2+X5
          BX3    X0*X2       DISCARD EXTRA BITS 
          IX6    X3+X6       ADD HIGH AND LOW PARTS 
          BX5    X6-X7       SIGN RESULT
          IX7    X5-X7       CORRECT -0 TO +0 
          EQ     SCADMU 
 SCADX    SPACE  4
**        SCADX - END OF EXPRESSION.
  
  
 SCADX1   RJ     GETCH       THROW AWAY COMMA 
 SCADX    SA3    UI+1 
          SA4    UI+2 
          SA5    EXERR
          SX6    B7          RECORD STOP CHARACTER
          SB6    X3 
          SB7    X4 
          SA6    EXSTOP 
          NZ     X5,SCAD56   IF EXPRESSION ERROR
          SA3    O.RVTAB     (X3) = FWA-1 RVTAB 
          SX3    X3-1 
          SA2    EXEXT
 SCADX2   SA5    X3+B6       NEXT RVTAB ENTRY 
          GT     B6,B7,SCAD53  IF END OF BLOCKS 
          SB6    B6+B1
          SB5    X5 
          ZR     X5,SCADX2   IF NO COEFFICIENT FOR THIS RELOCATION
          AX5    1
          SX6    B5-B1
          SX7    B6-B1
          LX6    7
          NZ     X5,SCAD55   IF NOT +1 OR -1, ERROR 
          NZ     X2,SCAD55   IF ANY OTHER RELOCATION OR EXTERNAL, ERROR 
          IX6    X7-X6       CALCULATE RELOCATION 
          BX2    X2+X6
          SA6    EXREL
          LE     B6,B7,SCADX2  LOOP 
 SCAD53   SA5    EXVAL       PROPAGATE MINUS ZERO 
          SA2    KADFLAG
          IX6    X5+X2
          SA6    A5 
          SA2    PPTYPE 
          PL     X2,SCAD61   IF ONES COMPLEMENT 
          SX2    X2+3 
          ZR     X2,SCAD61   PPTYPE NOT -1 NOR -2 
          PL     X6,SCAD61   IF RESULT POSITIVE 
          MX7    1
          SX2    B1 
          BX6    -X7*X6 
          IX6    X6+X2
          BX6    X6+X7
          SA6    A6 
 SCAD61   BSS    0
          SA2    EXLGN       CHECK FOR FIELD OVERFLOW 
          SB7    X2 
          AX7    X6,B7
          ZR     X7,SCAD
          SX7    B1          *** ADDRESS FIELD OVERFLOW 
          SA7    EFLG 
          SA7    W7ERR
          EQ     SCAD 
 SCAD55   SX6    B1 
          SA6    AERR 
          SA6    EFLG 
          SA6    EXERR
 SCAD56   SX7    B0 
          SX6    B0 
          SA7    EXVAL
          SA6    A7+B1       EXREL
          EQ     SCAD 
 SCAD800  SX6    X1-45B 
          SA6    ELOP 
          RJ     GETCH
          EQ     SCAD3
 SCAD900  SX6    X1-43B 
          SA6    TEOP 
          RJ     GETCH
          BX1    X6 
          EQ     SCAD2
 SCAD901  SX6    5
          SA6    TEOP 
          RJ     GETCH
          SX1    X6 
          EQ     SCAD2
 SMC      SPACE  4
**        SMC - SCAN MIXED BASE CONSTANT. 
*         ENTRY  (X6) = 1 TO OUTLAW REGISTER. 
*                (X6) = 2 TO OUTLAW REGISTER + EXTERNAL.
*                (X6) = 3 TO OUTLAW REGISTER + EXTERNAL + RELOCATABLE.
*                (X1) = FIELD WIDTH.
*         EXIT   (X1) = 0 IF NO ERRORS. 
  
  
 SMC      PS                 RETURN EXIT
          SA2    NBASE       SAVE NUMBER BASE 
          SA3    MBASE       SET NUMBER BASE
          BX7    X2 
          SA7    SMCA 
          BX7    X3 
          SA7    A2 
          RJ     SCADCON
          SA2    SMCA        RESTORE NUMBER BASE
          BX6    X2 
          SA6    NBASE
          EQ     SMC         RETURN 
  
 SMCA     DATA   0           NUMBER BASE
 SCD      TITLE  SCAN DATA ITEM.
**        SCD - SCAN DATA ITEM. 
*         SETS AERR AND EXERR IF BAD DATA OCCURS. 
*         ENTRY  (X2) = ORIGIN OF DATA. 
*                (X3) = LIMITING WORD COUNT FOR DATA. 
*                (X4) = ADDRESS FIELD FLAG. (1 ADDRESS, 0 DATA, -1 LIT) 
*                (X5) = FIELD WIDTH FOR CHARACTER DATA IN ADDRESS FIELD.
*         EXIT   (X3) = WORD COUNT OF DATA STORED.
  
  
          QUAL   DATA 
  
 SCDA     BSS    0
  
 RD       DATA   0           RADIX OF VALUE 
 SI       DATA   0           SIGN OF VALUE
 DV       DATA   0,0         DECIMAL VALUE
 OV       DATA   0,0         OCTAL VALUE
 RN       DATA   0           REAL NUMBER FLAG 
 FC       DATA   0           COUNT OF FRACTIONAL DIGITS 
  
 EF       DATA   0           -E- SCALE FLAG (1 = SINGLE, 2 = DOUBLE)
 ES       DATA   0           SIGN OF -E- SCALE FACTOR 
 EV       DATA   0           VALUE OF -E- SCALE FACTOR
  
 SF       DATA   0           -S- SCALE FLAG 
 SS       DATA   0           SIGN OF -S- SCALE FACTOR 
 SV       DATA   0           VALUE OF -S- SCALE FACTOR
  
 PF       DATA   0           -P- SCALE FLAG 
 PS       DATA   0           SIGN OF -P- SCALE FACTOR 
 PV       DATA   0           VALUE OF -P- SCALE FACTOR
  
 OC       DATA   0           OCTAL FLAG FOR 8 OR 9 DETECTED 
  
 SCDAL    EQU    *-SCDA-1 
  
 DO       DATA   0           DATA ORIGIN ADDRESS
 DL       DATA   0           WORD COUNT OF DATA FIELD 
 AF       DATA   0           ADDRESS FIELD FLAG (-1 LIT, 0 DATA, 1 ADD) 
 FW       DATA   0           FIELD WIDTH FOR CHARACTER DATA IN ADDRESS
  
  
 SCD      PS     0           ENTRY/EXIT 
          BX6    X2          STORE CALLING SEQUENCE PARAMETERS
          LX7    X3 
          SA6    DO 
          SA7    A6+B1
          BX6    X4 
          LX7    X5 
          SA6    A7+B1
          SA7    A6+B1
          SB4    SCDAL       CLEAR LOCAL VARIABLES
          MX6    0
          SX5    B1 
          SA6    SCDA 
          SA1    CHAR        FIRST CHARACTER
 SCD1     SB4    B4-B1
          SA6    A6+B1
          NZ     B4,SCD1
  
**        CHECK FIRST CHARACTER FOR SIGN OF DATA. 
  
          SB7    X1-1R+      CHECK CHARACTER
          ZR     B7,SCD2     IF *+* 
          NE     B7,B1,SCD3  IF NOT *-* 
          MX6    60          SET SIGN NEGATIVE
          SA6    SI 
 SCD2     RJ     GETCH       SKIP SIGN
  
**        CHECK FIRST CHARACTER TO DETERMINE DATA TYPE. 
  
 SCD3     SA2    =10000000401110436B     MASK FOR  #ZROLHDCBA 
          SB7    X1 
          AX2    X2,B7
          LX2    59 
          CX0    X2 
          PL     X2,NDS      IF NOT ONE OF THE ABOVE CHARACTERS 
          SB7    X0 
          JP     B7+SCDB-1   JUMP TO LETTER PROCESSOR 
 ERR      SPACE  4
**        ERR - PROCESS DATA ERROR AND EXIT.
  
  
 ERR      SX6    B1          NOTE ERROR IN DATA 
          SA6    EXERR
          SX3    B1          LENGTH = 1 
          SA6    EFLG 
          SA6    AERR 
          SA2    DO 
          SX6    B0          VALUE = 0
          SA6    X2 
 SCDX     SPACE  4
**        SCDX - PROCESS TERMINATOR AND EXIT. 
  
  
 SCDX     SA4    =36060020B  MASK FOR \+-*/ ,&@ 
          SA2    AF 
          NZ     X2,SCDX1    IF ADDRESS FIELD 
          SA4    =6BS12      MASK FOR \ ,@
 SCDX1    SB7    X1 
          LX6    X4,B7
          NG     X6,SCD      RETURN IF ONE OF THE ABOVE 
          RJ     GETCH       SKIP CHARACTER 
          EQ     ERR         PROCESS ERROR
 SCDB     SPACE  4
**        SCDB - JUMP TABLE FOR LEADING CHARACTER PROCESSORS. 
*         INDEXED BY BIT COUNT OF CHARACTER MASK. 
  
  
  
 SCDB     BSS    0
  
 +        EQ     HDS         # - HEXADECIMAL DATA 
  
 +        SB6    CSZ         Z - DELIMITED CHARACTER DATA 
          EQ     DCS
  
 +        SB6    CSR         R - DELIMITED CHARACTER DATA 
          EQ     DCS
  
 +        SX6    8           O - LEADING OCTAL RADIX
          EQ     LRS
  
 +        SB6    CSL         L - DELIMITED CHARACTER DATA 
          EQ     DCS
  
 +        SB6    CSH         H - DELIMITED CHARACTER DATA 
          EQ     DCS
  
 +        SX6    10          D - LEADING DECIMAL RADIX
          EQ     LRS
  
 +        SB6    CSC         C - DELIMITED CHARACTER DATA 
          EQ     DCS
  
 +        SX6    8           B - LEADING OCTAL RADIX
          EQ     LRS
  
 +        SB6    CSA         A - DELIMITED CHARACTER DATA 
          EQ     DCS
 NUMERIC  EJECT 
***       NUMERIC DATA. 
* 
* 
*         SRN.NR(MN)
*         *S* = SIGN (ASSUMED +)
*         *R* = RADIX (ASSUMED ACCORDING TO *BASE* PSEUDO)
*         *N.N* = NUMERIC DATA
*         *MN* = MODIFIER 
* 
*         ONE RADIX IS ALLOWED FOR EACH DATA ITEM.
*         D = DECIMAL.
*         O = OCTAL.
*         B = OCTAL.
* 
*         IF *.N* IS OMITTED, THE VALUE IS INTEGER. (ONLY INTEGER 
*         VALUES ARE ALLOWED IN PERIPHERAL ASSEMBLIES)
*         THE MAXIMUM VALUE IS 32 SIGNIFICANT OCTAL DIGITS OR 
*         7.9*(10**28). 
*         *8* OR *9* ARE ILLEGAL IF OCTAL RADIX IS SPECIFIED. 
* 
*         MODIFIERS MAY APPEAR IN ANY ORDER.
* 
*         ESN 
*         *S* = SIGN. 
*         *N* = SCALE VALUE.
*         SINGLE PRECISION DECIMAL SCALE, MAXIMUM VALUE = 32767.
* 
*         EESN
*         *S* = SIGN. 
*         *N* = SCALE VALUE.
*         DOUBLE PRECISION DECIMAL SCALE, MAXIMUM VALUE = 32767.
* 
*         PSN 
*         *S* = SIGN. 
*         *N* = SCALE VALUE.
*         BINARY POINT POSITION FOR FLOATING POINT NUMBERS. 
*         THE BINARY POINT WILL BE PLACED TO THE RIGHT OF *N*TH BIT,
*         AND THE EXPONENT WILL BE ADJUSTED TO A VALUE OF (EXP-*P*).
* 
*         SSN 
*         *S* = SIGN. 
*         *N* = SCALE VALUE.
*         BINARY SCALE, MAXIMUM VALUE = 32767.
 NUMERIC  SPACE  4
**        TRS - TRAILING RADIX SPECIFICATION. 
*         ENTRY  (X6) = RADIX.
*         EXIT   TO *NDS4*. 
  
  
 TRS      SA2    RD          CHECK RADIX SPECIFICATION
          NO
          SA6    A2 
          ZR     X2,NDS4     IF NO PREVIOUS RADIX 
          EQ     ERR
 NUMERIC  SPACE  4
**        LRS - PROCESS LEADING RADIX SPECIFICATION.
*         ENTRY  (X6) = RADIX.
*         EXIT   TO *NDS*.
  
  
 LRS      SA6    RD 
          RJ     GETCH       SKIP CHARACTER 
 NUMERIC  SPACE  4
**        NDS - NUMERIC DATA SCAN.
*         CONVERT UP TO 32 DIGITS, DECIMAL AND OCTAL. 
*         SET REAL NUMBER FLAG IF *.* ENCOUNTERED.
*         SET OCTAL FLAG IF *8* OR *9* ENCOUNTERED. 
*         SET FRACTION DIGIT COUNT. 
  
  
 NDS      MX0    -55         MASK FOR DIGIT OVERFLOW
          SX7    B0          H10 = 0
          SA2    COLUMN      INITIALIZE CARD POINTERS 
          SA1    X2+CARD-2
          SA0    7
          SA2    =7774BS21   MASK FOR \0123456789@
          MX3    0           L10 = 0
          BX4    X7          H8 = 0 
          IX5    X7+X7       L8 = 0 
          SB2    B0 
          SB3    B0 
          SB4    B0 
          SB5    B1+B1
          SB6    55 
          EQ     NDS2        ENTER LOOP 
  
*         (X7) = H10, (X3) = L10. 
*         (X4) = H8, (X5) = L8. 
*         (B4) = *8* OR *9* ENCOUNTERED.
*         (B3) = FRACTION DIGIT COUNT.
*         (B2) = *.* ENCOUNTERED. 
  
 NDS1     LX6    B5,X7       3.  8*H10
          IX7    X6+X7       H10 = (2)+(3)
          SB3    B2+B3       COUNT FRACTIONAL DIGITS
          BX2    -X2*X1      EXTRACT 8/9 BIT
          LX6    X3,B5       4.  8*L10
          SB4    X2+B4       8/9 PRESENCE 
          IX3    X1+X3       5.  (1)+DIGIT
          SA2    A2          REFETCH DIGITS MASK
          LX5    3           6.  8*L8 
          IX3    X6+X3       L10 = (4)+(5)
          LX4    3           H8 = 8*H8
          IX5    X1+X5       L8 = (6)+DIGIT 
  
 NDS2     SA1    A1+B1       NEXT CHARACTER 
          AX6    X3,B6       OVERFLOW FROM L10
          SB7    X1 
          IX7    X6+X7       H10 = H10+CARRY
          BX3    -X0*X3      CLEAR OVERFLOW FROM L10
          AX6    X5,B6       OVERFLOW FROM L8 
          IX4    X6+X4       H8 = H8+CARRY
          BX5    -X0*X5      CLEAR OVERFLOW FROM L8 
          LX6    X2,B7       CHECK CHARACTER
          SX1    X1-1R0      CONVERT CHARACTER TO DIGIT 
          IX3    X3+X3       1.  2*L10
          SX2    A0          RESET 7 IN X2
          LX7    1           2.  2*H10
          NG     X6,NDS1     LOOP IF CHARACTER = DIGIT
  
          SB7    B7-1R.      CHECK CHARACTER
          NZ     B7,NDS3     IF NOT *.* 
          SA1    A1+B1       NEXT CHARACTER 
          SA2    A2          SET UP FOR LOOP RE-ENTRY 
          ZR     B2,NDS2A    IF FIRST *.* 
          SX6    A1-CARD+1   ERROR, BUT FIRST SET CARD POINTERS 
          SA6    COLUMN 
          BX7    X1 
          SA7    CHAR 
          EQ     ERR
  
 NDS2A    SB2    B1          SET REAL NUMBER FLAG 
          SB7    X1 
          LX6    X2,B7
          SX2    A0 
          SX1    X1-1R0 
          NG     X6,NDS1     IF DIGIT 
  
 NDS3     SX1    X1+1R0      RESET NEXT CHARACTER 
          AX7    1           H10 = (2)/2
          AX6    X3,B1       L10 = (1)/2
          SA7    DV          SET DECIMAL VALUE
          SA6    A7+B1
          BX7    X4          SET OCTAL VALUE
          LX6    X5 
          SA7    A6+B1
          SA6    A7+B1
          SX7    B2          SET REAL NUMBER FLAG 
          SX6    B3          SET FRACTIONAL DIGIT COUNT 
          SA7    RN 
          SA6    FC 
          SX7    B4          SET OCTAL FLAG 
          SX6    A1-CARD+1   CORRECT CARD POINTERS
          SA7    OC 
          SA6    COLUMN 
          BX7    X1          SET NEXT CHARACTER 
          SA7    CHAR 
          NZ     B2,NDS5     IF REAL NUMBER 
 NUMERIC  SPACE  4
**        CHECK CHARACTER FOLLOWING NUMERIC DATA TO DETERMINE 
*         IF DATA IS NUMERIC COUNT CHARACTER STRING.
  
  
          SA2    =10000000401010412B     MASK FOR  #ZRLHCA
          SB7    X1 
          AX2    X2,B7
          CX0    X2 
          LX2    59 
          PL     X2,NDS5     IF NOT ONE OF THE ABOVE CHARACTERS 
          SB7    X0          JUMP TO CHARACTER CONSTANT PROCESSOR 
          JP     B7+NDSA-1
  
 NDSA     BSS    0
  
 +        EQ     HCD         # - HEXADECIMAL CHARACTER DATA 
  
 +        SB6    CSZ         Z - NUMERIC CHARACTER DATA 
          EQ     NCS
  
 +        SB6    CSR         R - NUMERIC CHARACTER DATA 
          EQ     NCS
  
 +        SB6    CSL         L - NUMERIC CHARACTER DATA 
          EQ     NCS
  
 +        SB6    CSH         H - NUMERIC CHARACTER DATA 
          EQ     NCS
  
 +        SB6    CSC         C - NUMERIC CHARACTER DATA 
          EQ     NCS
  
 +        SB6    CSA         A - NUMERIC CHARACTER DATA 
          EQ     NCS
 HCD      SPACE  4,8
**        HCD - HEXADECIMAL CHARACTER DATA. 
  
  
 HCD      SA3    DV          CHECK VALUE OF COUNT 
          SA2    A3+B1
          SA1    RD 
          BX2    X2+X3
          BX2    X2+X1
          NZ     X2,ERR      ERROR IF VALUE NOT ZERO OR RADIX DEFINED 
          MI     X2,ERR 
*         EQ     HDS
 HDS      SPACE  4,8
**        HDS - HEXADECIMAL DATA SCAN.
*         CONVERT UP TO 26 HEX DIGITS.
  
  
 HDS      SA2    COLUMN      INITIALIZE CARD POINTERS 
          MX0    -55         MASK FOR DIGIT OVERFLOW
          SX7    B0          H16 = 0
          SA1    X2+CARD-1
          MX3    0           L16 = 0
          SB6    55 
          MX4    4
          SX2    B0 
  
 HDS1     LX3    4
          LX7    4
          IX3    X3+X2       ADD IN NEW DIGIT 
          SA1    A1+B1       NEXT CHARACTER 
          AX6    X3,B6       OVERFLOW FROM L16
          BX3    -X0*X3      CLEAR OVERFLOW FROM L16
          IX7    X7+X6       H16 = H16 + CARRY
          ZR     X1,HDS2     IF COLON 
          SB7    X1-1RF-1 
          SX2    X1-1RA+10
          MI     B7,HDS1     IF *A* - *F* 
          SB7    X1-1R9-1 
          SX2    X1-1R0 
          PL     B7,HDS2     IF NOT *0* - *9* 
          PL     X2,HDS1     LOOP TO NON-HEX CHARACTER
  
 HDS2     SX6    A1-CARD+1   CORRECT CARD POINTERS
          SA7    DV          SET DECIMAL VALUE
          SA6    COLUMN 
          BX6    X3 
          SX7    10          SET RADIX DEFINED
          SA6    A7+B1
          SA7    RD 
          BX6    X1          SET NEXT CHARACTER 
          SA6    CHAR 
          EQ     NDS5 
 NUMERIC  SPACE  4
**        CHECK FOR TERMINATOR OR MODIFIER CHARACTERS.
  
  
 NDS4     RJ     GETCH
 NDS5     SA2    =2003036000002300064B MASK FOR \&, /*-+SPOEDB@ 
          SB7    X1 
          AX2    B7,X2
          LX2    59 
          CX0    X2 
          PL     X2,ERR      ERROR IF NOT ONE OF THE ABOVE CHARACTERS 
          SB7    X0          JUMP TO PROCESSOR
          SA3    AF          (B4) = ADDRESS FIELD FLAG
          SB4    X3 
          JP     B7+NDSB-1
 NUMERIC  SPACE  4
**        NDSB - TRAILING CHARACTER JUMP TABLE. 
*         INDEXED BY BIT COUNT OF CHARACTER MASK. 
  
  
 NDSB     BSS    0
  
 +        NZ     B4,NDS6     & - END IF ADDRESS FIELD 
          EQ     ERR
  
 +        EQ     NDS6        COMMA
  
 +        EQ     NDS6        BLANK
  
 +        NZ     B4,NDS6     / - END IF ADDRESS FIELDS
          EQ     ERR
  
 +        NZ     B4,NDS6     * - END IF ADDRESS FIELDS
          EQ     ERR
  
 +        NZ     B4,NDS6     - - END IF ADDRESS FIELDS
          EQ     ERR
  
 +        NZ     B4,NDS6     + - END IF ADDRESS FIELDS
          EQ     ERR
  
 +        SB6    SF+1        S - -S- SCALE
          EQ     SSC
  
 +        SB6    PF+1        P - -P- SCALE
          EQ     PSC
  
 +        SX6    8           O - TRAILING OCTAL RADIX 
          EQ     TRS
  
 +        SB6    EF+1        E - -E- SCALE
          EQ     ESC
  
 +        SX6    10          D - TRAILING DECIMAL RADIX 
          EQ     TRS
  
 +        SX6    8           B - TRAILING OCTAL RADIX 
          EQ     TRS
 NUMERIC  SPACE  4
**        END OF NUMERIC DATA.
  
  
 NDS6     SA2    RD          CALCULATE RADIX
          SA3    NBASE
          NZ     X2,NDS7     IF NO RADIX SPECIFIED
          BX2    X3          RADIX = NBASE
 NDS7     SB6    X2-10       (B6) = RADIX-10
          SA2    DV          PRESET DECIMAL VALUE 
          SA3    A2+B1
          SA4    EV          (X0) = SIGNED -E- SCALE VALUE
          SA5    A4-B1
          BX0    X4-X5
          SA4    SV          (X6) = SIGNED -S- SCALE VALUE
          SA5    A4-B1
          BX6    X4-X5
          SA4    FC 
          ZR     B6,NDS8     IF DECIMAL NUMBER
  
**        CHECK OCTAL FIELD FOR CHARACTERS 8 OR 9.
  
          SA2    OV          USE OCTAL VALUE
          IX6    X6-X4       ADJUST -S- SCALE FOR FRACTIONAL DIGITS 
          LX4    1
          SA3    A2+B1
          IX6    X6-X4
          SA4    OC          CHECK OCTAL FLAG 
          NZ     X4,ERR      ERROR IF *8* OR *9* ENCOUNTERED IN SCAN
  
 NDS8     IX7    X0-X4       ADJUST -E- SCALE FOR FRACTIONAL DIGITS 
          SA6    SV 
          SA7    EV 
  
**        FORM TRIPLE PRECISION FLOATING VALUE FROM 105 BIT VALUE.
*         (X5) = HIGH.
*         (X6) = MIDDLE.
*         (X7) = LOW. 
  
          MX0    -41
          PX7    X3          LOW = BITS 0 - 47 OF LOW VALUE 
          AX3    48          1.  BITS 48 - 59 OF LOW VALUE
          BX4    -X0*X2      2.  BITS 0 - 40 OF HIGH VALUE
          LX4    7
          BX6    X4+X3       MIDDLE = (2)+(1) 
          SB7    48          MIDDLE EXPONENT = 48 
          AX2    41          HIGH = BITS 41 - 59 OF HIGH VALUE
          SB6    B7+B7       HIGH EXPONENT = 96 
          PX6    X6,B7
          PX5    X2,B6
  
**        NORMALIZE FLOATING VALUE. 
  
          NX0    B7,X7
          NX5    B7,X5
          NX6    B7,X6
          FX2    X0+X6
          DX3    X0+X6
          FX7    X5+X2
          DX4    X5+X2
          FX6    X4+X3
          DX5    X4+X3
  
**        BEGIN SCALING.
*         (B7) = ACCUMULATED EXPONENT.
  
          SB7    B0 
          SA2    EV 
          ZR     X5,NDS9     IF VALUE = 0 
 NUMERIC  SPACE  4
**        PROCESS -E- SCALING.
  
  
          SA7    SCVC        SAVE NORMALIZED VALUE
          SA6    A7+B1
          BX0    X2 
          LX7    X5 
          SA7    A6+B1
          SA5    DV          PRESET (A5) TO HIGH ORDER OF VALUE 
          PL     X2,SCV1     IF POSITIVE DECIMAL SCALING
          SX6    15 
          IX7    X6-X0       15-(E SCALE VALUE) 
          BX0    X7-X6
          SA2    SCVA        10**(-16)
          SA3    A2+B1
          SA4    A3+B1
          EQ     SCV2 
  
 SCV1     MX4    0           CLEAR LOW PART OF 10**16 
          SX3    B0 
          SA2    =1.0E16
  
 SCV2     MX1    -4 
          BX5    -X1*X0      EXTRACT SMALL POWER OF 10
          AX0    4           POSITION 10**16 BIT
          SB6    B0          CLEAR 10 EXPONENT CUMULANT 
          SA0    X5+SCVB     PRESET FOR POWERS OF TEN 
          UX2    B5,X2       EXTRACT EXPONENT 
          SX1    B5 
          SB5    -48
          PX6    X3,B5       REPACK WITH ZERO EXPONENTS 
          SB5    B5+B5
          PX5    X2 
          PX7    X4,B5
          EQ     SCV4        ENTER SCALE LOOP 
  
 SCV3     SA5    DV 
          SA3    A5+B1
          SA4    A3+B1
          BX2    X5 
          RJ     TPM         SQUARE POWER OF 10 
  
 SCV4     SX1    X1+B6       DOUBLE BINARY EXPONENT 
          SB6    X1+B6       AND CUMULATE 
          SX1    B1 
          BX2    X0*X1       EXTRACT NEXT POWER BIT 
          AX0    1
          SA6    A5+B1       STORE SCALED POWER OF 10 
          SA7    A6+B1
          BX6    X5 
          SA6    A5 
          ZR     X2,SCV5     IF THIS POWER DOES NOT APPLY 
          SA2    SCVC        FETCH SCALED CUMULANT
          SA3    A2+B1
          SA4    A3+B1
          SB7    B7+B6       ADD EXP OF POWER TO EXP OF CUMULANT
          RJ     TPM         MULTIPLY BY POWER OF 10
          SB7    X1+B7       LAST BIT TO EXPONENT SCALING 
          SA6    SCVC+1 
          SA7    A6+B1
          BX6    X5 
          SA6    A6-B1
 SCV5     NZ     X0,SCV3     IF MORE SCALING NECESSARY
  
          SA1    A0          LOAD POWER BETWEEN 1 AND 10**15
          SA2    SCVC+2      REFETCH SCALED VALUE 
          SA3    A2-B1
          SA4    A3-B1
          FX7    X1*X2       1.  T*AL       S L 
          DX6    X1*X3       2.  T*AM       D L 
          FX7    X7+X6       3.  (1)+(2)    S L 
          FX2    X1*X3       4.  T*AM       S M 
          DX3    X1*X4       5.  T*AU       D M 
          FX5    X2+X3       6.  (4)+(5)    S M 
          FX6    X1*X4       7.  T*AU       S U 
          DX1    X2+X3       8.  (4)+(5)    D L 
          FX7    X7+X1       9.  (3)+(8)    S L 
          SA2    EF 
          SA3    RN 
          AX2    1
          ZR     X3,SCV6     IF INTEGER NUMBER
  
**        ROUND VALUE.
  
          NZ     X2,SCV6     IF DOUBLE PRECISION
          RX6    X6+X5       ROUND DOUBLE TO SINGLE 
          MX5    0           MIDDLE = 0 
          BX7    X1-X1       LOW = 0
  
 SCV6     DX4    X5+X6       ROUND TRIPLE TO DOUBLE 
          FX5    X5+X6
          RX6    X4+X7
          DX7    X5+X6       (X7) = LOW 
          FX6    X5+X6       (X6) = HIGH
          UX1    B5,X6       (B7) = EXPONENT OF HIGH
          SB7    B7+B5
  
**        PERFORM -S- SCALING.
  
          SA1    SV 
          SB7    B7+X1
          PX6    X6,B7
          SB5    B7-2000B    CHECK EXPONENT 
          SA1    CHAR        NEXT CHARACTER 
          PL     B5,ERR      EXPONENT EXCEEDS MAXIMUM ALLOWABLE 
          SB5    -1777B 
          SB6    B7-48
          ZR     X7,SCV7     IF LOW = 0 
          PX7    X7,B6
 SCV7     LT     B5,B6,SCV8  IF MIDDLE IS RELEVANT
          MX7    0           MIDDLE = 0 
          LT     B5,B7,SCV8 
          MX6    0           CLEAR UNDER FLOW QUANTITY
 SCV8     SA3    RN 
          ZR     X3,INT      IF INTEGER NUMBER
          SA4    MACHINE     CHECK CODE TYPE
          NZ     X4,ERR      ERROR IF PP CODE 
  
**        PERFORM -P- SCALING.
  
          SA5    PF 
          ZR     X5,NDS9     COMPLETE VALUE IF NO -P- SCALE 
          SA3    PV          SET SIGNED -P- VALUE 
          SA4    PS 
          BX0    X3-X4
          UX6    B7,X6
          SX4    -B7
          IX0    X4-X0
          UX7    B6,X7
          NG     X0,ERR      IF -P- SCALE TOO BIG 
          SB5    -48         PREPARE SINGLE PRECISION 
          ZR     X2,SCV9     IF SINGLE PRECISION
          SB5    -96         PREPARE DOUBLE PRECISION 
 SCV9     SB5    X0+B5
          PL     B5,ERR      IF -P- SCALE WILL LOOSE ALL BITS 
          SB5    X0 
          AX7    X7,B5
          SX3    B1 
          LX4    X3,B5
          IX3    X4-X3
          BX4    X6*X3
          AX6    X6,B5
          SB6    B5-48
          AX0    X4,B6
          BX7    X0+X7
          SB7    B7+B5
          PX6    X6,B7       APPEND FINAL EXPONENT
          SB7    B7-48
          PX7    X7,B7
 NUMERIC  SPACE  4
**        STORE FINAL VALUE.
  
  
 NDS9     SA2    EF          CHECK PRECISION
          AX2    1
          SA3    DO          DATA DESTINATION ADDRESS 
          SA4    DL          WORD COUNT OF DATA FIELD 
          SA5    SI 
          BX6    X6-X5       CORRECT FOR SIGN 
          BX7    X7-X5
          SA6    X3          STORE UPPER
          AX4    1           CHECK DATA FIELD 
          SX3    B1          WORD COUNT OF DATA = 1 
          ZR     X2,SCDX     EXIT IF SINGLE PRECISION 
          ZR     X4,ERR      ERROR IF NO ROOM IN DATA FIELD FOR LOWER 
          SA7    A6+B1       STORE LOWER
          SX3    B1+B1       WORD COUNT OF DATA = 2 
          EQ     SCDX        EXIT 
 NUMERIC  SPACE  4
**        INT - CONVERT TO INTEGER VALUE. 
  
  
 INT      UX6    B7,X6       UNPACK HIGH
          UX0    B6,X7       UNPACK LOW 
          SB5    B7-13
          LX6    X6,B7
          SX7    B1          SET SINGLE PRECISION 
          LX0    X0,B6
          BX6    X6+X0       COMBINE HIGH AND LOW VALUE 
          SA7    EF 
          NG     B5,NDS9     IF INTEGER WITHIN RANGE
          EQ     ERR         ERROR
 NUMERIC  EJECT  4                                                       CPSA097
**        ESC - SET -E- SCALE.
  
  
 ESC      SX7    B1          PRESET SINGLE PRECISION
          RJ     GETCH       NEXT CHARACTER 
          SB2    X1-1RE 
          NZ     B2,SSV      IF NOT *E* 
          SX7    B1+B1       SET DOUBLE PRECISION 
          RJ     GETCH       NEXT CHARACTER 
          EQ     SSV
 NUMERIC  SPACE  4
**        PSC - SET -P- SCALE.
  
  
 PSC      SA2    RN 
          ZR     X2,ERR      IF NOT REAL NUMBER 
 NUMERIC  SPACE  4
**        SSC - SET -S- SCALE.
  
  
 SSC      SX7    B1 
          RJ     GETCH       NEXT CHARACTER 
 NUMERIC  SPACE  4
**        SSV - SET SCALE VALUE.
*         ENTRY  (X7) = SCALE FLAG. 
*                (B6) = ADDRESS OF SCALE TYPE SIGN. 
  
  
 SSV      SA5    B6-B1       CHECK SCALE FLAG 
          SA7    B6-B1       STORE SCALE FLAG 
          NZ     X5,ERR      ERROR IF DUPLICATED SPECIFICATION
          MX7    0
          SB7    X1-1R+      CHECK CHARACTER
          ZR     B7,SSV1     IF + 
          NE     B7,B1,SSV2  IF NOT - 
          MX6    60          SET SIGN NEGATIVE
          SA6    B6 
  
 SSV1     RJ     GETCH       NEXT CHARACTER 
 SSV2     SB7    X1-1R0      CHECK CHARACTER
          SB5    X1-1R9 
          NG     B7,SSV3     IF ALPHA 
          GE     B5,B1,SSV3  IF NOT DIGIT 
          BX5    X7          ACCUMULATION * 10
          LX7    2
          IX5    X7+X5
          LX5    1
          SX3    B7 
          IX7    X5+X3
          EQ     SSV1        LOOP 
  
 SSV3     SA7    B6+B1       STORE VALUE
          EQ     NDS5        RETURN TO PROCESS NEXT CHARACTER 
 TPM      SPACE  4
**        TPM - TRIPLE PRECISION MULTIPLY.
*         ENTRY  (X2,X3,X4) = 1ST FACTOR. 
*                (X5,X6,X7) = 2ND FACTOR. 
*         EXIT   (X5,X6,X7) = PRODUCT.
  
  
 TPM      PS     0           ENTRY/EXIT 
          FX6    X5*X4       1.  BU*AL      S L 
          DX7    X5*X3       2.  BU*AM      D L 
          FX4    X6+X7       3.  (1)+(2)    S L 
          FX6    X5*X3       4.  BU*AM      S M 
          DX7    X5*X2       5.  BU*AU      D M 
          FX1    X6+X7       6.  (4)+(5)    S M 
          SA5    A5+B1       BM 
          DX6    X6+X7       7.  (4)+(5)    D L 
          FX7    X5*X3       8.  BM*AM      S L 
          FX4    X4+X6       9.  (3)+(7)    S L 
          DX6    X5*X2       10.  BM*AU     D L 
          FX4    X7+X4       11.  (8)+(9)   S L 
          FX3    X6+X4       12.  (10)+(11) S L 
          FX7    X5*X2       13.  BM*AU     S M 
          FX6    X1+X7       14.  (6)+(13)  S M 
          SA4    A5+B1       BL 
          SA5    A5-B1       BU 
          DX7    X1+X7       15.  (6)+(13)  D L 
          FX7    X3+X7       16.  (12)+(15) S L 
          FX3    X4*X2       17.  BL*AU     S L 
          FX5    X5*X2       18.  BU*AU     S U 
          FX7    X7+X3       19.  (16)+(17) S L 
          FX3    X6+X7       POST NORMALIZE RESULT
          DX4    X6+X7
          FX2    X3+X5
          DX5    X3+X5
          FX3    X4+X5
          DX4    X4+X5
          UX2    B5,X2
          SX1    B5 
          SB5    -48
          PX6    X3,B5       REPACK WITH ZERO EXPONENTS 
          SB5    B5+B5
          PX5    X2 
          PX7    X4,B5
          EQ     TPM         RETURN 
 SCVA     SPACE  4
**        SCVA - 10**(-16) IN TRIPLE PRECISION. 
  
  
 SCVA     BSS    0
          CON    16327151262457542115B
          CON    15527025551413537150B
          CON    14723630465154737561B
 SCVB     SPACE  4
**        SCVB - TABLE OF POWERS OF 10. 
  
  
 SCVB     BSS    0
          CON    1. 
          CON    10.
          CON    100. 
          CON    1.E3 
          CON    1.E4 
          CON    1.E5 
          CON    1.E6 
          CON    1.E7 
          CON    1.E8 
          CON    1.E9 
          CON    1.E10
          CON    1.E11
          CON    1.E12
          CON    1.E13
          CON    1.E14
          CON    1.E15
  
 SCVC     DATA   0,0,0       TEMPORARY STORAGE FOR SCALING
 CHAR     EJECT 
***       CHARACTER DATA. 
* 
* 
*         NFCCC-CCC 
*         GENERATE *N* CHARACTERS OF DATA FROM THE STRING *CCC-CCC* IN
*         FORMAT *F*. 
*         *N* MUST NOT BE BLANK FOR ADDRESS FIELDS. 
*         IF *N* IS PRECEDED BY A *-*, THE CHARACTER STRING WILL BE 
*         COMPLEMENTED. 
*         IF *N* = *0*, STRING IS TERMINATED BY \+-*/, @ FOR ADDRESS
*         FIELDS, BY \, @ FOR *DATA*, *LIT*, OR LITERAL FIELDS. 
* 
*         F/CCC-CCC/
*         GENERATE DATA FROM CHARACTER STRING *CCC-CCC* IN FORMAT *F*.
*         */* IS ANY DELIMITER CHARACTER. 
* 
*         F      JUSTIFY     FILL 
* 
*         H      LEFT        TRAILING BLANK 
*         A      RIGHT       LEADING BLANK
*         C      LEFT        TRAILING ZERO, TWO ZEROS GUARANTEED
*         Z      LEFT        TRAILING ZERO, ONE ZERO GUARANTEED 
*         L      LEFT        TRAILING ZERO
*         R      RIGHT       LEADING ZERO 
 CHAR     SPACE  4
**        DCS - DELIMITED CHARACTER STRING. 
*         ENTRY  (B6) = ADDRESS OF CHARACTER STRING PROCESSOR.
  
  
 DCS      SB2    -B1         CLEAR CHARACTER COUNT
          SA0    B0          SET FLAG TO THROW AWAY TERMINATOR
          RJ     GETCH       GET DELIMITING LETTER
          SA2    LASTCOL     STORE IN LAST COLUMN 
          SA3    X2+CARD
          SA6    A3          STORE DELIMITER AT END OF CARD 
          BX0    X1          SAVE DELIMITER 
          BX6    X3 
  
 DCS1     SB2    B2+B1       COUNT CHARACTER
          SA1    A1+B1       FETCH NEXT CHARACTER 
          SB3    A1 
          BX4    X1-X0
          NZ     X4,DCS1     IF NOT DELIMITER 
          SA6    A6          RESET LAST COLUMN TO * * 
          SB7    X0-1R
          SX6    A6-B3
 +        ZR     B7,*+1      IF DELIMITER IS * *
          ZR     X6,ERR      IF MISSING DELIMITER 
          SA1    AF          (X1) = ADDRESS FIELD FLAG
          SX1    X1-1 
          JP     B6          PROCESS CHARACTER STRING 
 CHAR     SPACE  4
**        NCS - NUMERIC COUNT CHARACTER STRING. 
*         ENTRY  (B6) = ADDRESS OF CHARACTER STRING PROCESSOR.
  
  
 NCS      SA3    DV          CHECK VALUE OF COUNT 
          SA2    A3+B1
          SA0    B1          SET FLAG TO SAVE TERMINATOR
          NZ     X3,ERR      ERROR IF UPPER PART OF VALUE " 0 
          SB2    X2 
          SA2    RD 
          NZ     X2,ERR      ERROR IF RADIX SPECIFIED 
          SA4    COLUMN 
          SX5    CARD+71*NCARDS 
          SX7    X4+B2       CHECK THAT THIS DOES NOT EXCEED END
          IX6    X5-X7
          NG     X6,ERR 
          NZ     B2,NCS3     IF NON-ZERO VALUE
          SX3    3000B       MASK FOR \ ,@
          SA2    AF 
          LX3    36 
          SB2    X2 
          NE     B2,B1,NCS1  IF NOT ADDRESS FIELD 
          SA3    =2003036BS36 MASK FOR \& ,/*-+@
 NCS1     SB2    -B1
          SA1    X4+CARD-1   SET FOR DELIMITER SCAN 
 NCS2     SA1    A1+B1
          SB7    X1 
          AX2    X3,B7
          SB2    B2+B1
          LX2    59 
          PL     X2,NCS2
 NCS3     SA1    AF          (X1) = ADDRESS FIELD FLAG
          SX1    X1-1 
          JP     B6          PROCESS CHARACTER STRING 
 CHAR     SPACE  4
**        CSH - PROCESS -H- FORMAT. 
  
  
 CSH      SX6    -B1
          SB3    B0          NO LEADING CHARACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB4    X6          SET TRAILING CHARACTER COUNT 
          SX7    B1 
          SX0    1R          SPACE FILL 
          SA7    SF 
          NG     X1,GCS      IF NOT ADDRESS FIELD 
          SA7    SV          SET JUSTIFICATION FLAG 
 CHAR     SPACE  4
**        CSA - PROCESS -A- FORMAT. 
  
  
 CSA      SX6    -B1
          SB4    B0          NO TRAILING CHRACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB3    X6          SET LEADING CHARACTER COUNT
          SX0    1R          SPACE FILL 
          SX7    B1 
          SA7    SF 
          EQ     GCS
 CHAR     SPACE  4
**        CSC - PROCESS -C- FORMAT. 
  
  
 CSC      SX6    B1 
          SB3    B0          NO LEADING CHARACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB4    X6          SET TRAILING CHARACTER COUNT 
          MX0    1           ZERO FILL, NO CONVERSION                   P069  13
          NG     X1,GCS      IF NOT ADDRESS FIELD 
 CHAR     SPACE  4
**        CSZ - PROCESS -Z- FORMAT. 
  
  
 CSZ      SX6    B0 
          SB3    B0          NO LEADING CHARACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB4    X6          SET TRAILING CHARACTER COUNT 
          MX0    1           ZERO FILL, NO CONVERSION                   P069  15
          NG     X1,GCS      IF NOT ADDRESS FIELD 
 CHAR     SPACE  4
**        CSL - PROCESS -L- FORMAT. 
  
  
 CSL      SX6    -B1
          SB3    B0          NO LEADING CHARACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB4    X6          SET TRAILING CHARACTER COUNT 
          MX0    1           ZERO FILL, NO CONVERSION                   P069  17
          NG     X1,GCS      IF NOT ADDRESS FIELD 
          SX7    B1          SET JUSTIFICATION FLAG 
          SA7    SV 
 CHAR     SPACE  4
**        CSR - PROCESS -R- FORMAT. 
  
  
 CSR      SX6    -B1
          SB4    B0          NO TRAILING CHRACTERS
          RJ     CCS         COMPUTE CHARACTER STRING 
          SB3    X6          SET LEADING CHARACTER COUNT
          MX0    1           ZERO FILL, NO CONVERSION                   P069  19
          EQ     GCS
 CHAR     SPACE  4
**        GCS - GENERATE CHARACTER STRING.
*         ENTRY  (X0) = FILL CHARACTER. 
*                (X3) = EFFECTIVE CHARACTER COUNT.
*                (B2) = DATA CHARACTER COUNT. 
*                (B3) = LEADING FILL CHARACTER COUNT. 
*                (B4) = TRAILING FILL CHARACTER COUNT.
*                (A0) = FLAG TO SAVE TERMINATOR CHARACTER.
  
  
 GCS      SA5    DO          PRESET BYTE COUNTERS AND WORD VALUE
          SA4    DL 
          SB7    X3 
          SB6    X3 
          MX7    0
          MI     X0,GCS1A    IF NO FILL CHARACTER 
          SA1    CT 
          SX1    X1-45
          NZ     X1,GCS1A    IF NOT 8-BIT ASCII 
          SX7    1002B       INITIALIZE TRAILING FILL TO SPACE
 GCS1A    BSS    0
          SB5    X4          (B5) = LIMITING WORD COUNT 
          SA1    CT 
          MX3    -6 
          SA2    PPTYPE 
          PL     X2,GCS1B    IF NOT 8-BIT 
          SX2    X2+2 
          MI     X2,GCS1B    IF NOT 8-BIT 
          MX3    -8 
 GCS1B    BSS    0
          SX4    -B4
          SB4    X1          (B4) = CHARACTER TYPE SHIFT
          ZR     B3,GCS2     IF NO LEADING FILL 
  
 GCS1     BX6    X0          PACK LEADING FILL CHARACTERS 
          SB3    B3-B1
          RJ     STC
          NZ     B3,GCS1
  
 GCS2     SB3    B2+B2
          ZR     B2,GCS4
 GCS3     SB2    B2-B1       PACK CHARACTERS
          RJ     GETCH
          RJ     STC
          NZ     B2,GCS3
 GCS4     SB2    A0 
          ZR     X4,GCS6     IF NO TRAILING FILL
  
 GCS5     SX4    X4+B1
          BX6    X0          PACK TRAILING FILL CHARACTRRS
          RJ     STC
          NZ     X4,GCS5
  
 GCS6     NZ     B2,GCS7     THROW AWAY TERMINATOR IN BRACKET CASE
          RJ     GETCH
 GCS7     RJ     GETCH       THROW AWAY LAST CHARACTER
          SA4    A5 
          IX3    X5-X4       CALCULATE WORD COUNT 
          SA2    SV 
          ZR     X2,GCS9     IF NO JUSTIFICATION
          SA2    FW 
          SA3    PPTYPE 
          SX6    B3+B3       DATA CHARACTER COUNT * 4 
          SX0    X6+B3
          SA5    CT          CHARACTER TYPE SHIFT COUNT 
          SX5    X5-45
          NZ     X5,GCS7A    IF NOT 8-BIT ASCII 
          LX0    X6,B1
 GCS7A    BSS    0
          IX0    X2-X0
          SB7    X0 
          SA5    X4 
          LX7    B7,X5
          SA7    A5 
          PL     X3,GCS8     IF NOT HEX CHARACTERS
          SX3    X3+2 
          MI     X3,GCS8     IF NOT BCU/MCU 
          LX0    X6,B1
          IX0    X2-X0       SHIFT = FW - 8 * DATA CHARACTER COUNT
          SB7    X0 
          SB2    B7-48
          LX6    X5,B7
          MX7    12 
          LX5    X5,B2
          LX7    X7,B2
          BX6    X7*X6
          BX7    -X7*X5 
          BX6    X6+X7
          SA6    A5 
 GCS8     PL     B7,GCS9     IF NO TRUNCATION 
          SX6    B1 
          SA6    W7ERR
          SA6    EFLG 
 GCS9     SA2    SF 
          ZR     X2,SCDX     EXIT IF NO JUSTIFICATION NECESSARY 
          SA2    FW 
          SB7    X2-60
          ZR     B7,SCDX
          MX6    1
          SB7    B7+B1
          LX6    X6,B7
          SA5    X4 
          BX6    -X6*X5 
          SA6    X4 
          EQ     SCDX        EXIT 
 CHAR     SPACE  4
**        CCS - CALCULATE CHARACTER STRING. 
*         ENTRY  (B2) = CHARACTER COUNT.
*                (X1) = ADDRESS FIELD FLAG - 1. 
*                (X6) = EXTRA CHARACTER FLAG. 
*         EXIT   (X6) = (B2+NCHARS+X6)/NCHARS*NCHARS-B2.
*                (X3) = EFFECTIVE VALUE OF NCHARS.
*         SAVES  X1, B2, B3, B4, A0.
  
  
 CCS2     BX4    X3 
          IX7    X6/X4
          SB7    -B2
          DX6    X7*X3
          SX6    X6+B7
          SA5    CT 
          SX5    X5-45
          NZ     X5,CCS      IF NOT 8-BIT ASCII 
          SX3    6           6 CHARACTERS PER WORD
          SX6    X6-4 
  
 CCS      PS     0           ENTRY/EXIT 
          MX7    0           CLEAR JUSTIFICATION
          SA7    SF 
          SA3    NCHARS 
          NG     X1,CCS1     IF NOT ADDRESS FIELD 
          SX3    10 
          SA4    PPTYPE 
          PL     X4,CCS1
          SX4    X4+2 
          MI     X4,CCS1     IF NOT BCU/MCU.
          SX3    6
 CCS1     SX7    X6+B2
          IX6    X7+X3
          AX7    X3,B1       TRUNCATE TO MULTIPLE OF NCHARS 
          SB7    -B2
          ZR     X7,CCS1.1   IF MCU DATA
          AX7    1
          NZ     X7,CCS2     IF ADDRESS OR CENTRAL DATA 
          AX6    1
          IX6    X6+X6
 CCS1.1   SX6    X6+B7
          EQ     CCS         RETURN 
 CHAR     SPACE  4
**        STC - STORE CHARACTER.
* 
*         ENTRY  (X3) = CHARACTER MASK FOR 6 OR 8 BIT CHARACTER.
*                (X5) = STORE ADDRESS.
*                (X6) = CHARACTER TO BE STORED. 
*                (X7) = ACCUMULATION WORD.
*                (B2) = DATA CHARACTER COUNT. 
*                (B3) = LEADING FILL CHARACTER COUNT. 
*                (B4) = CHARACTER TYPE SHIFT. 
*                (B5) = LIMITING WORD COUNT.
*                (B6) = EFFECTIVE CHARACTER COUNT.
*                (B7) = CHARACTER COUNT.
  
  
  
 STC1     SA7    X5          STORE COMPLETED WORD 
          SX5    X5+B1       INCREMENT STORE ADDRESS
          MX7    0           CLEAR CUMULATING WORD
  
 STC      EQ     *+1S17      ENTRY/EXIT 
  
*         THE FOLLOWING WORD *STC0* IS MODIFIED FROM VARIOUS PLACES TO
*         MAKE *STC* STORE EITHER 6 OR 8-BIT CHARACTERS, AND TO 
*         SELECTIVELY HANDLE ASCII CONVERSION.
  
 STC0     SX2    0           SET FOR NO ASCII CONVERSION
          LX7    6           SHIFT ASSEMBLY FOR 6-BIT CHARS 
          SB7    B7-B1       DECREMENT CHARACTER COUNT
  
          MI     X6,STC2
          SA1    X6+STCA
          AX1    X1,B4
          BX6    -X3*X1 
          IX6    X6+X2
          BX7    X7+X6       OR IN CHARACTER
 STC2     NZ     B7,STC      RETURN IF NOT END OF WORD
          SA1    SI          COMPLEMENT ON SIGN 
          BX7    X7-X1
          SB5    B5-B1
          SB7    B6          RESET CHARACTER COUNTER
          PL     B5,STC1     IF STILL IN RANGE
          SX7    B1          SET A-ERROR
          SA7    EXERR
          SA7    AERR 
          SA7    EFLG 
          MX7    0
          EQ     STC         RETURN 
  
*         CODE-MODIFICATION WORDS FOR *STC0*. 
  
 STCW     SX2    0           SET FOR NO ASCII CONVERSION
          LX7    6           SHIFT ASSEMBLY FOR 6-BIT CHARS 
          SB7    B7-B1       DECREMENT CHARACTER COUNT
  
 STCX     SX2    0           SET FOR NO ASCII CONVERSION
          LX7    8           SHIFT ASSEMBLY FOR 8-BIT CHARS 
          SB7    B7-B1       DECREMENT CHARACTER COUNT
  
 STCZ     SX2    ASC6T8      SET FOR ASCII CONVERSION 
          LX7    8           SHIFT ASSEMBLY FOR 8-BIT CHARS 
          SB7    B7-B1       DECREMENT CHARACTER COUNT
 CHAR     SPACE  4
**        CHAR - CHARACTER SET CODES. 
*         CHAR   A,B,C,D
*         ENTRY  (A) = DISPLAY CODE.
*                (B) = EXTERNAL BCD.
*                (C) = INTERNAL BCD.
*                (D) = USASCII. 
  
  
          PURGMAC CHAR
  
 CHAR     MACRO  A,B,C,D
          CON    ;D0;A0;D0;C0;B0;A
          ENDM
  
 CHAR*    MACRO  A,B,C,D     CHARACTERS OF SPECIAL INTEREST TO *SQUEEZE*
          CON    1S59+;D0;A0;D0;C0;B0;A 
          ENDM
 CHAR     SPACE  4
          BASE   O
 STCA     BSS    0
          LOC    0
  
          IFEQ   IP.CSET,IP.C63,2 
          CHAR*  00,20,60,00   UNDEFINED FOR 63 CSET --> SPACE
          SKIP   1
          CHAR*  00,00,12,32   COLON
          CHAR   01,61,21,41 A
          CHAR   02,62,22,42 B
          CHAR   03,63,23,43 C
          CHAR   04,64,24,44 D
          CHAR   05,65,25,45 E
          CHAR   06,66,26,46 F
          CHAR   07,67,27,47 G
          CHAR   10,70,30,50 H
          CHAR   11,71,31,51 I
          CHAR   12,41,41,52 J
          CHAR   13,42,42,53 K
          CHAR   14,43,43,54 L
          CHAR   15,44,44,55 M
          CHAR   16,45,45,56 N
          CHAR   17,46,46,57 O
          CHAR   20,47,47,60 P
          CHAR   21,50,50,61 Q
          CHAR   22,51,51,62 R
          CHAR   23,22,62,63 S
          CHAR   24,23,63,64 T
          CHAR   25,24,64,65 U
          CHAR   26,25,65,66 V
          CHAR   27,26,66,67 W
          CHAR   30,27,67,70 X
          CHAR   31,30,70,71 Y
          CHAR   32,31,71,72 Z
          CHAR   33,12,00,20 0
          CHAR   34,01,01,21 1
          CHAR   35,02,02,22 2
          CHAR   36,03,03,23 3
          CHAR   37,04,04,24 4
          CHAR   40,05,05,25 5
          CHAR   41,06,06,26 6
          CHAR   42,07,07,27 7
          CHAR   43,10,10,30 8
          CHAR   44,11,11,31 9
          CHAR   45,60,20,13 +
          CHAR   46,40,40,15 -
          CHAR   47,54,54,12 *
          CHAR   50,21,61,17 /
          CHAR   51,34,74,10 (
          CHAR   52,74,34,11 )
          CHAR   53,53,53,04 $
          CHAR   54,13,13,35 =
          CHAR*  55,20,60,00   BLANK
          CHAR   56,33,73,14 ,
          CHAR   57,73,33,16 .
          CHAR   60,36,76,03 # NUMBER 
          CHAR   61,17,17,73 [ LEFT BRACKET                             P069  28
          CHAR   62,32,72,75 ] RIGHT BRACKET                            P069  29
          IFEQ   IP.CSET,IP.C63,2 
          CHAR*  63,00,12,32 : COLON
          SKIP   1
          CHAR   63,16,16,05 : PERCENT
          CHAR   64,14,14,02 " QUOTE
          CHAR   65,35,75,77 _ UNDERLINE
          CHAR   66,52,52,01 ! EXCLAMATION                              P069  31
          CHAR   67,37,77,06 & AMPERSAND
          CHAR   70,55,55,07 ' APOSTROPHE                               P069  33
          CHAR   71,56,56,37 ? QUESTION 
          CHAR   72,72,32,34 < LESS THAN                                P069  35
          CHAR   73,57,57,36 > GREATER THAN                             P069  36
          CHAR   74,15,15,40 @ AMOUNT                                   P069  37
          CHAR   75,75,35,74 \ REVERSE /
          CHAR   76,76,36,76 ^ HAT
          CHAR*  77,77,37,33 ; SEMICOLON OR FORMAL PARAMETER MARK 
  
          LOC    *O 
          BASE   *
          SPACE  4
          QUAL
 SCD      EQU    /DATA/SCD
 STCA     EQU    /DATA/STCA 
 CONADD   TITLE  LISTING SUBROUTINES. 
**        CONADD - CONVERT CROSS REFERENCE ADDRESS. 
*         ENTRY (X1) = (18/X,17/ADDR,25/Y)
*         EXIT  (X1) = (18/3R   ,36/ADDRESS,6/SEPERATOR)
  
  
          USE    LIST 
          SEG    LISTING SUBROUTINES. 
          QUAL   PASS2
 CONADD   PS     0           RETURN EXIT
          AX1    25 
          MX0    60-17
          BX1    -X0*X1 
          RJ     CONOCT      CONVERT ADDRESS
          BX1    X6 
          SA5    P2TEMP 
          LX6    6
          ZR     X5,CONADD   IF END OF STRING 
          SX5    B1 
          IX1    X6+X5       ADD SEPERATOR
          EQ     CONADD      RETURN 
 CONREF   SPACE  4
**        CONREF - CONVERT PAGE AND LINE NUMBER.
*         ENTRY  (X1) = (18/TABADD,17/LOCCTR,12/PAGE,7/LINE,6/LET)
*         EXIT   (X1) = DPC FORM (30/PAGE,6/1H/,12/LINE,6/1L,6/LET) 
  
  
 CONREF   PS     0           RETURN EXIT
          BX5    X1 
          LX1    -13
          MX0    60-12
          BX6    X0*X1
          AX6    -7 
          BX1    -X0*X1      CONVERT PAGE 
          MX0    -7 
          BX6    -X0*X6 
          SA2    CP.PS       PAGE SIZE                                   F4810A 
          IX2    X6-X2       CHECK IF AT START OF PAGE                   F4810A 
          SB7    X2+B1                                                   F4810A 
          NG     B7,CONREF1  IF NOT START OF PAGE 
          SX1    X1+B1
          SX6    B1+B1
 CONREF1  SA6    CONREFA
          RJ     CONDEC 
          SA1    A6          CONVERT LINE 
          LX6    30 
          MX0    42 
          LX0    12 
          BX6    X0*X6
          SA6    A6 
          SX1    X1-1 
          RJ     CONDEC 
          NE     B2,B6,CONREF2   JUMP IF NOT 1-DIGIT LINE NUMBER
          SX6    X6-2200B        ADD LEADING ZERO 
 CONREF2  SA1    CONREFA
          SX6    X6-050000B 
          MX0    42 
          BX6    -X0*X6 
          LX6    12 
          IX6    X6+X1
          MX0    54 
          BX6    X0*X6
          BX1    -X0*X5 
          IX1    X6+X1
          EQ     CONREF      RETURN 
  
 CONREFA  DATA   0
 CPL      SPACE  4
**        CPL - CREATE PRINT LINE.
  
  
 CPL      PS                 RETURN EXIT
          SA2    PLFLG
          NZ     X2,CPL      IF PRINT LINE READY
          SX6    B1 
          SA6    A2 
          SA3    CCT         SET LISTING CARD COUNT 
          SA1    LINE-1      CREATE PRINT LINE
          BX7    X3 
          LX6    X1 
          SA7    LCCT 
          SB2    6
          SA5    =20600000000000000056B 
          SA4    =20660000000000000000B 
          SA2    SEQ-1
          SA6    A1 
          SB5    X3 
          UX6    B7,X4
          SB6    B2 
          SA1    CARD 
 CPL1     LX3    X1,B7       ASSEMBLE CHARACTERS
          SB7    B7-B2
          SA1    A1+B1
          BX6    X6+X3
          PL     B7,CPL1     LOOP FOR 10 CHARACTERS 
          SA6    A6+B1
          SB6    B6-B1
          UX6    B7,X4
          PL     B6,CPL1     LOOP FOR 70 CHARACTERS 
          LX3    X1,B2
          SA1    A1+B1
          BX6    X3+X1
          SA2    A2+B1
          LX6    48 
          SA1    A1+B1
          IX7    X6+X2
          SA2    A2+B1
          BX6    X2 
          SB5    B5-B1
          SA7    A6+B1
          SA6    A7+B1
          SB6    B2 
          UX6    B7,X5
          LX6    54 
          NZ     B5,CPL1     LOOP FOR CONTINUATION CARDS
          SX6    A6+B1
          SA6    LLINE
          SA5    SEQ
          SA1    CCT
          NZ     X5,CPL      IF NOT MODIFY-STYLE SEQUENCE FIELD 
          SA5    A5+B1
          SB3    LINE+7 
          SB4    X1 
 CPL2     SA2    =40404040404040404040B 
          MX0    42          BLANK FILL NAME
          BX1    -X0*X5 
          BX5    X0*X5
          MX0    48 
          IX7    X0+X5
          BX7    -X5*X7 
          BX7    X2*X7
          LX6    X7 
          SA2    =8L
          LX7    60-5 
          SA3    B3 
          IX7    X6-X7
          BX7    X6+X7
          BX6    X7*X2
          BX6    X6+X5
          LX6    -12
          BX6    X3+X6
          SA6    A3          STORE NAME IN COLUMNS 73-79, BLANK IN 80 
          RJ     CONDEC      CONVERT NUMBER 
          LX6    24 
          SA5    A5+2 
          SA6    B3+B1       STORE NUMBER IN COLUMNS 81-86, 
          SB4    B4-B1       BLANKS IN COLUMNS 87-90
          SB3    B3+9 
          NZ     B4,CPL2     LOOP IF CONTINUATION CARDS 
          EQ     CPL
 CUL      SPACE  4
**        CUL - CLEAN UP LISTING AREA.
  
  
 CUL      PS                 RETURN EXIT
          SA1    DLFLG
          NZ     X1,CUL1     IF DEFERRED LIST IN EFFECT 
          SX6    B1 
          SA6    LCCT 
          SA6    DETFLG 
          SA6    PLFLG
          SA1    =1H         CLEAR LINE 
          SX2    LINE 
          SA3    LLINE
          RJ     PRESET 
 CUL1     SX6    1R          CLEAR OCTAL AREA TO BLANKS 
          SA6    OCTAL
          BX7    X6 
          SA7    A6+B1
          SB7    40/2-1 
 CUL2     SB7    B7-B1
          SA6    A7+B1
          SA7    A6+B1
          NZ     B7,CUL2     LOOP 
          EQ     CUL         RETURN 
 LBL      SPACE  4
**        LBL - LIST BLANK LINE.
*         ENTRY  (X0) = NUMBER OF LINES TO LIST.
  
  
 LBL      PS                 RETURN EXIT
          SA2    CP.LISTF 
          SA1    LPCNT
          ZR     X2,LBL      IF NO LONG OUTPUT
          SX0    X0 
          IX6    X1+X0
          NG     X0,LBL      IF < 0 LINES 
          SA2    CP.PS       PAGE SIZE                                   F4810A 
          IX2    X6-X2       CHECK IF EJECT                              F4810A 
          SA6    A1 
          PL     X2,LBL      IF EJECT                                    F4810A 
  
 RM       IFEQ   CP#RM,0
  
 LBL1     ZR     X0,LBL      IF END OF BLANK LINES
          WRITEW O,(=2L  ),1
          SX0    X0-1 
  
 RM       ELSE
  
          SX6    X0 
 LBL1     ZR     X6,LBL      IF END OF BLANK LINES
          SA6    T6RM1
          PUT    O,BLANKS,10
          SA2    T6RM1
          SX6    X2-1 
  
 RM       ENDIF 
  
          EQ     LBL1        LOOP 
 LDL      SPACE  4
**        LDL - LIST DEFERRED LINE. 
  
  
 LDL      PS                 RETURN EXIT
          SA1    DLFLG
          ZR     X1,LDL      IF NO DEFERRED LIST
          SA2    EFLG 
          ZR     X2,LDL1     IF NO ERROR FLAG 
          SX7    B1 
          SA7    FLIST
          RJ     LISTER 
 LDL1     SX6    B0 
          SA6    DLFLG
          SX7    B1 
          SA7    FLIST
          RJ     LISTER 
          MX6    0           CLEAR DETAIL FLAG
          SA6    DETFLG 
          EQ     LDL         RETURN 
 LEL      SPACE  4
**        LEL - LIST ERROR LINE.
  
  
 LEL2     RJ     LTX         LIST TEXT
  
 LEL      PS                 RETURN EXIT
          SA1    CP.LISTF 
          ZR     X1,LEL1     IF NO FULL LIST
          SA3    O
          SA1    LPCNT
          SX7    PGCNT
          RJ     LHD
 LEL1     SA3    E
          SX0    B0 
          ZR     X3,LEL2     IF NO ERROR FILE 
          SA1    ELCNT       LIST HEADER
          SX7    EPCNT
          RJ     LHD
          SX0    E
          EQ     LEL2 
 LHD      SPACE  4
**        LHD - LIST HEADER LINE. 
*         ENTRY  (A1) = LINE COUNT ADDRESS. 
*                (X1) = LINE COUNT. 
*                (A3) = FET ADDRESS.
*                (X7) = PAGE NUMBER ADDRESS.
  
  
 LHD      PS                 RETURN EXIT
          MX2    6
          SA5    TITBUF      FIRST WORD OF HEADER 
          BX6    -X2*X5 
          SX2    A3-E 
          SA4    LONGEJ      LONG EJECT CARRIAGE CONTROL CHARACTER
          NZ     X2,LHD0     IF LONG LIST HEADER BEING PRINTED
          SA2    CP.EPAG
          LX2    B1 
          PL     X2,LHD0     TEST *WRITTEN TO* FLAG (BIT 58)
          SA4    SHORTEJ     SHORT EJECT CARRIAGE CONTROL CHARACTER 
 LHD0     BX6    X4+X6       OR IN CARRIAGE CONTROL CHARACTER 
          SA6    A5 
          SA2    LCCT        INCREMENT LINE NUMBER
          IX6    X2+X1
          SA6    A1 
          SA4    CP.PS       PAGE SIZE                                   F4810A 
          IX4    X6-X4                                                   F4810A 
          NG     X4,LHD      IF NOT AT END OF PAGE                       F4810A 
          SX6    X2+2        RESET LINE NUMBER
          SA6    A1 
          SX6    A3          SAVE FET ADDRESS 
          SA6    LHDA 
          SA7    A6+B1       SAVE PAGE NUMBER ADDRESS 
          SX6    X6-E 
          ZR     X6,LHD1     IF ERROR FILE
          RJ     PET         PROCESS ERROR TABLE
 LHD1     SA2    LHDA+1      INCREMENT PAGE NUMBER
          SA1    X2 
          SX6    X1+B1
          SA6    X2 
          SX1    X1+B1       CONVERT PAGE NUMBER
          RJ     CONDEC 
          LX6    24 
          SA6    PAGENO 
          SA2    LHDA 
  
 RM       IFNE   CP#RM,7
                                                                         F4810A 
          SX6    X2-E        DECIDE WHICH FILE WE ARE WRITING TO. 
          SA5    CP.EPAG
          ZR     X6,LHD1X 
          SA5    CP.PAGE
 LHD1X    LX6    X5,B1       TEST *WRITTEN TO* FLAG (BIT 58). 
          MI     X6,LDH1A    IF WRITTEN TO, DO NOT PRINT PD CONTROL.
          MX0    1
          LX0    -1 
          BX6    X0+X5
          SA6    A5          SET *WRITTEN TO* FLAG (BIT 58) 
          RJ     STF         SET TERMINAL FILE
          ZR     X6,LDH1A    IF TERMINAL FILE 
          SA1    FRSTLIN                                                 F4810A 
          ZR     X1,LDH1A    IF NO NEED TO RESET PRINTER DENSITY         F4810A 
          WRITEH X2,FRSTLIN,1 ELSE RESET PRINTER DENSITY                 F4810A 
 LDH1A    BSS    0                                                       F4810A 
          WRITEH X2,TITBUF,PAGENO+1-TITBUF
                                                                         F4810A 
 RM       ELSE                                                           F4810A 
                                                                         F4810A 
          SX6    X2-E        DECIDE WHICH FILE WE ARE WRITING TO. 
          SA5    CP.EPAG
          ZR     X6,LHD1X 
          SA5    CP.PAGE
 LHD1X    LX6    X5,B1       TEST *WRITTEN TO* FLAG (BIT 58). 
          MI     X6,LDH1A    IF WRITTEN TO, DO NOT PRINT PD CONTROL.
          MX0    1
          LX0    -1 
          BX6    X0+X5
          SA6    A5          SET *WRITTEN TO* FLAG (BIT 58) 
          SA1    FRSTLIN     CHECK IF NEED TO RESET PRINTER DENSITY      F4810A 
          ZR     X1,LDH1A    IF NOT                                      F4810A 
          PUT    X2,FRSTLIN,10 RESET PRINTER DENSITY                     F4810A 
 LDH1A    BSS    0                                                       F4810A 
 L.       SET    PAGENO+1-TITBUF
          PUT    X2,TITBUF,L.*10
                                                                         F4810A 
 RM       ENDIF                                                          F4810A 
                                                                         F4810A 
          RJ     LHDS        DO SUBTITLE LINE 
          EQ     LHD         RETURN 
  
  
 LHDS     SPACE  4
**        LHDS - LIST HEADER SUBTITLE 
* 
 LHDS     PS                 RETURN EXIT
          SA1    SUBNAME
          MX0    6
          BX2    X0*X1
          LX6    X1 
          NZ     X2,LHD2
          RJ     LJUST
 LHD2     SA6    SBNAME 
          SA2    LHDA 
  
 RM       IFEQ   CP#RM,0
          WRITEH X2,SUBTIT,SUBL 
          WRITEW X2,(=2L  ),1 LIST BLANK LINE UNDER TITLES
 RM       ELSE
          PUT    X2,SUBTIT,SUBL*10
          SA2    LHDA 
          PUT    X2,BLANKS,10 
 RM       ENDIF 
  
          EQ     LHDS        RETURN 
  
 LHDA     DATA   0           FET ADDRESS
          DATA   0           PAGE NUMBER ADDRESS
 LISTER   SPACE  4
**        LISTER - LIST LINE. 
*         LISTER WILL LIST: 
*                1. ERROR LINES.
*                2. IF FLIST " 0. 
*                3. IF NONE OF THE FOLLOWING CARD TYPES = 1 AND LIST
*                CONTROL = 0. 
*                   CARD TYPE   LIST CONTROL
*                     1         L - MASTER LIST.
*                     1             CONTROL CARD. 
*                     SYSFLG    S - SYSTEM MACROS.
*                     LIBFLG    X - XTEXT.
*                     MACFLG    M - MACRO GENERATED LINES.
*                     ECHFLG    E - DUP GENERATED LINES.
*                     DETFLG    D - DETAIL (GENERATED). 
*                     RMTFLG    D - REMOTE. 
*                     CTYPE     C - LIST CONTROL. 
*                     NOAS      F - IF SKIPPED LINES. 
*         ENTRY  (LCCT) = NUMBER OF LINES TO LIST.
*         EXIT   (LCCT) = 1.
*                (DETFLG) = 1.
*                (NLFLG) = 0. 
  
  
 LISTER   PS                 RETURN EXIT
          SA3    EFLG 
          ZR     X3,LSL7     IF NO ERRORS 
          SA2    DLFLG
          ZR     X2,LSL1     IF NOT DELAYED LIST WITH ERROR 
          RJ     LEL
          SX2    LINE        CLEAR DELAYED LIST LINE
          SX6    1R 
          SA6    X2-1 
          SA6    A6-B1
          SA6    A6-B1
          SA6    A6-B1
          SA1    =1H
          SA3    LLINE
          RJ     PRESET 
          EQ     LISTER      RETURN 
  
*         RECHECK FOR ERRORS. 
  
 LSL1     SX6    1R          CHECK FOR ERRORS 
          SA6    OCTAL
          SA1    ERFLAGS
          SA2    ERRLETS
          BX7    X6 
          SB7    LEFLG-1
 LSL2     ZR     X1,LSL3     IF NO ERROR
          BX6    X2 
          SA6    A6+B1
 LSL3     SB7    B7-B1
          SA1    A1+B1
          SA2    A2+B1
          PL     B7,LSL2     LOOP 
          SX6    A6-OCTAL    ERROR COUNT
          SA6    EFLG 
          ZR     X6,LSL7     IF NO ERRORS 
  
*         LIST ERROR LINE ON BOTH OUTPUT FILES AND RECORD PAGE NUMBERS
*         OF THE LINES IN ERROR.
  
          RJ     CPL         CREATE PRINT LINE
          RJ     LEL         LIST ERROR LINE
          SA1    ERFLAGS
          SB7    NFERS-1
          SA2    LSLB 
          SB6    LEFLG-NFERS-1
          SA3    ERCNT
          SA4    WECNT
 LSL4     BX6    X1+X2       RECORD PAGE OCCURRENCE OF ERRORS 
          IX3    X3+X1
          SA1    A1+B1
          SB7    B7-B1
          SA6    A2 
          SA2    A2+B1
          PL     B7,LSL4     LOOP 
 LSL5     BX6    X1+X2
          IX4    X4+X1
          SA1    A1+B1
          SB6    B6-B1
          SA6    A2 
          SA2    A2+B1
          PL     B6,LSL5     LOOP 
          BX6    X3 
          LX7    X4 
          SA6    A3 
          SB7    LERFLAGS-2  CLEAR ERROR FLAGS
          SA7    A4 
          SX6    B0 
          SA6    EXERR
          SA6    ERFLAGS
 LSL6     SB7    B7-B1
          SA6    A6+B1
          PL     B7,LSL6     LOOP 
          EQ     LSL10
  
*         NO ERRORS. CHECK FORCE LIST AND LIST OPTIONS. 
  
 LSL7     SA4    FLIST
          NZ     X4,LSL9     IF FORCE LIST
          SB7    30 
          SA1    LSLA        PROCESS LIST OPTION TABLE
 LSL8     AX2    X1,B7
          SA3    X1 
          SA4    X2 
          BX6    -X3*X4 
          SA1    A1+B1
          ZR     X6,LSL8     IF LINE WILL LIST
          SX6    A1-LSLA-LSLAL
          NZ     X6,LSL10    IF NO LIST 
 LSL9     SA1    LPCNT
          SX7    PGCNT       CHECK FOR END OF PAGE
          SA3    O
          RJ     LHD         LIST HEADER
          SX0    0
          RJ     LTX         LIST TEXT
  
*         CLEAN UP LINE FOR NEXT LISTING ENTRY. 
  
 LSL10    RJ     CUL         CLEAN UP LIST
          MX6    0
          SA6    FLIST
          EQ     LISTER 
  
 LSLA     VFD    30/NLFLG,30/=0    CONDITIONS DETECTED BY RINTER
          VFD    30/DETFLG,30/LD+1 DETAIL 
          VFD    30/CTYPE,30/LC+1  LIST CONTROL 
          VFD    30/=1,30/LL+1     MASTER LIST
          VFD    30/=1,30/=0       END OF TABLE 
 LSLAL    EQU    *-LSLA 
  
 LSLB     BSSZ   LEFLG       PAGE OCCURANCES OF ERRORS
 LISTERF  SPACE  4
**        LISTERF - FORCE LISTING.
  
  
 LISTERF  PS                 RETURN EXIT
          RJ     LEL         LIST ERROR LINE
          RJ     CUL         CLEAN UP LINE
          EQ     LISTERF     RETURN 
 LISTERG  SPACE  4
**        LISTERG - LIST GENERATIVE LINES.
  
  
 LISTERG  PS                 RETURN EXIT
          SA2    DLFLG
          ZR     X2,LSG1     IF NO DERERRED LIST
          RJ     LDL         LIST DEFERRED LINE 
          EQ     LISTERG
 LSG1     SA3    LL+1        SET FLIST IF BOTH G AND L LIST 
          SA4    LG+1 
          BX6    X3*X4       L*G
          SA6    FLIST
          ZR     X6,LSG2     IF NO FORCE LIST 
          RJ     CPL         CREATE PRINT LINE
 LSG2     RJ     LISTER 
          EQ     LISTERG     RETURN 
 LISTL    SPACE  4
**        LISTL - LIST LINE IF EXTERNAL LIST OPTION SELECTED. 
  
  
 LISTL1   SA6    FLIST       FORCE LISTING
          RJ     LISTER 
  
 LISTL    PS                 RETURN EXIT
          RJ     LDL         LIST DEFERRED LINE 
          RJ     CPL         CREATE PRINT LINE
          SA1    CP.LISTF 
          SX6    X1 
          EQ     LISTL1 
 LIST2L   SPACE  4
**        LIST2L - LIST 2 LINES IF EXTERNAL LIST SELECTED.
  
  
 LIST2L   PS                 RETURN EXIT
          RJ     LISTL
          SA1    CP.LISTF 
          ZR     X1,LIST2L   IF EXTERNAL LIST IS OFF
          SX0    B1 
          RJ     LBL
          EQ     LIST2L      RETURN 
 LTX      SPACE  4
**        LTX - LIST TEXT.
*         ENTRY  (X0) = 0 IF NO ERROR LIST. 
*                (X0) = ADDRESS OF ERROR FILE FET IF ERROR LIST.
*                (LCCT) = NUMBER OF LINES TO LIST.
  
  
 LTX      PS                 RETURN EXIT
          SA2    DLFLG
          ZR     X2,LTX1     IF NOT DEFERRED LIST 
          SA1    =1H         CLEAR OCTAL AREA 
          BX6    X1 
          SA6    LINE-1 
          SA6    A6-B1
          SA6    A6-B1
          SA6    A6-B1
          EQ     LTX3 
 LTX1     SA1    LINE        COMPRESS OCTAL LINE INTO 4 WORDS 
          BX6    X1 
          SA6    A1 
          SA3    =20120000000000000000B 
          SB6    4
          UX6    B7,X3
 LTX2     SA1    A1-B1
          SB7    B7-B1
          BX6    X6+X1
          LX6    54 
          NZ     B7,LTX2     LOOP FOR 10 CHARACTERS 
          SA6    A6-B1
          SB6    B6-B1
          UX6    B7,X3
          NZ     B6,LTX2     LOOP FOR 40 CHARACTERS 
  
 RM       IFEQ   CP#RM,0
  
 LTX3     SA0    A6 
          SA5    CP.LISTF 
 LTX4     ZR     X5,LTX5     IF NO FULL LIST
          WRITEH O,A0,13
 LTX5     ZR     X0,LTX6     IF NO ERROR LIST 
          WRITEH X0,A0,13 
 LTX6     SA1    LCCT        COUNT LINES
          SX7    X1-1 
          ZR     X7,LTX      IF END OF LINE 
          SA7    A1          LIST CONTINUATION LINES
          SA0    A0+9 
          SA3    =1H
          LX6    X3 
          BX7    X3 
          SA6    A0 
          SA7    A6+B1
          SA6    A7+B1
          SA7    A6+B1
          EQ     LTX4 
  
 RM       ELSE
  
 LTX3     SX6    A6 
          BX7    X0 
          SA6    T6RM1       SAVE LIST ADDRESS
          SA7    A6+B1
          SA5    CP.LISTF 
 LTX4     ZR     X5,LTX5     IF NO FULL LIST
          PUT    O,X6,130 
 LTX5     SA2    T6RM2
          SA3    A2-B1
          ZR     X2,LTX6     IF NO ERROR LIST 
          PUT    E,X3,130 
 LTX6     SA1    LCCT        COUNT LINES
          SX7    X1-1 
          ZR     X7,LTX      IF END OF LINE 
          SA7    A1          LIST CONTINUATION LINES
          SA2    T6RM1
          SA3    =1H
          SA5    CP.LISTF 
          LX6    X3 
          BX7    X3 
          SA6    X2+9 
          SA7    A6+B1
          SA6    A7+B1
          SA7    A6+B1
          SX6    X2+9 
          SA6    A2 
          EQ     LTX4 
  
 RM       ENDIF 
 PACKO    SPACE  4
**        PACKO - PACK OCTAL/HEX DIGITS INTO LINE.
*         ENTRY  (X1) = VALUE.
*                (X2) = LOW ORDER COLUMN NUMBER.
*                (X3) = COLUMN COUNT. 
*                (X3) = 0 IF LEADING ZERO SUPPRESSION.
*         SAVES  A - 0, 1.
  
  
 PACKO    PS                 RETURN EXIT
          MX0    60-4        HEX DIGITS 
          SB3    4           SIZE OF SHIFT
          SX4    1R0         CONVERSION FACTOR
          SB7    X3-1        COLUMN COUNTER 
          SX7    1R          BLANK
          SB6    -B1
          SB5    OCTAL-1
          PL     X1,PACKO1   IF POSITIVE NUMBER 
          NZ     X3,PACKO1   IF NO LEADING ZERO SUPPRESSION 
          BX1    -X1         REVERSE NEGATIVE NUMBER
          SX7    1R-         SAVE A MINUS SIGN
 PACKO1   SA5    PPTYPE 
          SX5    X5+B1
          ZR     X5,PACKO2   HEX (BCU PPTYPE = -1)
          SX5    X5+B1
          ZR     X5,PACKO2   HEX (MCU PPTYPE = -2)
          MX0    60-3        OCTAL DIGITS 
          SB3    3           SIZE OF SHIFT
 PACKO2   BX5    -X0*X1      MASK OFF LOWER NUMBER
          IX6    X4+X5       ADD CONVERSION FACTOR
          SB4    X5-10       HEX NUMBERS GET LARGER THAN 10.
          NG     B4,PACKO3   IF NOT NUMERIC 
          SX6    B4+B1       10=A,11=B,ETC. 
 PACKO3   AX1    B3          SHIFT
          SA6    X2+B5       STORE DISPLAY VALUE
          SB7    B7-B1       DECREMENT COLUMN NUMBER
          SX2    X2+B6       DECREMENT COLUMN COUNTER 
          PL     B7,PACKO2   LOOP.
          NZ     X3,PACKO    NO LEADING ZERO SUPPRESSION. 
          NZ     X1,PACKO2   NOT END OF NUMBER. 
          SA7    A6-B1       STORE MINUS SIGN IF NECESSARY. 
          EQ     PACKO       RETURN.
 PET      SPACE  4
**        PET - PROCESS ERROR TABLE.
*         RECORDS ERRORS IN ERRTAB.  CLEARS LSLB. 
  
 PET      PS                 RETURN EXIT
          MX6    0
          SA6    PETA 
 PET1     SA2    PETA 
          SA1    LSLB+X2
          ZR     X1,PET2     IF NO ERROR
          SX6    B0 
          SA6    A1 
          LX2    30 
          SA3    PGCNT
          BX1    X3+X2
          ADDWORD ERRTAB
          SA2    PETA 
 PET2     SX6    X2+B1
          SB7    X6-LEFLG 
          SA6    A2 
          NZ     B7,PET1     LOOP 
          EQ     PET         RETURN 
  
 PETA     DATA   0           ERROR INDEX
 PRT      TITLE  CROSS REFERENCE TABLE PROCESSING.
*         PRT - PROCESS CROSS-REFERENCE TABLE.                           CPSA097
  
  
 PRTX     SX6    B0          CLEAR REFTAB 
          SA6    L.REFTAB 
          SA1    PRTA        CHECK OVERFLOW 
          ZR     X1,PRT      IF NO OVERFLOW 
  
 RM       IFEQ   CP#RM,0
  
          SA1    B+4
          SX1    X1 
          RJ     ACL         ADJUST CORE LIMITS 
          IFEQ   OVERLAY,0,1
          READ   C,R
          REWIND R
  
 RM       ELSE
  
          SX1    BUFFERS
          RJ     ACL         ADJUST CORE LIMITS 
  
          IFEQ   OVERLAY,0,1
          GET    R,CBUF 
          REWINDM R 
  
 RM       ENDIF 
  
 OVL      IFNE   OVERLAY,0
          SA1    OVLA        RELOAD SECONDARY OVERLAY 
          SA2    A1+B1
          RJ     OVL
 OVL      ENDIF 
  
  
 PRT      PS                 RETURN EXIT
          SA3    LXRF        CHECK IF REFERENCE TABLE REQUIRED
          ZR     X3,PRT 
          SX6    3           SET PASS TO 3
          SA6    PASS 
          MX6    0           CLEAR QUAL VALUE 
          SA6    QVAL 
          SA6    SUBNAME     AND SUB-SUBTITLE 
          SA6    PRTA 
          SX7    O           SET FOR *LHDS* TO ALWAYS USE LISTING FILE
          SA7    LHDA         AND NOT ERROR FILE
          SA1    REFIO
          NZ     X1,PRT1     IF REFTAB OVERFLOWED 
          SA6    LOSTREF
          EQ     PRT7 
  
 RM       IFEQ   CP#RM,0
  
 PRT1     WRITER R
          SA1    E           GET STATUS OF ERROR FILE 
          SA2    E+2         *IN* POINTER 
          SA3    A2+B1       *OUT* POINTER
          LX1    59-3 
          IX4    X2-X3
          MI     X1,PRT1.1   IF ANYTHING WAS WRITTEN
          ZR     X4,PRT1.2   IF BUFFER EMPTY
 PRT1.1   WRITER E
 PRT1.2   BSS    0
  
          RECALL S
          RECALL B
          RECALL E
          RECALL R
          SX6    CBUF 
          SA6    PRTA 
  
 OVL      IFEQ   OVERLAY,0
          SA1    R+1
          SX7    X1 
          SA6    C+3
          SA7    A6-B1
 OVL      ENDIF 
  
          REWIND T
  
 RM       ELSE
  
 PRT1     WEOR   R
          SX6    BUFFERS     LWA OF COMPASS 
          SA6    PRTA 
  
 OVL      IFEQ   OVERLAY,0
          SX3    X6-CBUF
          IX4    X3+X3
          LX3    3
          IX5    X3+X4       LENGTH TO BE DUMPED
          PUT    R,CBUF,X5                                              S028 368
 OVL      ENDIF 
  
          REWINDM R 
  
 RM       ENDIF 
  
          SX1    PRTB        ADJUST CORE LIMITS 
          RJ     ACL
          RJ     MTD         MOVE TABLES DOWN 
 PRT1A    BSS    0
          SA1    O.REFTAB 
          SA2    O.ENDTAB 
          SA3    LOSTREF
          IX4    X2-X1
          SX7    X4-100B
          IX6    X3-X7
          NG     X6,PRT1B    IF ENOUGH ROOM 
          SA4    LSTTHOU
          NZ     X4,PRT2     IF ALREADY AT MAX. FL. WE HAVE LOST REFS.
          BX1    X6 
          RJ     RFL         GET MORE FL. 
          EQ     PRT1A       TRY AGAIN
  
 PRT1B    BSS    0
          BX7    X3 
          MX6    0
 PRT2     SA7    L.REFTAB 
          SA6    A3          RESET LOSTREF
          BX6    X2 
          SA6    O.MEMORY 
  
 RM       IFEQ   CP#RM,0
  
          SB6    X1          READ REFERENCE TABLE 
          SB7    X7 
          READ   T
          READW  T,B6,B7
          NZ     X1,PRT5     IF ROOM FOR REFERENCE TABLE
 PRT4     READW  X2,PRTA,1   COUNT LOST REFERENCES
          ZR     X1,PRT4     LOOP 
 PRT5     SX1    TBUF 
          RJ     ACL         ADJUST CORE LIMITS 
  
 RM       ELSE
  
          IX5    X7+X7
          LX7    3
          IX4    X5+X7
          GETP   R,X1,X4     READ REFERENCE TABLE                       S028 370
          FETCH  R,FP,X3
          NZ     X3,PRT7     IF ROOM FOR REFERENCE TABLE
 PRT4     GETP   R,T6RM1,10 
          FETCH  R,FP,X3
          SX0    #EOI#+#EOP#+#EOS#+#EOR#
          BX4    X0*X3
          ZR     X4,PRT4     IF MORE REFERENCES 
  
 RM       ENDIF 
  
 PRT7     SA1    O.SYMTAB    PREPARE SYMBOL TABLE BY CLEARING OUT 
          SA2    L.SYMTAB    BITS 42-59 
          MX0    18 
          SB2    B1+B1
          SB7    X2-2 
          SB3    X1 
          SX1    X1+B1
          RX5    X1 
          BX6    -X0*X5 
          SB6    42 
 PRT8     WX6    X1 
          SX1    X1+B2
          SB7    B7-B2
          RX5    X1 
          BX6    -X0*X5 
          PL     B7,PRT8
          SA5    L.REFTAB    CONSTRUCT REFERENCE LINK 
          ZR     X5,PRT10    IF REFERENCE TABLE EMPTY 
          SA2    O.REFTAB 
          SB7    X5-1 
          SA2    X2+B7
          AX3    X2,B6
          BX5    -X0*X2 
 PRT9     SX3    X3+B3       FETCH SYMBOL TABLE ENTRY 
          RX1    X3 
          SA2    A2-B1       REFERENCE ENTRY FOR NEXT ITERATION 
          BX4    X0*X1       ISOLATE LINK FROM SYMBOL TABLE 
          IX6    X4+X5       ADD SYMBOL T. LINK TO REF ENTRY
          SX5    B7+B1       REFTAB ORDINAL 
          LX7    X5,B6
          SB7    B7-B1
          BX1    -X0*X1 
          IX7    X7+X1       ADD REFTAB ORDINAL TO SYMTAB ENTRY 
          SA6    A2+B1
          WX7    X3 
          AX3    X2,B6       ISOLATE SYMBOL INDEX FOR NEXT PASS 
          BX5    -X0*X2 
          PL     B7,PRT9
 PRT10    SA2    L.SYMTAB    CLEAR UNREFERENCED SST ENTRIES 
          SA1    O.SYMTAB 
          SB2    B1+B1
          SB7    X2 
          SX4    X1+1 
          SA2    LT+1 
          SA5    LN+1 
          SB6    59-35
          SX7    0
          BX2    -X2
          SX6    X2+B1
          BX2    X6 
          LX2    34-32
          BX2    X2+X6       X2 = 5 * (1 - (LT))
          LX2    32 
 PRT11    RX1    X4          FETCH SYMTAB ENTRY 
          SX4    X4+B2
          ZR     B7,PRT13    IF END OF SYMBOL TABLE 
          SB7    B7-B2
          LX6    X1,B6
          BX3    X0*X1
          NG     X6,PRT12    IF NOREF ENTRY 
          BX6    X2*X1
          NZ     X3,PRT11    IF REFERENCED ENTRY
          NZ     X6,PRT12    IF SST OR XTEXT, BUT NO LIST T 
          NZ     X5,PRT11    IF LIST N
 PRT12    SX6    X4-3 
          WX7    X6          CLEAR SYMTAB ENTRY 
          SX6    X6+B1
          WX7    X6 
          EQ     PRT11       LOOP 
  
 PRT13    SA2    L.SYMTAB    LEFT JUSTIFY SYMBOLS 
          SA3    O.SYMTAB 
          SB2    B1+B1
          MX0    12 
          SB7    X2 
          RX1    X3 
          SX4    X3 
          MX5    18 
  
 PRT14    BX6    -X0*X1      LEFT JUSTIFY SYMBOLS AND 
          ZR     X6,PRT16    ELIMINATE ZERO ENTRIES 
          SX2    X3+B1
 PRT15    BX7    X5*X6
          LX6    6
          ZR     X7,PRT15 
          RX2    X2 
          AX6    6
          BX1    X0*X1
          IX6    X6+X1
          BX7    X2          MOVE SYMTAB ENTRY
          WX6    X4 
          SX4    X4+B1
          WX7    X4 
          SX4    X4+B1
 PRT16    SX3    X3+B2
          SB7    B7-B2
          RX1    X3 
          NZ     B7,PRT14 
  
          SA3    O.SYMTAB    UPDATE SYMBOL TABLE SIZE 
          IX7    X4-X3
          SA7    L.SYMTAB 
          ZR     X7,PRTX     IF NO SYMBOLS
          SA1    =1H         PREPARE SUBTITLE 
          SX2    SUBTIT 
          SX3    SUBTIT+SUBL
          RJ     PRESET 
          SA1    =H*        SYMBOLIC REFERENCE TABLE.*
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    SUBTIT 
          SA7    A6+B1
          SA1    A2+B1
          SA2    A1+B1
          BX7    X1 
          LX6    X2 
          SA7    A7+B1
          SA6    A7+B1
          SA1    LPCNT       CAUSE PAGE EJECT 
          SA2    PSIZE
          IX7    X1+X2
          SA7    A1 
          NZ     X2,PRT16.1  IF PAGE EJECT NOT SUPPRESSED 
          SX0    2           ELSE PRINT SOME BLANK LINES
          RJ     LBL
          SA1    LPCNT
          SX0    2
          SA2    CP.PS       CHECK FOR END OF PAGE
          IX6    X1+X0
          IX2    X6-X2
          SA6    A1          INCREMENT LINE COUNT 
          PL     X2,PRT16.1 
          RJ     LHDS        AND PRINT SUBTITLE LINE
 PRT16.1  BSS    0
          SA1    LOSTREF
          ZR     X1,PRT17    IF NO LOST REFERENCES
          RJ     CONDEC 
          SA6    SUBTIT+4 
          SA1    =20H LOST REFERENCES IN
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA1    ASMM+1 
          SX2    1R 
          SA6    A6+B1
          SA7    A6+B1
          LX1    6
          BX6    X1-X2
          SA6    A7+B1
          MESSAGE SUBTIT+4,,R 
          SA1    =10HRENCES.
          SA2    =10H 
          BX6    X1 
          LX7    X2 
          SA6    SUBTIT+6 
          SA7    A6+B1
  
*         SHELL SORT OF SYMBOL TABLE. 
  
 PRT17    SA3    L.SYMTAB 
          SA2    O.SYMTAB 
          ZR     X3,PRTX     IF SYMBOL TABLE IS NOW EMPTY 
          SA0    X2-2        (A0) = TABLE ADDRESS 
          SB7    X3          N = LENGTH 
          SB6    X3          M = N
          SX5    2
  
 PRT18    SX0    B6          M = M/2
          AX0    2
          LX0    1
          SB6    X0 
          ZR     B6,PRT22    IF M = 0 
          SB4    B7-B6       K = N - M
          SB3    B1+B1       J = 1
          SB2    B3+         I = J
 PRT20    SB5    B2+B6       L = I + M
          SX1    A0+B2
          SX2    A0+B5
          RX3    X1          A(I) 
          RX4    X2          A(L) 
          IX6    X4-X3
          PL     X6,PRT21    IF A(L) \ A(I) 
          BX6    X4          INTERCHANGE A(L) AND A(I)
          LX7    X3 
          WX6    X1 
          WX7    X2 
          SX1    X1+B1       INTERCHANGE SECOND WORDS OF ENTRIES
          SX2    X2+B1
          RX3    X1 
          RX4    X2 
          SB2    B2-B6       I = I - M
          BX6    X3 
          LX7    X4 
          WX6    X2 
          WX7    X1 
          GT     B2,PRT20    IF I > 0 
 PRT21    SB3    B3+X5       J = J + 1
          SB2    B3          I = J
          LE     B3,B4,PRT20 IF J @ K 
          EQ     PRT18       LOOP 
  
*         OUTPUT CROSS REFERENCE TABLE. 
  
 PRT22    SX6    B0          QUAL VALUE 
          SA6    QVAL 
  
 PRT23    SA3    L.SYMTAB 
          SA2    O.SYMTAB 
          MX6    0
          SA6    L.MEMORY 
          SA6    LOSTREF
          ZR     X3,PRTX     IF SYMBOL TABLE EMPTY
          SX7    X3-2 
          SX6    X2+2 
          SA7    A3 
          SA6    A2 
          SA0    1R 
          MX0    12 
          RX1    X2 
          SA4    QVAL        CHECK FOR QUALIFIER CHANGE 
          BX6    X0*X1
          BX4    X4-X6
          ZR     X4,PRT27    IF NO CHANGE 
  
*         INDICATE QUALIFIER CHANGE.
  
          SA6    A4 
          SA2    O.QVTAB     SET QUALIFIER NAME 
          LX6    12 
          IX1    X2+X6
          ZR     X6,PRT24    IF QUAL = 0
          SA1    X1-1 
          MX6    -48
          BX6    -X6*X1 
 PRT24    SA6    SUBNAME
          BX1    X6 
          RJ     LJUST
          SA6    LINE+3 
          SX6    A6+B1
          SA6    LLINE
          SA1    =H*SYMBOL QUALIFIER =* 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    LINE+1 
          SA7    A6+B1
          SA1    LPCNT       CHECK LINE NUMBER
          SA2    CP.PS       PAGE SIZE
          IX2    X1-X2       CHECK IF END OF PAGE                        F4810A 
          SB7    X2+7                                                    F4810A 
          NG     B7,PRT25    IN NOT END OF PAGE 
          SA2    PSIZE       FORCE EJECT
          ZR     X2,PRT25    IF NO EJECT
          IX7    X1+X2
          SA7    A1 
          EQ     PRT26
 PRT25    SX0    4           LIST 4 BLANK LINES 
          RJ     LBL
 PRT26    RJ     LISTL
          SX0    2           LIST 2 BLANK LINES 
          RJ     LBL
          SA2    O.SYMTAB 
          SX2    X2-2 
          RX1    X2 
          SA0    1R 
          MX0    12 
  
*         LIST SYMBOL AND VALUE.
  
 PRT27    BX1    -X0*X1 
          MX0    54 
          LX1    18 
          SX6    A0 
          SA6    OCTAL+7
          BX6    -X0*X1      STORE SYMBOL NAME
 PRT28    LX1    6
          SA6    A6+B1
          BX6    -X0*X1 
          NZ     X6,PRT28    STOP AT END OF SYMBOL
          SX2    X2+B1
          RX1    X2          FETCH EQUIVALENT 
          BX6    X1 
          LX6    29 
          PL     X6,PRT32    IF SYMBOL IS UNDEFINED 
          BX7    X2          SAVE CONTENTS OF X2
          SA7    P2TEMP 
          MX0    -21         STORE 21-BIT DEFINITION
          BX1    -X0*X1      CALL PACKO(VALUE,23,0) 
          SX2    25 
          MX3    0
          RJ     PACKO
          SA2    P2TEMP 
          RX1    X2 
          MX0    54 
          BX2    X1 
          LX2    28 
          SX6    A0 
          SA5    =9REXTERNAL* 
          NG     X2,PRT31    IF EXTERNAL
          LX2    59 
          PL     X2,PRT30A   IF NOT SYSTEXT 
          MX3    -3 
          AX2    3
          BX3    -X3*X2      EXTRACT SYSTEXT ORDINAL
          SA2    CP.STEXT+X3
          BX5    X0*X2       GET OVERLAY NAME 
          NZ     X5,PRT31 
          SA5    CP.LIB+X3   IF NONE, USE FILE NAME 
          EQ     PRT31
 PRT30A   AX1    21          FIND RELOCATION
          MX2    52 
          BX3    -X2*X1 
          LX1    51 
 +        PL     X1,*+1 
          SX6    1R-
          SX5    A0 
          ZR     X3,PRT31    IF ABSOLUTE
          SA4    LLB
          SA5    =9RLCMLOCAL* 
          SA2    O.USETAB 
          SA1    UI 
          IX2    X2+X1       BASE ADDRESS OF BLOCK GROUP
          LX3    24 
          BX4    X4-X3
          ZR     X4,PRT31    IF LCM LOCAL 
          MX1    -9 
          SA2    X2+2 
          LX1    24 
 +        BX4    -X1*X2      SEARCH USE TABLE 
          IX7    X4-X3
          SA2    A2+4 
          NZ     X7,*-1 
          SA5    A2-6        GET BLOCK NAME 
 PRT31    SA6    OCTAL+27 
          MX3    6           LEFT JUSTIFY BLOCK NAME
          SX2    A0 
 +        NZ     X5,*+1 
          SX5    2R// 
          BX7    X5 
          AX7    60 
          BX5    X5-X7
 +        BX7    X3*X5
          LX5    6
          ZR     X7,* 
          BX6    -X0*X5 
 +        SA6    A6+B1
          LX5    6
          BX6    -X0*X5 
          NZ     X6,*-1 
          SA1    O.SYMTAB 
          SX2    X1-1 
          EQ     PRT33
  
 PRT32    SX6    1RU
          SA6    OCTAL+2
 PRT33    RX1    X2          SYMBOL EQUIVALENCE 
          AX1    42 
          BX6    X1 
          SA6    P2TEMP      CHAIN ADDRESS
  
 PRT34    SA5    P2TEMP 
          SA2    O.REFTAB 
          ZR     X5,PRT38    IF END OF CHAIN
          IX3    X2+X5
          SA1    X3-1 
          LX7    X1          SET NEXT LINK
          AX7    42 
          SA7    A5 
          ZR     X7,PRT35    IF END OF CHAIN
          IX3    X2+X7       READ NEXT ENTRY
          SA3    X3-1 
          BX6    X3-X1       COMPARE ENTRIES
          MX0    18 
          BX6    -X0*X6 
          ZR     X6,PRT34    IF IDENTICAL ENTRIES 
 PRT35    SA2    XR 
          ZR     X2,PRT36    IF ONLY ADDRESS TO XREF
          BX7    X1 
          SA7    A5+B1       SAVE ENTRY (P2TEMPA) 
          RJ     CONREF      CONVERT PAGE/LINE
          ADDWORD MEMORY
          SA2    XR 
          NG     X2,PRT34    IF ONLY PAGE/LINE
          SA1    P2TEMPA
          EQ     PRT37       MAKE ADDRESS XREF ENTRY
 PRT36    MX0    54 
          BX3    -X0*X1 
          SX2    X3-1RL 
          ZR     X2,PRT34    IF DEFINING ENTRY, LOOP
 PRT37    RJ     CONADD      CONVERT ADDRESS
          ADDWORD MEMORY
          EQ     PRT34       LOOP 
  
 PRT38    SA1    L.MEMORY    PRINT TABLE OF ENTRIES 
          NZ     X1,PRT39    IF ENTRIES IN TABLE
          RJ     LISTL
          EQ     PRT23       LOOP 
  
*         LIST TABLE OF REFERENCES. 
  
 PRT39    SX6    X1+7        CALCULATE NUMBER OF ROWS 
          AX6    3
          SA6    P2TEMP      NROWS
          SA6    A6+B1       INCREMENT
          MX7    0
          SA7    A6+B1       INDEX
          SA1    LPCNT       CHECK IF ROOM ON PAGE
          IX2    X1+X6
          SA3    CP.PS       PAGE SIZE                                   F4810A 
          IX1    X2-X3                                                   F4810A 
          NG     X1,PRT40    IF ROOM ON PAGE                             F4810A 
          SX6    X3+5        ELSE, FORCE EJECT                           F4810A 
          SA6    A1 
  
 PRT40    SA1    P2TEMP      DECREMENT ROW COUNT
          SX6    X1-1 
          ZR     X1,PRT44    IF END OF TABLE
          SA6    A1 
          SA2    A1+B1
          SA3    A2+B1
          SX6    X3+B1       INCREMENT INDEX
          SA4    O.MEMORY 
          SA5    L.MEMORY 
          SA6    A3 
          SB6    X4          TABLE ADDRESS
          SB7    X5+B6       TABLE END
          SB5    X2          INCREMENT
          SB6    X3+B6       ENTRY ADDRESS
          SB4    B0          LINE INDEX 
          SA1    XR 
          SB3    X1 
          SX6    X6+B1       INCREMENT INDEX
          NE     B3,B1,PRT42 IF NOT BOTH
          SA6    A6 
          SB5    B5+B5
 PRT41    SA1    B6          READ ENTRIES 
          SA2    B6+B1
          BX6    X1 
          LX7    X2 
          SA6    LINE+B4
          SA7    A6+B1
          SB6    B6+B5
          SB4    B4+2 
          LT     B6,B7,PRT41 LOOP 
          SX6    A7+B1
          EQ     PRT43
 PRT42    SA1    B6          READ ENTRY 
          BX6    X1 
          SA6    LINE+B4
          SB6    B6+B5
          SB4    B4+B1
          LT     B6,B7,PRT42 LOOP 
          SX6    A6+B1
 PRT43    SA6    LLINE
          RJ     LISTL       LIST LINE
          EQ     PRT40       LOOP FOR NEXT LINE 
 PRT44    SA1    LOSTREF
          SA2    L.MEMORY 
          ZR     X1,PRT23    IF NO LOST REFERENCES
          IX6    X1+X2
          SA6    A2 
          RJ     ASU         ACCUMULATE STORAGE USED
          EQ     PRT23
 COMPASS  TITLE  COMPASS MAIN BATCH CONTROL.
*         COMPASS - MAIN CONTROL                                         CPSA097
  
  
          USE    CONTROL
          SEG    CONTROL. 
          QUAL
 CMP      SB1    1           (B1) = CONSTANT 1
          EQ     PASS0       INITIALIZE COMPASS 
 CMP1     SX6    B1          SET INPUT PRESENCE FLAG
          SA6    INPRES 
          EQ     /PASS1/PASS1  EXECUTE PASS1
 EXITP1   EQ     /PASS2/PASS2 EXECUTE PASS2 
 EXITP2   RJ     ATS         ACCUMULATE TOTAL STORAGE USED
          RJ     DFL         DECREASE FL
          SA1    ERCNT
          SA2    CP.ERRCT 
          IX6    X1+X2       ACCUMULATE ERROR COUNT 
          SA6    A2 
  
*         TEST FOR END OF ASSEMBLY BATCH. 
  
          SA1    EOFINP 
          SA2    CP.BATCH 
          NZ     X1,CMP2     IF END OF SOURCE INPUT 
          LX2    59-11
          PL     X2,CMP1     IF NOT CALLED BY A COMPILER
          SA1    CP.CARD
          SA2    =1H
          SA3    A1+B1       CHECK FOR *IDENT*
          MX0    36 
          SA4    =6LIDENT 
          IX6    X1-X2
          BX7    X0*X3
          NZ     X6,CMP1A    IF COLUMNS 1-10 NOT ALL BLANKS 
          BX7    X7-X4
          NZ     X7,CMP1A    IF COLUMNS 11-16 NOT *IDENT* 
          EQ     CMP1 
  
 CMP1A    SA1    CP.LISTF 
          ZR     X1,CMP3     IF NO LISTING
  
 RM       IFEQ   CP#RM,0
          WEOR   O
          CHECK  O
          EQ     CMP3 
  
 RM       ELSE
          WEOR   O
          CHECK  O
          EQ     CMP3 
 RM       ENDIF 
  
 CMP2     MX6    0           SIGNAL END OF SOURCE INPUT 
          SA2    CP.BATCH 
          SA6    CP.CARD
          MX7    1
          LX2    59-11
          SA7    CP.IFORM 
          MI     X2,CMP1A    IF CALLED BY FTN, DONT CLOSE EVERYTHING. 
  
          IFNE   CP#RM,0,1
          CLOSEM I,N         CLOSE INPUT FILE 
  
          SA1    CP.LISTF 
          ZR     X1,CMP3     IF NO LISTING
 RM       IFEQ   CP#RM,0                                                 F4810A 
          SA1    FRSTLIN     CHECK IF PRINT DENSITY WAS CHANGED 
          ZR     X1,CMP2B    IF PRINT DENSITY=DEFAULT 
          SA1    LASTLIN
          ZR     X1,CMP2B    IF PRINT DENSITY AT DEFAULT
          WRITEH O,A1,1      ELSE RESTORE PRINT DENSITY TO DEFAULT       F4810A 
 CMP2B    BSS    0
          WEOR   O
  
 RM       ELSE                                                           F4810A 
          SA1    FRSTLIN
          ZR     X1,CMP2A    IF PRINT DENSITY=DEFAULT                    F4810A 
          SA1    LASTLIN
          ZR     X1,CMP2A    IF PRINT DENSITY AT DEFAULT
          PUT    O,LASTLIN,10  ELSE,RESTORE PRINT DENSITY TO DEFAULT     F4810A 
 CMP2A    BSS    0                                                       F4810A 
          CLOSEM O,N         CLOSE OUTPUT FILE
 RM       ENDIF                                                          F4810A 
  
          CHECK  O
 CMP3     SA1    CP.PAGE
          MI     X1,CMP4     IF NOT PROPAGATING PAGE NUMBERING
          SA2    PGCNT
          BX6    X2          UPDATE COMMUNICATION WORD
          SA6    A1 
  
*         CLOSE FILES.
  
 RM       IFEQ   CP#RM,0
  
 CMP4     SA1    S+1
          PL     X1,CMP4A    IF SCRATCH IS MASS STORAGE 
          REWIND S
          EQ     CMP5 
 CMP4A    RETURN S
 CMP5     SA1    R+1
          PL     X1,CMP5A    IF REFERENCE IS MASS STORAGE 
          REWIND R
          EQ     CMP6 
 CMP5A    RETURN R
 CMP6     SA1    E
          SA2    E+2         CHECK ERROR LISTING FILE 
          SA3    A2+B1
          LX1    59-3 
          IX4    X2-X3
 +        MI     X1,*+1      IF ANYTHING WAS WRITTEN
          ZR     X4,CMP7     IF BUFFER EMPTY
          SA1    FRSTLIN
          ZR     X1,CMP6A    IF PRINT DENSITY IS NOT 8 LPI
          SA1    LASTLIN
          ZR     X1,CMP6A    IF PRINT DENSITY AT DEFAULT
          WRITEH E,A1,1      RESTORE PRINT DENSITY TO DEFAULT            F4810A 
 CMP6A    BSS    0                                                       F4810A 
          WRITER E,RECALL 
 CMP7     RECALL B           WAIT FOR BINARY OUTPUT COMPLETE
          RECALL S
          RECALL R
  
 RM       ELSE
  
 CMP4     FETCH  S,OC,X1
          SX6    X1-#YES# 
          NZ     X6,CMP5     IF SCRATCH FILE NOT OPEN 
          SA1    SCR+1
          PL     X1,CMP4A    IF SCRATCH IS MASS STORAGE 
          CLOSEM S,R
          EQ     CMP5 
 CMP4A    CLOSEM S,U
 CMP5     FETCH  R,OC,X1
          SX6    X1-#YES# 
          NZ     X6,CMP6     IF REFERENCE FILE NOT OPEN 
          SA1    REF+1
          PL     X1,CMP5A    IF REFERENCE IS MASS STORAGE 
          CLOSEM R,R
          EQ     CMP6 
 CMP5A    CLOSEM R,U
 CMP6     SA1    E
          ZR     X1,CMP7     IF NO ERROR FILE 
          SA1    CP.BATCH 
          LX1    59-11
          MI     X1,CMP7     IF CALLED BY FTN, DONT CLOSE E FILE. 
          SA1    FRSTLIN
          ZR     X1,CMP6A    IF PRINT DENSITY IS NOT 8 LPI
          SA1    LASTLIN
          ZR     X1,CMP6A    IF PRINT DENSITY AT DEFAULT
          PUT    E,LASTLIN,10  ELSE, RESTORE PRINT DENSITY TO DEFAULT    F4810A 
 CMP6A    BSS    0                                                       F4810A 
          CLOSEM E,N
          CHECK  E
          SA1    EOFINP                                                 S028 372
          SA2    E                                                      S028 373
          SA3    O                                                      S028 374
          BX6    X2-X3                                                  S028 375
          NZ     X1,CMP7     IF END OF INPUT                            S028 376
          NZ     X6,CMP7     IF LISTING FILES NOT SAME FILE NAMES       S028 377
          OPENM  O,OUTPUT,N  RE-OPEN LONG LISTING FILE                  S028 378
 CMP7     FETCH  B,OC,X1
          SB7    X1-#YES# 
          NZ     B7,CMP7A    IF BINARY NOT OPEN 
          SA2    CP.BATCH 
          LX2    59-11
          MI     X2,CMP7A    IF CALLED BY FTN, LET FTN CLOSE THIS FILE. 
          SA1    EOFINP 
          ZR     X1,CMP7A    IF NOT END OF SOURCE INPUT 
          CLOSEM B,N
          CHECK  B
 CMP7A    BSS    0
  
 RM       ENDIF 
                                                                        S028 380
          SA1    COMPPS                                                  F4810A 
          BX6    X1                                                      F4810A 
          SA6    CP.PS       RESTORE COMPILER PAGE SIZE                  F4810A 
          SA1    COMPPD                                                  F4810A 
          BX6    X1                                                      F4810A 
          SA6    CP.PD       RESTORE COMPILER PRINT DENSITY              F4810A 
          SA1    COMPPW 
          BX6    X1 
          SA6    CP.PW       RESTORE COMPILER PRINT WIDTH 
  
*         RESTORE ECS/LCM FIELD LENGTH.                                 S028 381
                                                                        S028 382
          SA1    CP.NFLL     NOMINAL FL                                 S028 383
          SA2    CP.AFLL     ACTUAL FL                                  S028 384
          IX7    X1-X2                                                  S028 385
          BX6    X1                                                     S028 386
          ZR     X7,CMP7B    IF NO CHANGE                               S028 387
          SA6    A2          UPDATE (CP.AFLL)                           S028 388
          LX6    30                                                     S028 389
 +        NZ     X1,*+1                                                 S028 390
          MX6    30          -0 = ZERO FIELD LENGTH                     S028 391
 +        SA6    LCMEND                                                 S028 392
          MEMORY ECS,LCMEND,R      REQUEST FIELD LENGTH                 S028 393
 CMP7B    BSS    0                                                      S028 394
  
          RJ     RCS         RESTORE COMPILER SPACE IF NECESSARY         F4810B 
          EQ     CP.STOP     EXIT TO (0,0) OVERLAY
          TITLE  COMPASS INITIALIZATION - OVERLAYED CODE. 
 PASS0    SPACE  4,8
**        PASS0 - INITIALIZE COMPASS. 
  
  
          USE    PASS0
          SEG    INITIALIZATION.
 PASS0    RJ     CTM         CHECK MACHINE TYPE 
          RJ     SMP         SET MEMORY PARAMETERS                       F4810B 
          RJ     SCS         SAVE COMPILER SPACE IF NECESSARY            F4810B 
          TIME   BTIME       GET ASSEMBLY BATCH START TIME
          SA1    CP.BATCH 
          SA2    CP.PAGE
          LX1    59-11
          BX3    X1          SET FMODE = ABS (CP.BATCH) 
          AX1    59 
          AX3    59-11
          BX6    X3-X1
          SX7    B0 
          MI     X2,CMP8     IF NOT PROPAGATING PAGE NUMBERS
          SA3    CP.EPAG
          SX7    X3 
          PL     X3,CMP7C    IF ERROR PAGE PROPAGATION FLAG ALREADY SET 
          SX7    B0 
          SA7    A3          ELSE SET ERROR PAGE PROPAGATION FLAG 
 CMP7C    SA7    EPCNT       INITIALIZE ERROR FILE PAGE COUNT 
          BX7    X2          SET PAGE NUMBER
 CMP8     SA6    FMODE
          SA7    PGCNT
          RJ     SFP         SET FILE PARAMETERS
          RJ     SFL         SET FIELD LENGTH 
          RJ     ZLC         ZERO FIRST 100B OF LCM FIELD LENGTH IF ANY 
          RJ     SPF         SET PRINTER FLAGS                           F4810A 
  
 DEBUG    IFNE   DEBUG,0
          RJ     /DEBUG/RDD  READ DEBUGGING DIRECTIVES
          SA2    LOCORE 
          SA3    CP.NFLS     CLEAR MANAGED TABLE AREA 
          RJ     CLS
 DEBUG    ENDIF 
  
          SA1    CP.CARD
          NZ     X1,CMP9     IF SOURCE CARD READY 
          MI     X1,CMP9
  
 RM       IFEQ   CP#RM,0
          READ   I           PRIME THE PUMP 
 RM       ELSE
          OPENM  I,INPUT,N
          FETCH  I,RT,X1     CHECK RECORD TYPE
          ZR     X1,CMP8.5   W TYPE OK
          SB7    X1-1 
          ZR     B7,CMP8.5   F TYPE OK
          SB7    B7-2 
          ZR     B7,CMP8.5   Z TYPE OK
          MESSAGE  CMPB,,R   ANYTHING ELSE IS AN ERROR
          ABORT  ,NODUMP
 CMP8.5   BSS    0
          SA1    CP.LISTF 
          ZR     X1,CMP9     IF NO LONG LISTING 
          OPENM  O,I-O,N
 RM       ENDIF 
  
 CMP9     RJ     IOT         INITIALIZE OPCODE TABLE
          RJ     LST         LOAD SYSTEM TEXT 
          RJ     OPF         OPEN FILES 
  
 OVL      IFNE   OVERLAY,0
          SA1    OVLA        LOAD SECONDARY OVERLAY 
          SA2    A1+B1
          RJ     OVL
 OVL      ENDIF 
  
          SA1    CP.CARD
          SX2    I
          NZ     X1,CMP1     IF SOURCE CARD READY 
          MI     X1,CMP1
          SA0    A1 
          RJ     CIF         CHECK INPUT FORMAT 
          SA1    EOFINP 
          ZR     X1,CMP1     IF INPUT PRESENT 
          MESSAGE CMPA,,R 
          SX6    B1          SET ERR FLAG 
          SA6    ERCNT
          EQ     EXITP2      QUIT 
 INPRES   DATA   0           INPUT PRESENCE FLAG
  
 CMPA     DATA   C*  INPUT FILE EMPTY OR MISPOSITIONED.*
 CMPB     DATA   C* INPUT FILE RECORD TYPE NOT ALLOWED.*
 PRTA     SPACE  4,8
**        WHEN THE CROSS-REFERENCE TABLE HAS OVERFLOWED, THE
*         FOLLOWING SPACE IS USED AS WORKING STORAGE DURING 
*         PRINTING OF THE CROSS-REFERENCE TABLE, AND THEN THE 
*         SECONDARY OVERLAY IS RELOADED.  SEE SUBROUTINE *PRT*. 
  
  
 PRTA     DATA   0           OVERFLOW TO DISK FLAG
 CBUF     BSS    0           END OF NON-OVERLAID AREA 
 TBUF     BSS    0           BUFFER FOR READING CROSS-REFERENCE TABLE 
 PRTB     EQU    TBUF+RBUFL  ORIGIN OF MANAGED TABLE AREA 
 RM       IFNE   CP#RM,7
          LIST   X
*CALL     COMCCPM 
          LIST   *
 RM       ENDIF 
 CTM      SPACE  4
**        CTM - CHECK MACHINE TYPE. 
  
  
 MOD      DECMIC "MODEL"/10*10
 NUMCHR   MICCNT MODEL
 MODSH    EQU    NUMCHR*6 
  
 CTM1     SX4    CTMAS       DECIDE WHICH MACHINE WE ARE USING
          SX5    X3-4        AND STUFF THE CORRECT CPU TYPE INTO
          MI     X5,CTM2     THE ASSEMBLY MESSAGE 
          SX4    CTMAP
          ZR     X5,CTM2
          SX4    CTMA76 
 CTM2     SA1    X4 
          SX6    0R"MOD"
          IX6    X6+X3
          LX3    4*6-MODSH
          BX7    X1 
          LX6    -MODSH 
          SA7    TLINE
          SA6    CP.CPU 
  
 CTM      PS                 RETURN EXIT
          MX1    1
          SB2    100B 
          AX1    X1,B2       -0 IF MODEL 76, +0 OTHERWISE 
          SX3    6
          MI     X1,CTM1     IF MODEL 76
  
          SX6    0220B       JP B2
          SB2    CTM1 
          LX6    48 
  
          BX1    X6          FORM  +         JP     B2
          LX1    30                -         JP     B2
          BX6    X1+X6
 +        SA6    *+1         STORE *JP B2* (BOTH UPPER AND LOWER) 
          SX3    3
  
 +        SX3    4           JUMP TO CTM1 IF MODEL 72 OR 73 
          JP     CTM1        EXECUTE IF MODEL 74
  
 CTMA76   DATA   H*7600-TYPE *
 CTMAP    DATA   H* PARALLEL *
 CTMAS    DATA   H*   SERIAL *
 IOT      SPACE  4
**        IOT - INITIALIZE OPCODE TABLE.
  
  
 IOT      PS                 RETURN EXIT
          MANAGE OPTAB,2*NOPCT     ALLOCATE BASIC TABLE AREA
          IX3    X2+X3
          RJ     CLS         CLEAR IT 
          SX6    LGOPS-2
          SA3    EXVAL
 IOT1     SA1    OPS+X6      GET NEXT ENTRY 
          SA2    A1+B1
          SA6    A3 
          RJ     ENTOP       ENTER OPCODE TABLE 
          SA3    EXVAL
          SX6    X3-2 
          PL     X6,IOT1     LOOP 
          EQ     IOT         RETURN 
 LGT      SPACE  4
**        LGT - LOAD SYSTEM TEXT FROM A NON-LIBRARY FILE. 
*         ENTRY  (X7) = SYSTEM TEXT ORDINAL.
*                (X1) = OVERLAY NAME. 
*                (X2) = BITS 17-00 OF (X1). 
*         EXIT   (X0) = 0 IF TEXT LOADED. 
  
  
 LGT      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          SA3    CP.LIB+X7
          SX4    3
          BX6    X1-X2
          IX7    X3+X4
          SA6    EXVAL       SAVE OVERLAY NAME
          SA7    G           STORE FILE NAME IN FET 
          REWIND G
          RJ     MTD         MOVE TABLES DOWN TO GET ROOM 
          SA1    O.MEMORY 
          SA2    O.ENDTAB 
          SX0    X1          PRESET FAILURE RETURN
          IX6    X2-X1
          SA0    X6          AVAILABLE MEMORY 
 LGT1     READ   G
 LGT2     READW  G,X0,1      READ 7700 TABLE
          MI     X1,LGT      IF EOF 
          NZ     X1,LGT1     IF EOR 
          SA2    X0 
          LX2    18 
          SX6    X2-770000B 
          ZR     X6,LGT4     IF 7700 TABLE
 LGT3     READW  G,X0,A0     SKIP TO EOR
          ZR     X1,LGT3
          EQ     LGT1        TRY NEXT RECORD
 LGT4     LX2    6
          SX5    X2-1 
          MI     X5,LGT3     IF ZERO-LENGTH TABLE 
          READW  G,X0,1      GET RECORD NAME
          SA1    EXVAL
          SA2    X0 
          BX6    X1-X2
          ZR     X1,LGT5     IF NO OVERLAY NAME SPECIFIED 
          NZ     X6,LGT3     IF WRONG NAME
 LGT5     READW  G,X0,1 
          SX5    X5-1        SKIP 7700 TABLE
          PL     X5,LGT5
          SA1    X0          CHECK OVERLAY HEADER 
          SA2    =50000101BS36
          BX6    X1-X2
          NZ     X6,LGT3     IF NOT A (1,1) OVERLAY 
 LGT6     READW  G,X0+B1,A0-B1  READ REMAINDER OF OVERLAY                F4810B 
          SX0    B0          INDICATE TEXT LOADED                        F4810B 
          NZ     X1,LGT      IF ALL OF OVERLAY READ, RETURN              F4810B 
          SX0    B6-B1       (B6) = ADDRESS OF LAST WORD TRANSFERED      F4810B 
          MX1    0                                                       F4810B 
          RJ     RFL         REQUEST FLINC WORDS MORE CENTRAL MEMORY     F4810B 
          ZR     X3,LST7A    IF REQUEST NOT COMPLETED, ABORT             F4810B 
          SA2    O.ENDTAB    ELSE SET UP TO CONTINUE                     F4810B 
          IX1    X2-X0       AMOUNT OF SPACE AVAILABLE                   F4810B 
          SA0    X1+B1       ADD 1 WORD                                  F4810B 
          EQ     LGT6        GO GET REST OF TEXT                         F4810B 
  
 RM       ELSE
  
          SA3    CP.LIB+X7
          BX6    X1-X2
          LX7    X3 
          SA6    EXVAL       SAVE OVERLAY NAME
          SA7    GDUM        STORE FILE NAME IN FIT 
          RJ     MTD         MOVE TABLES DOWN TO GET ROOM 
          SX1    LGDUM
          SX2    GDUM 
          SX3    G           RE-INITIALIZE FIT
          RJ     MOVE 
          SA1    O.MEMORY 
          SA2    O.ENDTAB 
          IX3    X2-X1       AVAILABLE WORDS
          IX4    X3+X3
          LX3    3           MULTIPLY BY 10 
          IX4    X3+X4
          STORE  G,MRL=X4    SET MAXIMUM RECORD LENGTH
          STORE  G,WSA=X1    WORKING STORAGE ADDRESS
          STORE  G,DX=LGT8   END OF DATA EXIT 
          OPENM  G,INPUT,R   OPEN THE FILE WITH REWIND
          FETCH  G,RT,X2
          SB7    X2-#ST#
          SX6    #EOS#
 +        NZ     B7,*+1      IF NOT *S* RECORDS 
          SX6    X6+#EOR# 
          SA6    G-1
  
 LGT1     GETP   G,,10       GET FIRST WORD OF SECTION
          SA1    O.MEMORY 
          SA2    X1 
          LX2    18 
          SX6    X2-770000B 
          ZR     X6,LGT5     IF 7700 TABLE
 LGT2     GETP   G,,10       SKIP REST OF RECORD
 LGT3     FETCH  G,FP,X2
          SX0    #EOI#+#EOP#
          BX3    X0*X2
          SA1    G-1
          NZ     X3,LGT4     IF EOI OR EOF
          BX4    X1*X2
          ZR     X4,LGT2     IF NOT END OF SECTION
          EQ     LGT1 
 LGT4     CLOSEM G,R         CLOSE WITH REWIND
          SX0    B1          INDICATE FAILURE 
          EQ     LGT         RETURN 
 LGT5     LX2    6
          SX7    X2          WORD COUNT 
          IX0    X7+X7
          LX7    3           MULTIPLY BY 10 
          IX4    X0+X7
          GETP   G,,X4       SKIP THE 7700 TABLE
          SA1    EXVAL
          SA2    O.MEMORY 
          ZR     X1,LGT6     IF NO OVERLAY NAME SPECIFIED 
          SA3    X2 
          BX6    X3-X1
          NZ     X6,LGT2     IF WRONG NAME
 LGT6     GETP   G,,10       READ 5000 TABLE
          SA3    O.MEMORY 
          SA2    =50000101BS36
          SA1    X3 
          BX6    X1-X2
          NZ     X6,LGT2     IF NOT A (1,1) OVERLAY 
          SX3    X3+B1
          SX4    10 
          STORE  G,DX=LGT9   SET NEW DATA EXIT
          STORE  G,WSA=X3 
          FETCH  G,MRL,X2 
          IX1    X2-X4
          STORE  G,MRL=X1 
 LGT6A    GETP   G,,X1       GET REMAINDER OF RECORD                     F4810B 
          FETCH  G,FP,X1
          SX0    #EOR#
          BX6    X0*X1
          ZR     X6,LGT9+1   IF NOT AT EOR, CHECK FOR EOP OR EOI         F4810B 
          FETCH  G,PTL,X2 
 LGT7     SX1    1S20/10+1
          BX4    X2          RECORD LENGTH IN CHARACTERS
          IX3    X1*X2
          AX3    20          RECORD LENGTH IN WORDS 
          FETCH  G,WSA,X1 
          IX3    X1+X3       ADJUST WSA FOR NEXT GET
          STORE  G,WSA=X3 
          FETCH  G,MRL,X2 
          IX1    X2-X4       REDUCE MRL 
          MI     X1,LGT10    IF NO MORE ROOM, GO GET MORE FL             F4810B 
          STORE  G,MRL=X1 
          EQ     LGT6A
  
 LGT8     PS                 DATA EXIT FOR SKIPPING TO END OF SECTION 
          EQ     LGT3        PROCESS OF END OF DATA 
  
 LGT9     PS                 DATA EXIT FOR READING OVERLAY
          SA2    G-1
          FETCH  G,FP,X1
          SX0    #EOI#+#EOP#+X2 
          BX6    X0*X1
          ZR     X6,LGT10    IF NOT THROUGH                              F4810B 
          SX0    B0          INDICATE TEXT LOADED                        F4810B 
          SA6    EXVAL
          CLOSEM G,R         CLOSE THE FILE 
          EQ     LGT         RETURN                                      F4810B 
                                                                         F4810B 
 LGT10    MX1    0                                                       F4810B 
          RJ     RFL         REQUEST FLINC WORDS MORE CENTRAL MEMORY     F4810B 
          ZR     X3,LST7A    IF ALREADY AT MAXFL, ABORT                  F4810B 
          FETCH  G,PTL,X2    GET NUMBER OF CHARACTERS TRANSFERED         F4810B 
          SX1    1S20/10+1                                               F4810B 
          BX4    X2          LENGTH IN CHARACTERS                        F4810B 
          IX3    X1*X2                                                   F4810B 
          AX3    20          LENGTH IN WORDS                             F4810B 
          FETCH  G,WSA,X1    GET PREVIOUS WORKING STORAGE AREA ADDRESS   F4810B 
          IX3    X1+X3       ADJUST WORKING STORAGE AREA FOR NEXT READ   F4810B 
          STORE  G,WSA=X3    STORE NEW WSA IN FIT                        F4810B 
          SA2    O.ENDTAB    END OF TABLE SPACE                          F4810B 
          IX3    X2-X3       WORDS AVAILABLE                             F4810B 
          IX4    X3+X3       MULTIPLY BY 10 TO GET NUMBER OF CHARACTERS  F4810B 
          LX3    3                                                       F4810B 
          IX1    X3+X4                                                   F4810B 
          STORE  G,MRL=X1    STORE NEW MAXIMUM RECORD LENGTH IN FIT      F4810B 
          EQ     LGT6A       GO GET REST OF RECORD                       F4810B 
                                                                         F4810B 
 RM       ENDIF                                                          F4810B 
  
  
**        FET/FIT FOR SYSTEM TEXT LOADING FROM FILES. 
  
  
 GET      FET    ,GBUF,GBUFL,3
  
 RM       IFEQ   CP#RM,0
 G        EQU    GET
 RM       ELSE
          IFEQ   CP#RM,6,1
 G        FILE   FO=SQ,BT=C,RT=S,CM=NO,LT=UL,FET=GET,FWB=GBUF,BFS=GBUFL,
,ERL=1
          IFEQ   CP#RM,7,1
 G        FILE   FO=SQ,BT=,RT=W,CM=NO,PD=INPUT
          BSSZ   GET+40B-*
  
          IFEQ   CP#RM,6,1
 GDUM     FILE   FO=SQ,BT=C,RT=S,CM=NO,LT=UL,FET=GET,FWB=GBUF,BFS=GBUFL,
,ERL=1
          IFEQ   CP#RM,7,1
 GDUM     FILE   FO=SQ,BT=,RT=W,CM=NO,PD=INPUT
 LGDUM    EQU    *-GDUM 
  
 RM       ENDIF 
 LLT      SPACE  4
**        LLT - LOAD LIBRARY TEXT.
*         ENTRY  (X7) = SYSTEM TEXT ORDINAL.
*                (X1) = OVERLAY NAME. 
*         EXIT   (X0) = 0 IF TEXT LOADED. 
  
  
 LLT      PS                 RETURN EXIT
          SA3    CP.LIB+X7
          BX6    X1 
          LX7    X3 
          SA6    LLTA        OVERLAY NAME 
          SA7    LLTA+2      LIBRARY NAME 
 LLT0     BSS    0                                                       F4810B 
          RJ     MTD         MOVE TABLES DOWN TO GET ROOM 
          SA1    O.ENDTAB                                                F4810B 
          SA2    O.MEMORY                                                F4810B 
          IX1    X1-X2       SPACE AVAILABLE FOR TEXTS                   F4810B 
          SX3    TXTFL                                                   F4810B 
          IX1    X1-X3       SPACE AVAILABLE-SPACE REQUIRED FOR TEXT     F4810B 
          PL     X1,LLT0A    IF ENOUGH SPACE, GO LOAD TEXT               F4810B 
          IX1    X2+X3                                                   F4810B 
          SX1    X1+10D                                                  F4810B 
          BX1    -X1                                                     F4810B 
          RJ     RFL         REQUEST FL OF O.MEMORY+TXTFL+10D(SLOP)      F4810B 
 LLT0A    BSS    0                                                       F4810B 
          SA1    LLTA+2 
          SX5    0101014B 
          ZR     X1,LLT1     IF NO LIBRARY NAME SPECIFIED 
          SA2    LLTA 
          BX6    X1 
          LX7    X2 
          SX5    0101214B    SET 3-WORD REQUEST 
          SA6    A2 
          SA7    A1 
 LLT1     SA1    O.ENDTAB    SETUP SECOND WORD OF REQUEST 
          SA2    O.MEMORY 
          LX5    39 
          LX1    18 
          BX3    X5+X2
          SX6    B0 
          BX7    X3+X1
          SA6    RA.LDR      CLEAR REPLY WORD 
          SA7    LLTA+1 
          LOADREQ LLTA       REQUEST OVERLAY LOAD 
  
 RM       IFNE   CP#RM,7
 LLT2     RECALL             WAIT FOR LOADER
          SA4    RA.LDR 
          ZR     X4,LLT2
 RM       ENDIF 
  
 BE       IF     DEF,NOSBE
          SA1    LLTA+1 
          SA2    A1-B1
          SX0    B1 
          LX1    -36         GET FATAL ERROR FLAG 
          SX6    X2-9 
          BX0    X0*X1
          NZ     X6,LLT      IF SUFFICIENT STORAGE, RETURN               F4810B 
          SX1    B0                                                      F4810B 
          RJ     RFL         REQUEST FLINC WORDS MORE CENTRAL MEMORY     F4810B 
          ZR     X3,LST7A    IF ALREADY AT MAXIMUM, GO ABORT             F4810B 
          EQ     LLT0        ELSE, GO GET MORE TEXT                      F4810B 
 BE       ELSE
          MX0    0           (X0) = 0, TEXT LOADED
          EQ     LLT         RETURN 
 BE       ENDIF 
  
 LLTA     BSS    3           LOADER PARAMETER LIST
 LST      SPACE  4
**        LST - LOAD SYSTEM TEXT. 
  
  
 LST      PS                 RETURN EXIT
  
          IFNE   OVERLAY,0
          RJ     ASU         ACCUMULATE STORAGE USED
          SA2    LOCORE 
          BX6    X2          SAVE NORMAL FWA OF MANAGED TABLE AREA
          SA6    LSTA 
          SX1    ENDZ        SET NEW FWA TO USE ALL AVAILABLE SPACE 
          RJ     ACL
          ENDIF 
  
          SA1    CP.STEXT 
          SA2    CP.LIB      CHECK FOR *S=0*
          SX7    B1 
          NZ     X1,LST1     IF SYSTEM TEXT(S) SPECIFIED
          BX6    X2 
          ZR     X2,LST6A    IF NONE AT ALL 
          SA6    A1 
 LST1     SA7    A2          STORE SYSTEM TEXT ORDINAL
          SA1    CP.STEXT+X7
          SX2    X1 
          ZR     X2,LST1A    IF *S* ARGUMENT
          RJ     LGT         LOAD FROM FILE (*G* ARGUMENT)
          EQ     LST1B
 LST1A    RJ     LLT         LOAD LIBRARY TEXT
 LST1B    NZ     X0,LST7     IF NOT LOADED
          SA3    O.MEMORY 
          SA2    X3+B1       SYSTEM SYMBOL TABLE LENGTH 
          BX1    X2 
          AX2    18          VERIFY SYSTEXT FORMAT
          SB2    X1+B1
          NZ     X2,LST8     IF BAD SYSTEXT 
          SA4    O.ENDTAB 
          SB3    X4          FIND END OF OVERLAY
          SB2    A2+B2
          GE     B2,B3,LST8  IF BAD SYSTEXT 
          MI     B2,LST8
          SA2    B2          SYSTEM MICRO TABLE LENGTH
          SB2    X2+B1
          SB2    A2+B2
          GE     B2,B3,LST8  IF BAD SYSTEXT 
          MI     B2,LST8
          SA2    B2          SYSTEM MACRO DEFINITION TABLE LENGTH 
          SB2    X2+B1
          SB2    A2+B2
          GE     B2,B3,LST8  IF BAD SYSTEXT 
          MI     B2,LST8
          SA2    B2          SYSTEM OPCODE TABLE LENGTH 
          SB2    X2+B1
          SB2    A2+B2
          GE     B2,B3,LST8  IF BAD SYSTEXT 
          MI     B2,LST8
          SX6    B2          LWA+1 OF OVERLAY 
          IX6    X6-X3
          SA6    L.MEMORY 
          MANAGE SSYMS,X1    ALLOCATE SYSTEM SYMBOL TABLE 
          RJ     ASU         ACCUMULATE STORAGE USED
          SA2    CP.LIB 
          SA3    O.MEMORY 
          SA4    L.SSYMS
          SA1    O.SSYMS
          LX2    36          POSITION SYSTEM TEXT ORDINAL 
          SA5    X3+B1
          SB2    B1+B1
          SB4    A5+B1
          SB5    X5-2        NUMBER OF SYMBOLS * 2 - 2
          IX6    X4-X5
          SB3    X6 
          SB6    X1+B3
          EQ     LST2A
 LST2     LX6    X4          STORE NEW SYMBOL 
          SA6    B6 
          SA7    B6+B1
          SB6    B6+B2
 LST2A    MI     B5,LST2C    IF END OF TABLE
          SA4    B4 
          SA5    B4+B1       GET NEXT SYMBOL
          SB4    B4+B2
          SB5    B5-B2
          SB7    B3-B2
          BX7    X5+X2
 LST2B    SA3    X1+B7       CHECK FOR DUPLICATE SYMBOL 
          MI     B7,LST2     IF NOT FOUND 
          BX0    X4-X3
          SB7    B7-B2
          NZ     X0,LST2B    LOOP 
          SA7    A3+B1       REDEFINE SYMBOL
          EQ     LST2A
 LST2C    SX6    B6          REDUCE SSYMS LENGTH IF ANY 
          IX7    X6-X1       DUPLICATE SYMBOLS WERE FOUND 
          SA7    L.SSYMS
          SA1    L.MEMORY 
          SA2    O.MEMORY    REDUCE MEMORY
          SX7    B4 
          IX3    X1+X2
          IX6    X3-X7
          SA7    A2 
          SA6    A1 
          SA1    X7 
          MANAGE SYSMIC,X1
          SA4    O.MEMORY    LOAD SYSTEM MICROS 
          SA1    X4 
          IX3    X2+X3
          ZR     X1,LST3     IF LENGTH IS ZERO
          SX2    X4+B1
          IX3    X3-X1
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
 LST3     SA4    O.MEMORY    REDUCE MEMORY
          SA5    L.MEMORY 
          SA3    X4 
          SX6    X3+B1
          IX7    X4+X6
          IX6    X5-X6
          SA7    A4 
          SA6    A5 
          SA1    X7 
          MANAGE MACDEF,X1
          SA4    O.MEMORY    LOAD MACRO DEFINITION SKELETONS
          SA1    X4 
          IX3    X2+X3
          ZR     X1,LST4     IF LENGTH IS ZERO
          SX2    X4+B1
          IX3    X3-X1
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
 LST4     SA4    O.MEMORY    REDUCE MEMORY
          SA5    L.MEMORY 
          SA3    X4 
          SX6    X3+2 
          IX7    X4+X6
          IX6    X5-X6
          SA7    A4 
          SA6    A5 
          ZR     X6,LST6     IF NO SYSTEM OPCODES 
 LST5     SA1    X7          LOOK UP OPCODE 
          RJ     TLUOP
          SA4    O.MEMORY 
          SA5    X4+B1       GET EQUIVALENT 
          BX7    X5 
          AX5    57 
          SX0    X5+B1
          SA3    LSYSMAC
 +        NZ     X0,*+1      IF NOT A MACRO 
          IX7    X7+X3
 +        AX5    1
          ZR     X5,LST5C    IF NOT PSEUDO OP 
          MX0    -9 
          BX5    X7 
          AX5    36 
          BX5    -X0*X5 
          ZR     X5,LST5C    IF OLD TYPE PSEUDO OP ENTRY
          LX5    1
          SA3    X5+POPS-1   GET EQUIVALENT FROM OPS
          BX7    X3 
 LST5C    NZ     X6,LST5A    IF OPCODE FOUND IN OPTAB 
          SA1    X4 
          BX2    X7 
          RJ     ENTOP       ENTER OPCODE TABLE 
          SA4    O.MEMORY 
          EQ     LST5B
 LST5A    SA7    A2          REPLACE EQUIVALENT 
 LST5B    SA5    L.MEMORY    REDUCE MEMORY
          SX7    X4+2 
          SX6    X5-2 
          SA7    A4 
          SA6    A5 
          NZ     X6,LST5     IF MORE SYSTEM OPCODES 
  
 LST6     SA3    L.MACDEF 
          SA2    CP.LIB 
          SA1    CP.STEXT 
          BX6    X3 
          SA6    LSYSMAC
          SX7    X2+B1       BUMP SYSTEM TEXT ORDINAL 
          IX6    X1-X2
          NZ     X6,LST1     IF MORE TO LOAD
          SA6    A2 
 LST6A    SA2    CP.AFLL
          ZR     X2,LST6F    IF NO LCM
          SA1    L.SYSMIC 
          ZR     X1,LST6B    IF NO SYSTEM MICROS
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,LST6B    IF NO ROOM IN LCM
          SA3    L.SYSMIC 
          MX7    0
          IX1    X6-X1
          SA7    A3          CLEAR SCM COPY OF SYSMIC TABLE 
          LX3    30 
          BX6    X3+X1
          LX3    30          SET LCM TABLE POINTER
          SA6    LCMMIC 
          SA2    O.SYSMIC 
          RJ     WLC         WRITE SYSMIC TO LCM
 LST6B    SA1    L.SSYMS
          ZR     X1,LST6C    IF NO SYSTEM SYMBOLS 
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,LST6C    IF NO ROOM IN LCM
          SA3    L.SSYMS
          MX7    0
          IX1    X6-X1
          SA7    A3          CLEAR SCM COPY OF SSYMS TABLE
          LX3    30 
          BX6    X3+X1
          LX3    30          SET LCM TABLE POINTER
          SA6    LCMSYM 
          SA2    O.SSYMS
          RJ     WLC         WRITE SSYMS TO LCM 
 LST6C    SA1    L.OPTAB
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,LST6D    IF NO ROOM IN LCM FOR OPCODE TABLE 
          SA3    L.OPTAB
          MX7    0
          IX1    X6-X1
          SA7    A3          CLEAR SCM COPY OF OPCODE TABLE 
          LX3    30 
          BX6    X3+X1
          LX3    30          SET LCM TABLE POINTER
          SA6    LCMOPC 
          SA2    O.OPTAB
          RJ     WLC         WRITE OPTAB TO LCM 
 LST6D    SA1    LCMEND 
          BX6    X1          SAVE ORIGIN OF LCM MACROS
          SA6    LCMSYS 
          SA1    L.MACDEF 
          ZR     X1,LST6F    IF NO SYSTEM MACROS
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,LST6F    IF NO ROOM IN LCM
          SA3    L.MACDEF 
          MX7    0
          IX1    X6-X1
          SA7    A3          CLEAR SCM COPY OF MACDEF TABLE 
          LX3    30 
          BX6    X3+X1
          LX3    30          SET LCM TABLE POINTER
          SA6    LCMMAC 
          SA2    O.MACDEF 
          RJ     WLC         WRITE MACDEF TO LCM
          SA1    LCMEND 
          SA2    LCMSYS 
          BX6    X1          SAVE END OF LCM SYSTEM MACROS
          SA6    A2 
          MX7    0           INDICATE NO SYSTEM MACROS IN SCM 
          SA7    LSYSMAC
          SX0    B1 
          LX0    37          ADJUST ALL OPTAB ENTRIES FOR 
          BX2    X2+X0       SYSTEM MACROS TO POINT TO MACRO
          SA3    L.OPTAB     DEFINITION TEXT IN LCM 
          SA4    LCMOPC 
          SA1    O.OPTAB
 +        NZ     X3,*+1      IF OPCODE TABLE NOT IN LCM 
          AX4    30 
          BX3    X4 
 +        SB2    2
          SB5    57          PREPARE TO SEARCH OPCODE TABLE 
          SB6    -1 
          SB7    X3 
          SA1    X1+B1
 LST6E    AX3    X1,B5       EXTRACT OPCODE TYPE
          IX6    X1+X2
          SA1    A1+B2       FETCH NEXT ENTRY 
          SB4    X3 
          SB7    B7-B2
          NE     B4,B6,*+1   IF NOT A SYSTEM MACRO
          SA6    A1-B2       STORE ADJUSTED EQUIVALENT
          NZ     B7,LST6E    LOOP TO END OF TABLE 
          SA3    LCMOPC 
          SA2    O.OPTAB
          ZR     X3,LST6F    IF OPCODE TABLE NOT IN LCM 
          BX1    X3 
          AX3    30 
          RJ     WLC         RE-WRITE TO LCM
  
 LST6F    MX6    0           INDICATE SYSTEM TEXTS ALL LOADED 
          SA6    CP.LIB 
  
          IFNE   OVERLAY,0,2
          SA1    LSTA        RESTORE NORMAL FWA OF MANAGED TABLE AREA 
          RJ     ACL         (IF NO SPACE, GOES TO LST7A) 
  
          RJ     ASU         ACCUMULATE STORAGE USED FOR PASS 0 
          RJ     ATS         ACCUMULATE TOTAL STORAGE USED
          EQ     LST         RETURN 
  
*         ERROR EXITS.
  
 LST7     MESSAGE LSTN,,R    *SYSTEM TEXT NOT FOUND.* 
          EQ     LST9 
 LST7A    MESSAGE LSTS,,R    *INSUFFICIENT STORAGE FOR SYSTEM TEXT.*
          SA1    CP.LIB 
          NZ     X1,LST9     IF NOT AFTER LAST SYSTEM TEXT
          MESSAGE LSTT
          ABORT  ,NODUMP
 LST8     MESSAGE LSTF,,R    *IMPROPER SYSTEM TEXT FORMAT.* 
 LST9     SA1    CP.LIB 
          SA2    CP.STEXT+X1 GET OVERLAY NAME 
          SX6    2RS= 
          SX3    X2 
          BX5    X2 
          NZ     X3,LST9A    IF *G* ARGUMENT
          SA4    CP.LIB+X1
          ZR     X4,LST9B    IF NO LIBRARY NAME 
          EQ     LST9C
 LST9A    IX2    X2-X3       ISOLATE OVERLAY NAME 
          SA4    CP.LIB+X1
          BX5    X4 
          SX6    2RG= 
          NZ     X2,LST9C    IF OVERLAY NAME SPECIFIED
 LST9B    BX6    X5+X6
          SX7    B0          SETUP MESSAGE -
          LX6    -12         S=OVL  OR
          EQ     LST9E       G=FNAME
 LST9C    SA1    =8R       /
          BX6    X6+X4
          MX0    12 
          LX6    -12
 LST9D    AX0    6           SETUP MESSAGE -
          BX3    -X0*X6      S=LIB/OVL  OR
          NZ     X3,LST9D    G=FNAME/OVL
          BX3    -X0*X1 
          BX6    X6+X3
          LX7    X2 
 LST9E    SA6    LSTM+2 
          SA7    A6+B1
          MESSAGE LSTM,,R 
          MX6    0
          SA6    L.MEMORY 
          EQ     LST6 
  
 LSTA     DATA   0           STORAGE FOR (LOCORE) 
 LSTN     DATA   C* SYSTEM TEXT NOT FOUND.* 
 LSTS     DATA   C* INSUFFICIENT STORAGE FOR SYSTEM TEXT.*
 LSTF     DATA   C* IMPROPER SYSTEM TEXT FORMAT.* 
 LSTM     DATA   C*  BAD SYSTEM TEXT - S=LIBRARY/OVERLAY* 
 LSTT     DATA   C*  ASSEMBLY ABORTED.* 
 OPF      SPACE  4
**        OPF - OPEN FILES. 
  
  
 OPF      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          EVICT  R
          OPEN   S,WRITE
          REWIND S
          EQ     OPF         RETURN 
  
 RM       ELSE
  
          SA3    E
          SA4    O
          ZR     X3,OPF1     IF NO ERROR LISTING
          BX6    X3-X4
          NZ     X6,OPF0     IF NOT SAME FILE NAME AS LONG LISTING FILE 
          FETCH  O,OC,X3
          SX3    X3-#YES# 
          NZ     X3,OPF0     IF LONG LISTING FILE NOT OPEN
          CLOSEM O,N
 OPF0     OPENM  E,OUTPUT,N 
 OPF1     SA1    B
          ZR     X1,OPF3     IF NO BINARY 
          FETCH  B,OC,X2
          SB7    X2-#YES# 
          ZR     B7,OPF2     IF ALREADY OPEN
          OPENM  B,OUTPUT,N 
 OPF2     FETCH  B,RT,X3
          SX7    X3-#WT#
          SA7    B-1         SAVE BINARY RECORD TYPE
 OPF3     OPENM  OPFA,I-O,N  RETURN SCRATCH FILES 
          CLOSEM OPFA,U 
          OPENM  OPFB,I-O,N 
          CLOSEM OPFB,U 
          EQ     OPF         RETURN 
  
 OPFA     FILE   LFN=ZZZZZRL,FET=SCR
 OPFB     FILE   LFN=ZZZZZRM,FET=REF
  
 RM       ENDIF 
 RDD      SPACE  4
**        RDD - READ DEBUGGING DIRECTIVES.
*         READ CARDS FROM FILE *PATCHES* AND COPY THEM
*         TO FILE *SNAPPER* IN LISTABLE FORM. 
*         *PATCH CARDS ARE PROCESSED DIRECTLY.
*         *SNAP CARDS CAUSE CONSTRUCTION OF SNAP DESCRIPTOR 
*         ENTRIES IN THE *SNAPBUF* TABLE AREA.
*         ALL OTHER CARDS ARE TREATED AS COMMENTS.
  
  
 DEBUG    IFNE   DEBUG,0
          QUAL   DEBUG
  
 RDD      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          REWIND P
          READ   P           START READING
          READC  P,LINE+1,9  READ FIRST CARD
          NZ     X1,RDDX     IF NONE
          SA0    B6 
          WRITEW D,DHEAD,LDHEAD    WRITE HEADER LINE
          SB6    A0 
 RDDC     SB5    B6-LINE-1   LENGTH OF CARD 
  
 RM       ELSE
  
          OPENM  P,INPUT,N
          REWINDM P 
          GET    P,LINE+1,90
          FETCH  P,FP,X2
          SX0    EOD
          BX3    X0*X2
          NZ     X3,RDDX     IF NO DATA IN PATCHES FILE 
          OPENM  D,I-O,N
          PUT    D,DHEAD,LDHEAD 
          PUT    D,DHEAD1,10
 RDDC     FETCH  P,RL,X3     RECORD LENGTH
          SX2    X3+9 
          SX1    52429
          IX4    X1*X2
          AX4    19          RL/10
          SB5    X4 
  
 RM       ENDIF 
  
          SB7    8
 +        SB6    B1 
          GE     B5,B7,*+1   IF MORE THAN 8 WORDS 
          SB7    B5 
          SA1    LINE+1      CARD COLUMNS 1-10
          SA2    SNAPC
          SA3    A2+B1
          IX2    X1-X2
          BX3    X1-X3
          ZR     X2,RDDD     IF *SNAP 
          NZ     X3,RDDW     IF NOT *PATCH
 RDDD     MX0    -6 
          SB4    10          GET FIRST NUMBER, STARTING IN COLUMN 11
          SA1    A1+B1
          SX4    B0 
          RJ     SCAN 
          NZ     X3,RDDS     IF *SNAP 
          SA0    X6 
          RJ     SCAN        GET NEW VALUE
          SA6    A0          STORE IT 
          EQ     RDDW 
 RDDS     SA2    LSNAPBUF 
          SA3    RJSNAP 
          SA5    X6          FETCH INSTRUCTION WORD 
          IX7    X3+X2
          BX6    X5          REPLACE WITH RJ SNAPPER
          SA7    A5 
          SX7    X2+B1
          SA6    X2+SNAPBUF  SAVE REPLACED INSTRUCTION WORD 
          SA7    A2 
 RDDT     SX4    B1 
          RJ     SCAN        GET FWA
          MI     X7,RDDU     IF TABLE NAME
          MX2    -17
          BX6    -X2*X6 
          IX5    X6+X7
          LX5    30 
          RJ     SCAN        GET WORD COUNT 
          MX2    -17
          BX6    -X2*X6 
          IX6    X6+X7
          IX6    X6+X5
 RDDU     LT     B6,B7,*+1   IF NOT END OF CARD 
          MX2    1
          BX6    X6+X2
          SA2    LSNAPBUF 
          SA6    X2+SNAPBUF  STORE SNAP DESCRIPTION 
          SX7    X2+B1
          SA7    A2 
          LT     B6,B7,RDDT  IF NOT END OF CARD 
  
 RM       IFEQ   CP#RM,0
  
 RDDW     WRITEW D,LINE,B5+B1 
          READC  P,LINE+1,9  READ NEXT CARD 
          ZR     X1,RDDC     IF NOT EOR/EOF 
          WRITER D,RECALL    FLUSH BUFFER 
 RDDX     BSS    0
  
 RM       ELSE
  
 RDDW     FETCH  P,RL,X3
          SX4    X3+10
          PUT    D,LINE,X4
          GET    P,LINE+1,90
          FETCH  P,FP,X2
          SX0    EOD
          BX3    X0*X2
          ZR     X3,RDDC     IF NOT END OF DATA 
          WEOR   D           FLUSH D
 RDDX     CLOSEM P,R
  
 RM       ENDIF 
  
          EQ     RDD
 SCAN     SPACE  4
**        SCAN - READ ONE OCTAL NUMBER OR TABLE NAME FROM DEBUG CARD. 
*         STOPPED BY , OR . OR END OF CARD IMAGE. 
*         ENTRY  (X0) = -77B. 
*                (X1) = CURRENT WORD OF CARD IMAGE. 
*                (A1) = ADDRESS OF (X1).
*                (B4) = NUMBER OF CHARACTERS REMAINING IN (X1). 
*                (B6) = WORD NUMBER.
*                (B7) = WORD COUNT OF CARD IMAGE. 
*                (X4) = 0 TO DISALLOW TABLE NAME AND IGNORE ALL 
*                         CHARACTERS OTHER THAN * , . AND 0-7.
*                     = 1 TO ALLOW TABLE NAME.
*         EXIT   (X0), (B7) UNCHANGED.
*                (X1), (A1), (B4), (B6) UPDATED.
*                (B6) = (B7) IF . OR END OF CARD IMAGE ENCOUNTERED. 
*                (X6) = NUMBER SCANNED, OR
*                     = 13/1, 17/O.XXX, 13/1, 17/L.XXX
*                       IF TABLE NAME XXX SCANNED.
*                (X7) = -1 IF A TABLE NAME SCANNED, 
*                     = 1000000B IF A $ SCANNED,
*                     = 0400000B IF AN * SCANNED, OR
*                     = 0 IF NONE OF THE ABOVE. 
  
  
 SCAN     PS                 RETURN EXIT
          MX6    0
          SX7    B0 
          GE     B6,B7,SCAN  IF CARD EXHAUSTED
 SCAN0    NZ     B4,SCAN1    IF WORD NOT EXHAUSTED
          SB6    B6+B1
          SA1    A1+B1
          SB4    10 
          GE     B6,B7,SCAN  IF CARD EXHAUSTED
 SCAN1    LX1    6
          SB4    B4-B1
          BX2    -X0*X1 
          SX2    X2-1R0 
          SB3    X2-8 
          MI     X2,SCAN4    IF COLON OR A-Z
          PL     B3,SCAN2    IF NOT 0-7 
          LX6    3
          SX4    0
          IX6    X6+X2
          EQ     SCAN0
 SCAN2    SB2    X2+1R0-1R* 
          SB3    X2+1R0-1R, 
          SB5    X2+1R0-1R$ 
          NZ     B2,SCAN2A   IF NOT ASTERISK (INDIRECT) 
          SX2    B1 
          LX2    17 
          BX7    X7+X2
 SCAN2A   NZ     B5,SCAN3    IF NOT DOLLAR (ECS/LCM)
          SX2    B1 
          LX2    18 
          BX7    X7+X2
 SCAN3    ZR     B3,SCAN     IF COMMA, RETURN 
          NE     B3,B1,SCAN0 IF NOT PERIOD
          SB6    B7          SET END OF CARD
          EQ     SCAN 
 SCAN4    ZR     X4,SCAN0    IF TABLE NAME NOT ALLOWED
          SB2    60 
          SX2    X2+1R0      RESTORE CHARACTER
          ZR     X2,SCAN6    IF COLON 
 SCAN5    SB2    B2-6 
          LX2    B2          APPEND CHARACTER TO NAME 
          BX6    X6+X2
 SCAN6    NZ     B4,SCAN7    IF WORD NOT EXHAUSTED
          SB6    B6+B1
          SA1    A1+B1       FETCH NEXT WORD
          SB4    10 
          GE     B6,B7,SCAN8 IF CARD EXHAUSTED
 SCAN7    LX1    6
          SB4    B4-B1
          BX2    -X0*X1      EXTRACT NEXT CHARACTER 
          SB3    X2-1R, 
          ZR     X2,SCAN6    IF COLON 
          ZR     B3,SCAN8    IF COMMA 
          NE     B3,B1,SCAN5 IF NOT PERIOD
          SB6    B7          SET END OF CARD
 SCAN8    SA2    TABLES      SEARCH LIST OF TABLES
          MX3    -18
 SCAN9    ZR     X2,SCAN+1   IF NOT FOUND, IGNORE FIELD 
          BX4    X3*X2
          SB3    X2          TABLE NUMBER 
          IX7    X6-X4
          SA2    A2+B1
          NZ     X7,SCAN9    LOOP 
          SX3    B1 
          SX4    ORIGINS+B3 
          LX3    17 
          BX4    X4+X3       SETUP (X6) FOR TABLE 
          SX6    SIZES+B3 
          LX4    30 
          BX6    X6+X3
          SX7    -B1         (X7) = -1
          BX6    X4+X6
          EQ     SCAN        RETURN 
 DATA     SPACE  4
**        CONSTANTS AND WORKING STORAGE FOR *RDD*.
  
  
 RJSNAP   RJ     SNAPPER
 -        VFD    30/**
  
 RM       IFEQ   CP#RM,0
 DHEAD    DATA   C*1     COMPASS DEBUGGING OUTPUT.*,8L0 
 LDHEAD   EQU    *-DHEAD
 RM       ELSE
 DHEAD    DATA   H*1     COMPASS DEBUGGING OUTPUT.* 
 LDH      SET    *-DHEAD
 LDHEAD   EQU    LDH*10 
 DHEAD1   DATA   1H0
 RM       ENDIF 
  
 LINE     DATA   10H
          BSS    9           DIRECTIVE CARD IMAGE 
  
 SNAPC    DATA   H *SNAP ,H *PATCH
  
 TABLES   BSS    0
 DEBUG    HERE               LIST OF TABLE NAMES AND NUMBERS
          CON    0
  
 LSNAPBUF DATA   0           LENGTH OF SNAPBUF
  
 PSD      FET    PATCHES,,BBUFL,1 
  
 RM       IFEQ   CP#RM,0
 P        EQU    PSD
 RM       ELSE
          IFEQ   CP#RM,6,1
 P        FILE   LFN=PATCHES,FO=SQ,BT=C,RT=Z,MRL=90,CM=YES,LT=UL,FET=PSD
,,BFS=BBUFL,ERL=1 
          IFEQ   CP#RM,7,1
 P        FILE   LFN=PATCHES,FO=SQ,BT=,RT=W,MRL=90,PD=INPUT 
          BSSZ   PSD+40B-*
 RM       ENDIF 
  
          QUAL   *
 DEBUG    ENDIF 
 SBA      SPACE  4
**        SBA - SET BUFFER ADDRESS. 
*         ENTRY  (X0) = BUFFER FIRST WORD ADDRESS.
*                (X1) = FET/FIT ADDRESS.
*         EXIT   (X0) = BUFFER LAST WORD ADDRESS + 1. 
  
  
 SBA      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          SA4    X1+B1       READ FIRST 
          BX6    X4+X0
          LX7    X0 
          SA6    X1+B1       SET FIRST
          SA7    A6+B1       SET IN 
          SA7    A7+B1       SET OUT
          SA2    A7+B1       READ LIMIT 
          IX6    X7+X2
          SA6    A7+B1       SET LIMIT
          IX0    X0+X2
  
 RM       ELSE
 RM       IFEQ   CP#RM,6
  
          STORE  X1,FWB=X0   SET FWA BUFFER 
          FETCH  X1,BFS,X2   READ BUFFER SIZE 
          IX0    X0+X2
  
 RM       ENDIF 
  
          EQ     SBA         RETURN 
 SCS      SPACE  4,10                                                    F4810B 
**        SCS - SAVE COMPILER SPACE.                                     F4810B 
*         SAVES THE CONTENTS OF THE CELLS CP.NFLS AND CP.AFLS AND THE    F4810B 
*         SPACE INCLUDED BETWEEN THE TWO ADDRESSES CONTAINED IN THESE    F4810B 
*         CELLS WHEN COMPASS IS  CALLED BY A COMPILER.                   F4810B 
                                                                         F4810B 
                                                                         F4810B 
 SCS      PS                 RETURN EXIT                                 F4810B 
          SA2    CP.BATCH                                                F4810B 
          LX2    59-11                                                   F4810B 
          PL     X2,SCS      IF COMPASS NOT CALLED BY A COMPILER, RETURN F4810B 
          SA2    CP.NFLS     FL AVAILABLE TO COMPASS                     F4810B 
          SA3    LOCORE      SPACE NOT AVAILABLE TO TABLES               F4810B 
          SX6    X2-10                                                   F4810B 
          IX6    X6-X3                                                   F4810B 
          SA6    SIZCORE     TABLE SPACE = CP.NFLS-LOCORE-10(SLOP)       F4810B 
          SA3    CP.AFLS     ACTUAL FL                                   F4810B 
          IX1    X3-X2                                                   F4810B 
          SX1    B1+X1       ELSE, ADD 1 WORD TO GET WORD COUNT TO SAVE  F4810B 
          LX2    30-0                                                    F4810B 
          BX6    X2+X3                                                   F4810B 
          SA6    SCSFL       TEMP. SAVE COMPILER CP.NFLS AND CP.AFLS     F4810B 
          MANAGE CMPTAB,X1   REQUEST TABLE SPACE                         F4810B 
          SA4    SCSFL       GET SAVED COMPILER FIELD LENGTHS            F4810B 
          BX6    X4                                                      F4810B 
          SA6    X2          STORE IN FIRST WORD OF CMPTAB               F4810B 
          SB3    X4          CP.AFLS                                     F4810B 
          AX4    30-0                                                    F4810B 
          SB4    X4          CP.NFLS-FWA OF AREA TO BE SAVED             F4810B 
 SCS1     GE     B4,B3,SCS   IF THROUGH, RETURN                          F4810B 
          SX2    X2+B1       DESTINATION OF WORD TO BE MOVED             F4810B 
          SA1    B4          CURRENT WORD TO BE MOVED                    F4810B 
          BX6    X1                                                      F4810B 
          SA6    X2                                                      F4810B 
          SB4    B4+B1       INCREMENT SOURCE ADDRESS                    F4810B 
          EQ     SCS1        CONTINUE                                    F4810B 
                                                                         F4810B 
 SCSFL    DATA   0           TEMP. STORES COMPILER CP.NFLS AND CP.AFLS   F4810B 
 SFL      SPACE  4
**        SFL - SET FIELD LENGTH. 
  
  
 SFL      PS                 RETURN EXIT
 SFL0     BSS    0                                                       F4810B 
          SA1    CP.NFLS
          SA2    LOCORE 
          SX6    X1-10       ALLOW TEN WORDS FOR SLOP 
          IX7    X6-X2
          SB7    X7-NOPCT*2-NSYMT*2 
          SA6    O.ENDTAB    SAVE END OF MANAGED TABLE AREA 
          SA7    SIZCORE
          PL     B7,SFL1     IF ENOUGH ROOM 
          BX6    X1          SAVE CURRENT FL                             F4810B 
          SX5    X2+NOPCT*2+NSYMT*2+10D+77B  FL REQUIRED                 F4810B 
          BX1    -X5                                                     F4810B 
          RJ     RFL         REQUEST THE REQUIRED FIELD LENGTH           F4810B 
          NZ     X3,SFL0     IF REQUEST COMPLETE, TRY AGAIN              F4810B 
          BX1    X5          ELSE, PRINT MESSAGE AND ABORT               F4810B 
          MX0    -6 
          BX1    X0*X1
          RJ     COCT        CONVERT TO OCTAL 
          SA1    SFLA+2 
          MX0    30 
          BX1    X0*X1       INSERT REQUIRED FIELD LENGTH INTO MESSAGE
          BX6    -X0*X6 
          BX6    X1+X6
          SA6    A1 
          MESSAGE SFLA,,R 
          ABORT  ,NODUMP
  
 SFL1     BSS    0
 LCM      IFEQ   CP#RM,7
          MEMORY LCM,SFLB,R  GET LCM FIELD LENGTH AND MODE
          SA1    SFLB 
          LX1    59-1 
          SX6    B0 
          PL     X1,SFL2     IF NOT REDUCE MODE FOR LCM FIELD LENGTH
          SA6    FLLF        CLEAR FIXED FLL FLAG 
          SA2    CP.STEXT 
          SA3    CP.LIB      CHECK FOR SYSTEM TEXTS TO BE LOADED
          LX1    1-59 
          AX1    30          CURRENT LCM FIELD LENGTH 
          IX2    X2+X3
          SX6    20000B 
 +        NZ     X2,*+1      IF NOT *S=0* 
          SX6    10000B 
 +        IX2    X1-X6
          PL     X2,SFL2     IF ENOUGH ROOM 
          LX6    30 
          SA6    SFLB 
          MEMORY LCM,SFLB,R  REQUEST MORE LCM FIELD LENGTH
          SA1    SFLB 
          AX1    30 
          BX6    X1          UPDATE ACTUAL FIELD LENGTH 
          SA6    CP.AFLL
 LCM      ENDIF 
  
 SFL2     BSS    0
 OVL      IFNE   OVERLAY,0
          SA1    RA.LWP      INITIALIZE SUBROUTINE *OVL*
          SA2    CP.BATCH 
          LX1    59-18
          LX2    59-11
          BX1    X1+X2
          MI     X1,SFL3     IF LOADED FROM A LIBRARY OR CALLED BY
          SA1    RA.PGN      A COMPILER 
          MX0    42 
          BX6    X0*X1       STORE FILE NAME IN LOADER CALL 
          SA6    OVLY 
          SX7    2040B       THREE-WORD CALL, LOAD OVERLAY FROM FILE
          LX7    36 
          SA7    A6+B1
 OVL      ENDIF 
  
 SFL3     JP     SFL         RETURN 
  
 SFLA     DATA   C*  COMPASS NEEDS AT LEAST 00000B SCM.*
 SFLB     DATA   0
 SFP      SPACE  4
**        SFP - SET FILE PARAMETERS.
  
  
 SFP      PS                 RETURN EXIT
  
          IFNE   CP#RM,0,1
          STORE  I,DX=0 
  
          SA3    E
          BX6    X3 
          SA6    FTNE        SAVE CONTENTS OF E FET FOR FTN'S SAKE. 
          SA4    CP.LISTF 
          SX0    BUFFERS
          ZR     X3,SFP2     IF NO ERROR FILE 
          ZR     X4,SFP1     IF NO LONG LISTING WANTED
          SA4    O
          MX6    42 
          BX5    X3-X4       COMPARE ERROR AND MAIN LISTING FILE NAMES
          BX6    X6*X5
          NZ     X6,SFP1     IF NOT SAME FILE 
          SA6    A3          CLEAR ERROR FILE 
          EQ     SFP2 
 SFP1     BSS    0
  
          IFEQ   CP#RM,0,1
          SA2    E+2
          SX1    A3 
          NZ     X2,SFP2     IF BUFFERS HAVE BEEN SWITCHED
          SA4    E+4
          BX6    X4 
          SA6    FTNE+1      SAVE EBUFL 
          RJ     SBA         SET ERROR BUFFER ADDRESS 
 SFP2     SA3    CP.LISTF 
          SX1    R
          ZR     X3,SFP3     IF NO LISTING
          RJ     SBA         SET CROSS REFERENCE BUFFER ADDRESS 
 SFP3     SX1    S
          RJ     SBA         SET SCRATCH BUFFER ADDRESS 
  
          IFNE   DEBUG,0,2
          SX1    D
          RJ     SBA         SET SNAPPER BUFFER ADDRESS 
  
 B        IFEQ   CP#RM,0
          SA1    B+1         CHANGE *FET LGO,OBUF,OBUFL,7*
          SX7    BBUFL       TO     *FET LGO,,BBUFL,7*
          SX2    X1          FOR SBA
          BX6    X1-X2
          SA7    B+4         LIMIT = BBUFL
          SA6    A1          FIRST = 0
 B        ENDIF 
  
          SX1    B
          SX3    X0 
          RJ     SBA         SET BINARY BUFFER ADDRESS
  
          IFEQ   CP#RM,0,2
          SX1    X
          ELSE   1
          SX1    /PASS1/XDUM
  
          SX0    X3          BINARY BUFFER ADDRESS
          RJ     SBA         SET XTEXT BUFFER ADDRESS 
  
          IFNE   DEBUG,0,3
          SX0    X3 
          SX1    /DEBUG/P 
          RJ     SBA         SET PATCHES BUFFER ADDRESS 
  
          BX1    X0 
          RJ     ACL         ADJUST CORE LIMITS 
  
          EQ     SFP         RETURN 
 SLF      SPACE  4,10 
**        SLF - SET LIST FLAGS. 
*         EXIT TO ARGE ON BAD *LO* ARGUMENT.
  
  
 SLF      PS                 RETURN EXIT
          SA1    SLFA 
          SA3    ABTF 
          SA4    CP.ABORT 
          BX6    X1 
          LX1    18 
          SA6    XLIST
          BX7    X3+X4
          SA7    A4 
          SX7    B1 
          MX0    -6 
          SX6    X1-1L0 
          SB2    B1+B1
          LX1    -18
          NZ    X6,SLF1      IF NOT *LO=0*
          MX1    0
          SA6    A6 
 SLF1     ZR     X1,SLF      IF NO LIST FLAGS 
          LX1    6
          BX2    -X0*X1 
          SB7    X2 
          IX1    X1-X2
          SB6    B7-1R$ 
          SA3    LISTOPS     CHECK LIST OPTION TABLE
          SB5    LLISTOPS 
          ZR     B6,SLF4     IF $ 
 SLF2     UX6    B6,X3
          SB5    B5-B2
          EQ     B6,B7,SLF3  IF OPTION FOUND
          SA3    A3+B2
          NZ     B5,SLF2     LOOP 
          SX6    2RLO 
          LX6    -12
          SA6    ARGM+3      *BAD CONTROL CARD ARGUMENT - LO* 
          EQ     ARGE 
 SLF3     BX6    X3-X7       TOGGLE LIST FLAG 
          SA6    A3 
          EQ     SLF1        LOOP TO END OF FLAGS 
  
 SLF4     BX6    X3+X7       $ FOUND, TURN ON ALL LIST FLAGS
          SA6    A3 
          SB5    B5-B2
          SA3    A3+B2
          NZ     B5,SLF4     LOOP 
          EQ     SLF1 
 SMP      SPACE  4,10                                                    F4810B 
**        SMP - SET UP MEMORY REQUEST PARAMETERS                         F4810B 
*         OBTAINS THE MAXIMUM FL. AVAILABLE TO THE JOB. 
*         DETERMINES WHETHER THE FL. AT WHICH TABLES ARE TO BE DUMPED 
*         TO FILES (MIDFLN) IS VALID.  THIS IS DONE BY CHECKING THE 
*         CURRENT FL. TO SEE WHETHER IT IS LARGER THAN MIDFLN.  IF IT 
*         IS, COMPASS ASSUMES THAT THE PRESENT JOB STEP WAS PRECEEDED 
*         BY AN RFL STATEMENT AND SETS MIDFLN TO THE CURRENT FL ROUNDED 
*         UP FOR SPEED (TABLES NOT DUMPED TO FILES).  IF CP.NFLS IS LESS
*         THAN MIDFLN, COMPASS JUST INSURES THAT MIDFLN IS LESS THAN
*         MAXFL.
                                                                         F4810B 
                                                                         F4810B 
 SMP      PS                 RETURN EXIT                                 F4810B 
          MEMORY CM,MAXFL,RECALL  GET MAXIMUM JOB FL                     F4810B 
          SA1    MAXFL       GET RETURNED MAXIMUM FL                     F4810B 
          AX1    30-0        SHIFT INTO LOWER 30 BITS                    F4810B 
          BX6    X1                                                      F4810B 
          SA6    A1          STORE MAXIMUM FL                            F4810B 
          SX1    4           K                                           F4810B 
          SX2    FLINC       GET FL INCREMENT                            F4810B 
          IX2    X1*X2       K*FLINC                                     F4810B 
          SA1    MAXFL       GET MAX JOB FL                              F4810B 
          IX2    X1-X2       MAXFL-K*FLINC                               F4810B 
          SA1    MIDFLN      GET FL AT WHICH TABLES DUMPED TO FILES      F4810B 
          SA3    CP.NFLS     GET CURRENT FL 
          IX4    X1-X3
          PL     X4,SMP1     IF NO RFL OR RFL.LE.MIDFLN 
          MX4    -6          ELSE SET MIDFLN TO CURRENT FL
          IX6    X3-X4       CP.NFLS+77B
          BX6    X6*X4
          SA6    MIDFLN      STORE NEW VALUE OF MIDFLN
          EQ     SMP         RETURN 
  
 SMP1     BSS    0
          IX6    X2-X1       (MAXFL-K*FLINC)-MIDFLN                      F4810B 
          PL     X6,SMP      IF MIDFLN.LE.(MAXFL-K*FLINC)                F4810B 
          BX6    X2          ELSE, RESET MIDFLN TO MAXFL-K*FLINC         F4810B 
          SA6    MIDFLN                                                  F4810B 
          EQ     SMP         RETURN                                      F4810B 
 SPF      SPACE  4,10                                                    F4810A 
**        SPF - SET PRINTER FLAGS.                                       F4810A 
                                                                         F4810A 
                                                                         F4810A 
 SPF      PS                 RETURN EXIT                                 F4810A 
          SA2    CP.BATCH 
          LX2    59-11
          MX0    6
          PL     X2,SPF2     IF COMPASS WAS NOT CALLED BY COMPILER
          SA1    CP.PS       GET COMPILER PAGE SIZE 
          SA2    CP.PD       GET COMPILER PRINT DENSITY 
          BX6    X2 
          SA3    CP.PW       GET COMPILER PRINT WIDTH 
          SA6    COMPPD      SAVE COMPILER PRINT DENSITY
          LX7    X3 
          BX6    X1 
          SA7    COMPPW      SAVE COMPILER PRINT WIDTH
          SA6    COMPPS      SAVE COMPILER PAGE SIZE
          BX7    -X1         FTN PASSES COMPLIMENT OF PAGE SIZE 
          SA3    SPFB+1      8LPI 
          SX6    6D          PRESET 6LPI
          BX3    X0*X3
          BX2    X0*X2
          IX3    X3-X2
          NZ     X3,SPF1     IF 6LPI
          SX6    8D          8LPI 
 SPF1     SA6    CP.PD       STORE NUMERICAL VALUE FOR PRINT DENSITY
          SA7    CP.PS       STORE PAGE SIZE FROM COMPILER
  
 SPF2     GETPAGE SPFA       GET CURRENT JOB/SYSTEM PAGE SIZE 
          SA1    SPFA        GET JOB VALUES 
          MX3    -8          *PS* FIELD WIDTH 
          AX1    12          POSITION FOR *PW*
          SA2    CP.PW
          BX6    -X3*X1 
          NZ     X2,SPF3     IF *PW* SPECIFIED
          SA6    A2 
 SPF3     AX1    8           POSITION FOR *PS*
          SA2    CP.PS
          BX6    -X3*X1 
          NZ     X2,SPF4     IF *PS* SPECIFIED
          SA6    A2 
 SPF4     AX1    8           POSITION FOR *PD*
          MX3    -4 
          SA2    CP.PD
          BX6    -X3*X1 
          NZ     X2,SPF5     IF *PD* SPECIFIED
          SA6    A2 
 SPF5     AX6    1           DIVIDE BY 2
          SA2    A2          GET CURRENT *PD* 
          AX2    1
          SA4    SPFB-3+X2
          BX7    X4 
          SA7    FRSTLIN     SET INITIAL *PD* (ALWAYS)
          IX7    X6-X2
          ZR     X7,SPF6     IF CC *PD* AND JOB *PD* ARE EQUAL
          SA3    SPFB-3+X6   GET JOB DEFAULT *PD* 
          BX7    X3 
 SPF6     SA7    LASTLIN     SET EXIT *PD* (=0 IF NO CHANGE)
          SA1    CP.PS       GET CURRENT *PS* 
          SX4    X1-4D
          SX7    4           PRESET MIN = 4D
          NG     X4,SPF7     IF *PS* .LT. 4 - USE MIN = 4 
          SX4    X1-100D
          NG     X4,SPF8     IF 4.LE.PS.LT.100
          SX7    99D         SET MAX = 99D
 SPF7     SA7    CP.PS
          MESSAGE ARGA,,R    DIAGNOSE PAGE SIZE ADJUSTED
 SPF8     SA1    CP.PS
          SA2    NEJF 
          ZR     X2,SPF9     IF *N* NOT SPECIFIED 
          IX6    X1+X2
          SA6    A2 
 SPF9     SA2    CP.BLF 
          ZR     X2,SPF10    IF *BL* NOT SPECIFIED
          SX2    X1+5        ELSE, BL CONTROLLED PAGE SIZE = CP.PS+5
 SPF10    BX6    X2 
          SA6    PSIZE
          EQ     SPF
  
 SPFA     BSSZ   2           GETPAGE RETURN DATA
 SPFB     DATA   10HS   6LPI
          DATA   10HT   8LPI
  
                                                                         F4810A 
 ZLC      SPACE  4
**        ZLC - ZERO FIRST 100B WORDS OF LCM FIELD LENGTH, IF ANY.
*         THIS AREA IS USED BY *CLS* FOR RAPID CLEARING OF SCM AREAS. 
  
  
 ZLC      PS                 RETURN EXIT
          SA1    CP.AFLL
          ZR     X1,ZLC      IF NO LCM FIELD LENGTH 
          MX1    0
          SX2    ZLCA 
          SX3    100B 
          RJ     WLC         WRITE LCM
          EQ     ZLC         RETURN 
  
 ZLCA     BSSZ   100B 
 OPTS     SPACE  4,10                                                    F4810A 
**        OPTS - TABLE OF CONTROL CARD OPTIONS.                          F4810A 
*                                                                        F4810A 
*         BITS   CONTENTS                                                F4810A 
*         59-48  ARGUMENT                                                F4810A 
*         47-30  IF LT 0, -ADDRESS OF DEFAULT, = NOT ALLOWED.            F4810A 
*                IF GT 0,  ADDRESS OF DEFAULT, = ALLOWED.                F4810A 
*         29     MULTIPLE OCCURRANCES ALLOWED 
*         28     OPTION ENCOUNTERED 
*         27-00  IF LT 0, -ADDRESS OF SPECIAL PROCESSOR.
*                IF GT 0,  ADDRESS OF FLAG TO BE SET.                    F4810A 
                                                                         F4810A 
                                                                         F4810A 
 OPT      BSS    0                                                       F4810A 
          VFD    12/0LA,18/-OPTA,30/ABTF
          VFD    12/0LB,18/OPTB,30/B
          VFD   12/0LBL,18/OPTBL,30/CP.BLF
          VFD    12/0LD,18/-OPTD,30/CP.ERRCT
          VFD    12/0LE,18/OPTE,2/0,28/-ARG7A 
          VFD    12/0LF,18/OPTF,30/FVAL 
          VFD    12/0LG,18/OPTG,1/1,1/0,28/-ARG8
          VFD    12/0LI,18/OPTI,30/I
          VFD    12/0LL,18/OPTL,30/O
          VFD    12/0LLO,18/OPTLO,2/0,28/-ARG15 
          VFD    12/0LML,18/OPTML,2/0,28/-ARG14 
          VFD    12/0LN,18/-OPTN,30/NEJF
          VFD    12/0LO,18/OPTO,2/0,28/-ARG7A 
          VFD    12/0LP,18/-OPTP,30/CP.PAGE 
          VFD    12/0LPC,18/BLANKS,2/0,28/-ARG19
          VFD    12/0LS,18/OPTS,1/1,1/0,28/-ARG10 
          IFNE   SPY,0,1
          VFD    12/0LW,18/OPTW,30/SPYPAR 
          VFD    12/0LX,18/OPTX,30/CP.XNAME 
          VFD    12/0LPD,18/CP.PD,2/0,28/-ARG24 
          VFD    12/0LPS,18/CP.PS,2/0,28/-ARG26 
 LOPT     EQU    *-OPT                                                   F4810A 
                                                                         F4810A 
                                                                         F4810A 
 OPTA     DATA   1S29                                                    F4810A 
 OPTB     DATA   0LLGO                                                   F4810A 
 OPTBL    DATA   1
 OPTD     DATA   1BS59                                                   F4810A 
 OPTE     DATA   0LERRS 
 OPTF     DATA   0LCOMPASS                                               F4810A 
 OPTG     DATA   0LSYSTEXT                                               F4810A 
 OPTI     DATA   0LCOMPILE                                               F4810A 
 OPTL     DATA   0LOUTPUT                                                F4810A 
 OPTLO    DATA   0LCFGX                                                  F4810A 
 OPTML    DATA   0L"JDATE"                                               F4810A 
 OPTN     DATA   0                                                       F4810A 
 OPTO     DATA   0LOUTPUT                                                F4810A 
 OPTP     DATA   0                                                       F4810A 
 OPTS     DATA   0LSYSTEXT                                               F4810A 
 OPTW     DATA   0L100                                                   F4810A 
 OPTX     DATA   0LOPL                                                   F4810A 
                                                                         F4810A 
                                                                         F4810A 
 ABTF     DATA   0                                                       F4810A 
 ELFN     DATA   0LOUTPUT                                                F4810A 
 ERFFLG   DATA   0           RESET TO 1 WHEN O OR E PARAMETER FOUND 
 FVAL     DATA   0                                                       F4810A 
 ARGA     DATA   C* PAGE SIZE RANGE 4 - 99.*
 ARGL     DATA   10H                                                     F4810A 
 ARGM     DIS    ,*  BAD CONTROL CARD ARGUMENT - XXXXXXX*                F4810A 
 ARGN     DIS    ,*  MORE THAN 7 SYSTEM TEXTS SPECIFIED.*                F4810A 
 ARGQ     CON    0REXECUTE                                               F4810A 
*                  +   -   *   /   (    )   $   =   BL   ,    .          F4810A 
 GACA     VFD    4/1,4/1,4/0,4/2,4/1,4/-1,4/0,4/3,4/-0,4/1,4/-1,16/0     F4810A 
 GACB     CON    0           STORAGE FOR SAVING (X6)                     F4810A 
 GACC     CON    0           STATUS WORD FOR CONTRLC                     F4810A 
 GACD     CON    40404040404040404040B                                   F4810A 
 GACE     DATA   C* NO CONTROL CARD TERMINATOR.*                         F4810A 
 GACF     DATA   10H                                                     F4810A 
 FNAME    DATA   0LCOMPASS   0   TABLE OF NAMES FOR *F* PARAMETER        F4810A 
          DATA   0LRUN       1                                           F4810A 
          DATA   0LFTN4     2 
          DATA   0LFTN5     3 
 NFNAME   EQU    *-FNAME                                                 F4810A 
 SLFA     DATA   0           LIST FLAG TEMPORARY                         F4810A 
 DMF      EJECT 
 CLFN     MACRO  F1,F2
          LOCAL  EXIT 
          SA1    F1 
          SA2    F2 
          ZR     X1,EXIT
          ZR     X2,EXIT
          BX1    X1-X2
          ZR     X1,ARGF
 EXIT     BSS    0
 CLFN     ENDM
          SPACE  4
**        DMF - DIAGNOSE MISUSED FILES.  DIAGNOSES SAME FILE
*         DECLARED FOR LIST/INPUT/BINARY/XTEXT COMBINATION. 
* 
*         ENTRY  NONE 
*         EXIT   NONE 
*         USES   A1,A2,X1,X2
  
 DMF      PS
          CLFN   O,B
          CLFN   O,CP.XNAME 
          CLFN   O,I
          CLFN   B,CP.XNAME 
          CLFN   B,I
          CLFN   B,ELFN 
          CLFN   CP.XNAME,I 
          CLFN   CP.XNAME,ELFN
          EQ     DMF
  
 ARGF     MESSAGE ARGLFN,,R 
          ABORT  ,NODUMP
  
 ARGLFN   DIS    ,*FILE USE CONTRADICTION*
 OPS      EJECT 
**        OPCODE TABLE PROTOTYPE. 
  
  
          USE    OPCODES
          SEG    OPCODE TABLE PROTOTYPE.
          BASE   MIXED
 CPOP     SPACE  4
**        FIELD DEFINITIONS FOR CENTRAL PROCESSOR OPERATIONS. 
  
  
 Q        MICRO  1,,*001* 
 A        MICRO  1,,*040* 
 AQ       MICRO  1,,*041* 
 B        MICRO  1,,*100* 
 BQ       MICRO  1,,*101* 
 X        MICRO  1,,*140* 
 XQ       MICRO  1,,*141* 
 -B       MICRO  1,,*300* 
 -X       MICRO  1,,*340* 
 X+B      MICRO  1,,*144* 
 B+X      MICRO  1,,*106* 
 A+B      MICRO  1,,*044* 
 B+A      MICRO  1,,*102* 
 A-B      MICRO  1,,*054* 
 B+B      MICRO  1,,*104* 
 B-B      MICRO  1,,*114* 
 -B+A     MICRO  1,,*302* 
 -B+B     MICRO  1,,*304* 
 X+X      MICRO  1,,*146* 
 X-X      MICRO  1,,*156* 
 X*X      MICRO  1,,*166* 
 X/X      MICRO  1,,*176* 
 -X+X     MICRO  1,,*346* 
 -X-X     MICRO  1,,*356* 
 -X*X     MICRO  1,,*366* 
 CPOPA    SPACE  4
**        CPOPA - REMOVE ONE LEVEL OF MICRO.
*         CPOPA  P1 
*         ENTRY  (P1) = MICRO NAME. 
*         EXIT   (D) = MICRO NAME.
  
  
 CPOPA    MACRO  P1 
 D        MICRO  1,, "P1" 
          ENDM
 CPUOP    SPACE  4
**        CPUOP - CENTRAL PROCESSER OPERATION MACRO.
*         CPUOP  CTL,VAL,REQ,N1,N2,N3 
*         ENTRY  (CTL) = 4 - FORCE UPPER AFTER INSTRUCTION. 
*                        2 - FORCE UPPER BEFORE INSTRUCTION.
*                        1 - 30-BIT INSTRUCTION.
*                (VAL) = VALUE OF OPERATION CODE. 
*                (REG) = IJK.  (I) = CODE FOR I-PORTION.
*                        1 - OP-CODE PORTION. 
*                        2 - 2ND OR ONLY ADDRESS REGISTER.
*                        3 - 1ST OF 2 ADDRESS REGISTERS.
*                (NI) = FIELD DEFINITION OF MNEMONIC. 
  
  
 CPUOP    MACRO  CTL,VAL,REG,N1,N2,N3 
 D        MICRO  3,,$N1$
          CPOPA  "D"
 MN       MICRO  1,2,$N1$ 
          VFD    24/2R"MN",8/"D",8/"N2",8/"N3",12/1R
          VFD    12/VAL,18/M.,3/CTL,9/REG,18/ 
          ENDM
 PPUOP    SPACE  4
**        PPUOP - DEFINE PP INSTRUCTION MACRO.
*         PPUOP  NAME,CTL,VAL 
*         ENTRY  (NAME) = MNEMONIC NAME.
*                (CTL) = 1 - 24-BIT WITH 12-BIT ADDRESS AND NO INDEXING.
*                        2 - 12-BIT WITH SIGNED RELATIVE ADDRESS
*                            OR ABSOLUTE ADDRESS (UJN). 
*                        3 - 24-BIT WITH 18-BIT ADDRESS (LDC).
*                        4 - 12-BIT WITH 6-BIT ADDRESS (LDN). 
*                        5 - 24-BIT WITH 12-BIT ADDRESS AND OPTIONAL
*                            INDEXING (LDM).
*                        6 - 12-BIT WITH SIGNED RELATIVE ADDRESS (SHN). 
*                        7 - 24-BIT WITH 12-BIT ADDRESS AND REQUIRED
*                            SECOND FIELD (FNC).
*                (VAL) = 12-BIT OPERATION CODE VALUE. 
  
  
 PPUOP    MACRO  NAME,CTL,VAL PERIPHERAL MACHINE CODES
          DATA   R$NAME$
          VFD    3/1,27/M.,3/CTL,27/VAL 
          ENDM
 PSEUDO   SPACE  4
**        PSEUDO - DEFINE PSEUDO INSTRUCTION MACRO. 
*         PSEUDO TYPE,NAME
*         ENTRY  (TYPE) = 2 - CAN NOT OCCUR IN THE FIRST CARD GROUP.
*                         3 - PROCESS WHILE IF SKIPPING.
*                         4 - PERMISSIBLE ANYWHERE. 
*                         5 - FIRST CARD GROUP ONLY.
*                (NAME) = NAME OF PSEUDO OPERATION. 
  
  
 PSEUDO   MACRO  TYPE,NAME
          DATA   R$NAME$
          VFD    3/TYPE,12/0,9/N.,18//PASS1/NAME,18//PASS2/NAME 
 N.       SET    N.+1 
          ENDM
 PSEUD    SPACE  4
**        PSEUD - DEFINE PSEUDO INSTRUCTION MACRO.
*         PSEUD  TYPE,NAME,PASS1,PASS2
*         ENTRY  (TYPE) = PSEUDO INSTRUCTION TYPE.
*                (NAME) = NAME OF PSEUDO OPERATION. 
*                (P1) = PASS1 ADDRESS.
*                (P2) = PASS2 ADDRESS.
  
  
 PSEUD    MACRO  TYPE,NAME,P1,P2
          DATA   R$NAME$
          VFD    3/TYPE,12/0,9/N.,18//PASS1/P1,18//PASS2/P2 
 N.       SET    N.+1 
          ENDM
 OPS      SPACE  4
*         6600 AND 7600 PP OPCODES. 
*         6600, 7600 AND V PP OPCODES.
  
  
 OPS      BSS    0
 M.       SET    0
          LIST   -R 
          PPUOP  LJM,5,0100 
          PPUOP  RJM,5,0200 
          PPUOP  UJN,2,0300 
          PPUOP  ZJN,2,0400 
          PPUOP  NJN,2,0500 
          PPUOP  PJN,2,0600 
          PPUOP  MJN,2,0700 
          PPUOP  SHN,6,1000 
          PPUOP  LMN,4,1100 
          PPUOP  LPN,4,1200 
          PPUOP  SCN,4,1300 
          PPUOP  LDN,4,1400 
          PPUOP  LCN,4,1500 
          PPUOP  ADN,4,1600 
          PPUOP  SBN,4,1700 
          PPUOP  LDC,3,2000 
          PPUOP  ADC,3,2100 
          PPUOP  LPC,3,2200 
          PPUOP  LMC,3,2300 
          PPUOP  PSN,4,2400 
          PPUOP  LDD,4,3000 
          PPUOP  ADD,4,3100 
          PPUOP  SBD,4,3200 
          PPUOP  LMD,4,3300 
          PPUOP  STD,4,3400 
          PPUOP  RAD,4,3500 
          PPUOP  AOD,4,3600 
          PPUOP  SOD,4,3700 
          PPUOP  LDI,4,4000 
          PPUOP  ADI,4,4100 
          PPUOP  SBI,4,4200 
          PPUOP  LMI,4,4300 
          PPUOP  STI,4,4400 
          PPUOP  RAI,4,4500 
          PPUOP  AOI,4,4600 
          PPUOP  SOI,4,4700 
          PPUOP  LDM,5,5000 
          PPUOP  ADM,5,5100 
          PPUOP  SBM,5,5200 
          PPUOP  LMM,5,5300 
          PPUOP  STM,5,5400 
          PPUOP  RAM,5,5500 
          PPUOP  AOM,5,5600 
          PPUOP  SOM,5,5700 
          PPUOP  IAN,4,7000 
          PPUOP  IAM,7,7100 
          PPUOP  OAN,4,7200 
          PPUOP  OAM,7,7300 
  
*         6600 AND V PP OPCODES.
  
 M.       SET    5
          PPUOP  LRD,4,2400 
          PPUOP  SRD,4,2500 
          PPUOP  EXN,4,2600 
          PPUOP  MXN,4,2610 
          PPUOP  MAN,4,2620 
          PPUOP  RPN,4,2700 
          PPUOP  KEYP,4,2700
          PPUOP  CRD,4,6000 
          PPUOP  CRM,7,6100 
          PPUOP  CWD,4,6200 
          PPUOP  CWM,7,6300 
          PPUOP  AJM,7,6400 
          PPUOP  SCF,7,6440 
          PPUOP  IJM,7,6500 
          PPUOP  CCF,7,6540 
          PPUOP  FJM,7,6600 
          PPUOP  SFM,7,6640 
          PPUOP  EJM,7,6700 
          PPUOP  CFM,7,6740 
          PPUOP  ACN,4,7400 
          PPUOP  DCN,4,7500 
          PPUOP  FAN,4,7600 
          PPUOP  FNC,7,7700 
  
*         6416 PP OPCODES.
  
          PPUOP  ETN,4,2600 
          PPUOP  ERN,4,2700 
  
*         7600 PP OPCODES.
  
 M.       SET    2
          PPUOP  FIM,7,6000 
          PPUOP  EIM,7,6100 
          PPUOP  IRM,7,6200 
          PPUOP  NIM,7,6300 
          PPUOP  FOM,7,6400 
          PPUOP  EOM,7,6500 
          PPUOP  ORM,7,6600 
          PPUOP  NOM,7,6700 
          PPUOP  RFN,4,7400 
          PPUOP  ESN,4,7700 
  
*         180 OPCODES.
  
 M.       SET    4
          PPUOP  RDSL,4,100000
          PPUOP  RDCL,4,100100
          PPUOP  SHDL,4,101000
          PPUOP  LRDL,4,101100
          PPUOP  LRIL,4,101200
          PPUOP  LRML,5,101300
          PPUOP  SRDL,4,101400
          PPUOP  SRIL,4,101500
          PPUOP  SRML,5,101600
          PPUOP  HOLD,4,101700
          PPUOP  LPDL,4,102200
          PPUOP  LPIL,4,102300
          PPUOP  LPML,5,102400
          PPUOP  INPN,4,102600
          PPUOP  LDDL,4,103000
          PPUOP  ADDL,4,103100
          PPUOP  SBDL,4,103200
          PPUOP  LMDL,4,103300
          PPUOP  STDL,4,103400
          PPUOP  RADL,4,103500
          PPUOP  AODL,4,103600
          PPUOP  SODL,4,103700
          PPUOP  LDIL,4,104000
          PPUOP  ADIL,4,104100
          PPUOP  SBIL,4,104200
          PPUOP  LMIL,4,104300
          PPUOP  STIL,4,104400
          PPUOP  RAIL,4,104500
          PPUOP  AOIL,4,104600
          PPUOP  SOIL,4,104700
          PPUOP  LDML,5,105000
          PPUOP  ADML,5,105100
          PPUOP  SBML,5,105200
          PPUOP  LMML,5,105300
          PPUOP  STML,5,105400
          PPUOP  RAML,5,105500
          PPUOP  AOML,5,105600
          PPUOP  SOML,5,105700
          PPUOP  CRDL,4,106000
          PPUOP  CRML,7,106100
          PPUOP  CWDL,4,106200
          PPUOP  CWML,7,106300
          PPUOP  FSJM,7,106400
          PPUOP  FCJM,7,106500
          PPUOP  CHCM,7,107000
          PPUOP  IAPM,7,107100
          PPUOP  CMCH,7,107200
          PPUOP  OAPM,7,107300
          PPUOP  MCLR,4,107400
 FNCLCDE  EQU    007700B     *FNCL* HAS SAME OPCODE AS *FNC*
          PPUOP  FNCL,7,FNCLCDE 
  
*         6600, 7600 AND V CP OPCODES 
  
 M.       SET    0
          CPUOP  7,000,000,PS 
          CPUOP  7,000,000,PSQ
          CPUOP  5,010,000,RJQ
          CPUOP  5,020,000,JPQ
          CPUOP  5,020,220,JPB
          CPUOP  5,020,220,JPBQ 
          CPUOP  1,030,020,ZRX,Q
          CPUOP  1,031,020,NZX,Q
          CPUOP  1,032,020,PLX,Q
          CPUOP  1,033,020,NGX,Q
          CPUOP  1,033,020,MIX,Q
          CPUOP  1,034,020,IRX,Q
          CPUOP  1,035,020,ORX,Q
          CPUOP  1,036,020,DFX,Q
          CPUOP  1,037,020,IDX,Q
          CPUOP  5,040,000,EQQ
          CPUOP  1,040,200,EQB,Q
          CPUOP  1,040,320,EQB,B,Q
          CPUOP  5,040,000,ZRQ
          CPUOP  1,040,200,ZRB,Q
          CPUOP  1,050,200,NEB,Q
          CPUOP  1,050,320,NEB,B,Q
          CPUOP  1,050,200,NZB,Q
          CPUOP  1,060,200,PLB,Q
          CPUOP  1,060,200,GEB,Q
          CPUOP  1,060,320,GEB,B,Q
          CPUOP  1,060,230,LEB,B,Q
          CPUOP  1,060,020,LEB,Q
          CPUOP  1,070,200,NGB,Q
          CPUOP  1,070,200,MIB,Q
          CPUOP  1,070,320,LTB,B,Q
          CPUOP  1,070,230,GTB,B,Q
          CPUOP  1,070,200,LTB,Q
          CPUOP  1,070,020,GTB,Q
          CPUOP  0,100,122,BXX
          CPUOP  0,110,132,BXX*X
          CPUOP  0,120,132,BXX+X
          CPUOP  0,130,132,BXX-X
          CPUOP  0,140,122,BX-X 
          CPUOP  0,150,123,BX-X*X 
          CPUOP  0,160,123,BX-X+X 
          CPUOP  0,170,123,BX-X-X 
          CPUOP  0,200,100,LXQ
          CPUOP  0,210,100,AXQ
          CPUOP  0,220,102,LXX
          CPUOP  0,220,121,LXB
          CPUOP  0,220,121,AX-B 
          CPUOP  0,220,132,LXB,X
          CPUOP  0,220,132,AX-B,X 
          CPUOP  0,220,123,LXX,B
          CPUOP  0,220,123,AXX,-B 
          CPUOP  0,230,102,AXX
          CPUOP  0,230,121,AXB
          CPUOP  0,230,121,LX-B 
          CPUOP  0,230,132,AXB,X
          CPUOP  0,230,132,LX-B,X 
          CPUOP  0,230,123,AXX,B
          CPUOP  0,230,123,LXX,-B 
          CPUOP  0,240,101,NX 
          CPUOP  0,240,102,NXX
          CPUOP  0,240,121,NXB
          CPUOP  0,240,132,NXB,X
          CPUOP  0,240,123,NXX,B
          CPUOP  0,250,101,ZX 
          CPUOP  0,250,102,ZXX
          CPUOP  0,250,121,ZXB
          CPUOP  0,250,132,ZXB,X
          CPUOP  0,250,123,ZXX,B
          CPUOP  0,260,101,UX 
          CPUOP  0,260,102,UXX
          CPUOP  0,260,121,UXB
          CPUOP  0,260,132,UXB,X
          CPUOP  0,260,123,UXX,B
          CPUOP  0,270,101,PX 
          CPUOP  0,270,102,PXX
          CPUOP  0,270,121,PXB
          CPUOP  0,270,132,PXB,X
          CPUOP  0,270,123,PXX,B
          CPUOP  0,300,132,FXX+X
          CPUOP  0,310,132,FXX-X
          CPUOP  0,320,132,DXX+X
          CPUOP  0,330,132,DXX-X
          CPUOP  0,340,132,RXX+X
          CPUOP  0,350,132,RXX-X
          CPUOP  0,360,132,IXX+X
          CPUOP  0,370,132,IXX-X
          CPUOP  0,400,132,FXX*X
          CPUOP  0,410,132,RXX*X
          CPUOP  0,420,132,DXX*X
          CPUOP  0,420,132,IXX*X
          CPUOP  0,430,100,MXQ
          CPUOP  0,440,132,FXX/X
          CPUOP  0,450,132,RXX/X
          CPUOP  0,460,000,NO 
          CPUOP  0,460,000,NOQ
          CPUOP  7,464,020,IMB
          CPUOP  7,464,000,IMQ
          CPUOP  7,464,020,IMBQ 
          CPUOP  0,470,122,CXX
          CPUOP  1,500,120,SAAQ 
          CPUOP  1,600,120,SBAQ 
          CPUOP  1,700,120,SXAQ 
          CPUOP  1,510,100,SAQ
          CPUOP  1,610,100,SBQ
          CPUOP  1,710,100,SXQ
          CPUOP  1,510,120,SABQ 
          CPUOP  1,610,120,SBBQ 
          CPUOP  1,710,120,SXBQ 
          CPUOP  1,520,120,SAXQ 
          CPUOP  1,620,120,SBXQ 
          CPUOP  1,720,120,SXXQ 
          CPUOP  0,530,132,SAX+B
          CPUOP  0,630,132,SBX+B
          CPUOP  0,730,132,SXX+B
          CPUOP  0,530,123,SAB+X
          CPUOP  0,630,123,SBB+X
          CPUOP  0,730,123,SXB+X
          CPUOP  0,530,120,SAX
          CPUOP  0,630,120,SBX
          CPUOP  0,730,120,SXX
          CPUOP  0,540,120,SAA
          CPUOP  0,640,120,SBA
          CPUOP  0,740,120,SXA
          CPUOP  0,540,132,SAA+B
          CPUOP  0,640,132,SBA+B
          CPUOP  0,740,132,SXA+B
          CPUOP  0,540,123,SAB+A
          CPUOP  0,640,123,SBB+A
          CPUOP  0,740,123,SXB+A
          CPUOP  0,550,132,SAA-B
          CPUOP  0,650,132,SBA-B
          CPUOP  0,750,132,SXA-B
          CPUOP  0,550,123,SA-B+A 
          CPUOP  0,650,123,SB-B+A 
          CPUOP  0,750,123,SX-B+A 
          CPUOP  0,560,120,SAB
          CPUOP  0,660,120,SBB
          CPUOP  0,760,120,SXB
          CPUOP  0,560,132,SAB+B
          CPUOP  0,660,132,SBB+B
          CPUOP  0,760,132,SXB+B
          CPUOP  0,570,102,SA-B 
          CPUOP  0,670,102,SB-B 
          CPUOP  0,770,102,SX-B 
          CPUOP  0,570,132,SAB-B
          CPUOP  0,670,132,SBB-B
          CPUOP  0,770,132,SXB-B
          CPUOP  0,570,123,SA-B+B 
          CPUOP  0,670,123,SB-B+B 
          CPUOP  0,770,123,SX-B+B 
  
*         6600 AND V CP OPCODES 
  
 M.       SET    5
          CPUOP  3,011,020,REB
          CPUOP  3,011,000,REQ
          CPUOP  3,011,020,REBQ 
          CPUOP  3,012,020,WEB
          CPUOP  3,012,000,WEQ
          CPUOP  3,012,020,WEBQ 
          CPUOP  7,013,000,XJ 
          CPUOP  7,013,020,XJB
          CPUOP  7,013,000,XJQ
          CPUOP  7,013,020,XJBQ 
  
*         7600 CP OPCODES.
  
 M.       SET    2
          CPUOP  4,000,000,ES 
          CPUOP  4,000,000,ESQ
 SC2      IFEQ   CP#RM,7
          CPUOP  1,011,000,RLQ
          CPUOP  1,011,020,RLB
          CPUOP  1,011,020,RLBQ 
          CPUOP  1,012,000,WLQ
          CPUOP  1,012,020,WLB
          CPUOP  1,012,020,WLBQ 
 SC2      ELSE
          CPUOP  3,011,000,RLQ
          CPUOP  3,011,020,RLB
          CPUOP  3,011,020,RLBQ 
          CPUOP  3,012,000,WLQ
          CPUOP  3,012,020,WLB
          CPUOP  3,012,020,WLBQ 
 SC2      ENDIF 
          CPUOP  5,013,000,MJQ
          CPUOP  5,013,020,MJB
          CPUOP  5,013,020,MJBQ 
          CPUOP  4,013,000,MJ 
          CPUOP  0,016,010,TB 
          CPUOP  0,016,010,TBQ
          CPUOP  0,016,002,RIB
          CPUOP  0,016,012,IBB
          CPUOP  0,017,002,ROB
          CPUOP  0,017,012,OBB
  
*         V CP INSTRUCTIONS 
  
 M.       SET    4
          CPUOP  0,660,032,CRX,X
          CPUOP  0,670,032,CWX,X
          CPUOP  0,017,000,RT 
  
*         7600 AND V CP OPCODES.
  
 M.       SET    6
          CPUOP  0,014,012,RXX
          CPUOP  0,015,012,WXX
          LIST   *
 PSEUDO   SPACE  4
****      PSEUDO OPERATIONS.
*         NEW PSEUDO-OPS MUST BE ADDED AT THE END OF THIS TABLE.
  
  
 POPS     BSS    0
 N.       SET    1
 PSEUDO   SPACE  4
**        FIRST CARD GROUP ONLY.
  
  
          PSEUDO 5,ABS
          PSEUD  5,MACHINE,MCH,MCH
          PSEUDO 5,PERIPH 
          PSEUDO 5,PPU
          PSEUDO 5,STEXT
 PSEUDO   SPACE  4
**        PERMISSIBLE ANYWHERE. 
  
  
          PSEUDO 4,BASE 
          PSEUD  4,B1=1,B1=1.,.B1=1 
          PSEUDO 4,B7=1 
          PSEUD  4,CHAR,CHAR.,CHAR. 
          PSEUDO 4,CODE 
          PSEUDO 4,COMMENT
          PSEUDO 4,CPOP 
          PSEUDO 4,CPSYN
          PSEUDO 4,DECMIC 
          PSEUDO 4,EJECT
          PSEUDO 4,ENDD 
          PSEUDO 4,ENDM 
          PSEUDO 4,HERE 
          PSEUDO 4,IFC
          PSEUDO 4,IRP
          PSEUDO 4,LIST 
          PSEUDO 4,MACRO
          PSEUDO 4,MACROE 
          PSEUDO 4,MICCNT 
          PSEUDO 4,MICRO
          PSEUDO 4,NIL
          PSEUDO 4,NOLABEL
          PSEUDO 4,NOREF
          PSEUDO 4,OCTMIC 
          PSEUDO 4,OPDEF
          PSEUDO 4,OPSYN
          PSEUDO 4,PPOP 
          PSEUDO 4,PURGDEF
          PSEUDO 4,PURGMAC
          PSEUDO 4,QUAL 
          PSEUDO 4,RMT
          PSEUDO 4,SKIP 
          PSEUDO 4,SPACE
          PSEUDO 4,SST
          PSEUDO 4,TITLE
          PSEUDO 4,TTL
          PSEUDO 4,XREF 
          PSEUD  4,(  ),BLNKOP,BLNKOP 
 PSEUDO   SPACE  4
**        PROCESS WHILE IF SKIPPING.
  
  
          PSEUDO 3,ELSE 
          PSEUDO 3,END
          PSEUDO 3,ENDIF
 PSEUDO   SPACE  4
**        CAN NOT OCCUR IN THE FIRST CARD GROUP.
  
  
          PSEUDO 2,BSS
          PSEUDO 2,BSSZ 
          PSEUDO 2,CC 
          PSEUD  2,COL,COL.,COL.
          PSEUDO 2,CON
          PSEUDO 2,CTEXT
          PSEUDO 2,CU 
          PSEUDO 2,DATA 
          PSEUDO 2,DIS
          PSEUDO 2,DM 
          PSEUDO 2,DUP
          PSEUDO 2,ECHO 
          PSEUDO 2,ENDX 
          PSEUDO 2,ENTRY
          PSEUDO 2,ENTRYC 
          PSEUDO 2,EQU
          PSEUDO 2,ERR
          PSEUDO 2,ERRMI
          PSEUDO 2,ERRNG
          PSEUDO 2,ERRNZ
          PSEUDO 2,ERRPL
          PSEUDO 2,ERRZR
          PSEUDO 2,EXT
          PSEUDO 2,IF 
          PSEUDO 2,IFCP 
          PSEUDO 2,IFCP6
          PSEUDO 2,IFCP7
          PSEUDO 2,IFEQ 
          PSEUDO 2,IFGE 
          PSEUDO 2,IFGT 
          PSEUDO 2,IFLE 
          PSEUDO 2,IFLT 
          PSEUDO 2,IFMI 
          PSEUDO 2,IFNE 
          PSEUDO 2,IFPL 
          PSEUDO 2,IFPP 
          PSEUDO 2,IFPP6
          PSEUDO 2,IFPP7
          PSEUDO 2,LCC
          PSEUDO 2,LOC
          PSEUDO 2,LIT
          PSEUDO 2,MAX
          PSEUDO 2,MD 
          PSEUDO 2,MIN
          PSEUDO 2,ORG
          PSEUDO 2,ORGC 
          PSEUDO 2,IDENT
          PSEUDO 2,POS
          PSEUDO 2,REP
          PSEUDO 2,REPC 
          PSEUDO 2,REPI 
          PSEUDO 2,R= 
          PSEUDO 2,SEG
          PSEUDO 2,SEGMENT
          PSEUDO 2,SET
          PSEUDO 2,STOPDUP
          PSEUDO 2,USE
          PSEUDO 2,USELCM 
          PSEUDO 2,VFD
          PSEUDO 2,XTEXT
          PSEUD  2,=,EQU,EQU
 PSEUDO   SPACE  4
**        NEW PSEUDO OPS. 
  
  
          PSEUDO 4,LDSET
          PSEUDO 5,BCU
          PSEUDO 5,MCU
          PSEUDO 4,BCOP 
          PSEUDO 4,NDOP 
          PSEUDO 5,CIPPU
          PSEUDO 5,MEMSEL 
          PSEUDO 2,CONL 
          PSEUDO 2,VFDL 
****
 LGOPS    EQU    *-OPS
          BASE   DECIMAL
 GBUF     SPACE  4,8
*         BUFFER SPACE FOR LOADING SYSTEM TEXT.                          CPSA097
  
  
          IFNE   OVERLAY,0,2
 GBUF     BSS    0           CIO BUFFER SPACE FOR *G* SYSTEXT FILE
 ENDZ     EQU    GBUF+GBUFL  MANAGED TABLE SPACE DURING *LST* PROCESSING
          TITLE  SECONDARY OVERLAY. 
          IFEQ   OVERLAY,0   SEGMENT CONTROL
  
          IDENT              SECONDARY OVERLAY. 
  
          ELSE
  
          IDENT  "OVLA",ORGA+1,,1,1           SECONDARY OVERLAY 
          COMMENT   CYBER 70/ MODEL "MODEL" 
          COMMENT   COMPREHENSIVE ASSEMBLER PROGRAM VERSION "VERSION".
 ORGA     EQU    PRTA 
          ORG    ORGA+1 
  
          ENDIF 
 PASS1    TITLE  PASS 1 CONTROL.
**        PASS 1 CONTROL. 
  
  
          QUAL   PASS1
 PASS1    RJ     PRS         PRESET STORAGE 
          TIME   ATIME
          RJ     AUT         ALLOCATE USE TABLE 
 CONTROL  SPACE  4
**        CTL - SEARCH FOR IDENT CARD.
  
  
 CTL      RJ     INPUT1      READ FIRST CARD
          RJ     EDIT 
          RJ     SETUP
          SA1    TITBUF      SET TITLE
          RJ     SNT
          SA1    =7R*******  PRESET IDNAM 
          BX6    X1 
          SA6    IDNAM
          SA1    IOP
          SA2    =5RIDENT 
          BX6    X1-X2
          ZR     X6,CTL2     IF OP CODE IS IDENT
          SX2    3REND
          BX6    X2-X1
          NZ     X6,CTL1     IF NOT *END* CARD
          RJ     RSS         RECORD SEGMENT START 
          EQ     CTL105      PROCESS END CARD 
 CTL1     RJ     CWI         WRITE INTERMEDIATE FILE
          EQ     CTL
 CTL2     RJ     SCLIST      SCAN IDENT NAME
          SA6    IDNAM
          BX1    X6          DISPLAY IDENT MESSAGE
          RJ     DIM
          RJ     RSS         RECORD SEGMENT START 
 CTL60    SPACE  4
**        CTL60 - CLEAR OPERATION CODE ERROR. 
  
  
 CTL60    SX6    B0 
          SA6    OERR 
          SA6    W9ERR       AND MICRO WARNING ERROR
 CTL65    MX6    0
          SA6    AERR 
          SA6    UERR 
          SA6    W7ERR
 CTL70    SPACE  4
**        CTL70 - RETURN POINT FOR MOST OPERATION CODE PROCESSORS.
  
  
 CTL70    RJ     WINTER      WRITE INTERMEDIATE FILE
 CTL100   SPACE  4
**        CTL100 - MAIN COMPASS PASS 1 CONTROL. 
  
  
 CTL100   RJ     INPUT1      READ NEXT CARD 
          SA1    IFCNT       CHECK IF-SKIPPING
          SX6    1
          ZR     X1,CTL105   IF NOT SKIPPING
          SA2    CARD 
          SB7    X2-1R*      CHECK FOR COMMENT CARD 
          ZR     B7,CTL290   IF COMMENT CARD
          IX6    X1-X6       REDUCE COUNT 
          SA6    A1 
          NZ     X6,CTL105   IF STILL SKIPPING
          SA6    NOAS        CLEAR NO-ASSEMBLY FLAG 
 CTL105   RJ     EDIT        REMOVE CONCATENATION AND MICROS
 CTL110   RJ     SETUP       PREPARE FOR ASSEMBLY 
          SA1    STYPE
          SB7    X1-1R*      CHECK FOR COMMENTS CARD
          ZR     B7,CTL290   IF COMMENT CARD
          SA1    POSCTR      CHECK FOR END OF WORD
 +        NZ     X1,*+1 
          RJ     YFOUP       PUSH ON TO NEXT WORD 
          SA1    IOP         LOOK UP OPERATION CODE 
          RJ     TLUOP
          SA1    OPTYPE      DETERMINE TYPE OF OPCODE 
          SX0    7
          AX1    57 
          BX2    X1*X0
          SA5    IFCNT       CHECK IF-SKIPPING
          SA4    MACHINE
          SX3    X2-3 
 +        ZR     X5,*+1      IF NOT SKIPPING
          NZ     X3,CTL60    JUMP IF SKIPPING AND NOT END OR ENDIF
          SB7    X2-4 
          ZR     B7,CTL280   IF TYPE 4
          PL     B7,CTL260   IF TYPES 5,6 OR 7
          SX6    B1          SET FIRST CARD GROUP FLAG
          SA6    IFCDGP 
          JP     CTL200+4+B7
  
 CTL200   ZR     X4,CTLCP    TYPE 0 - CP OPERATION
          EQ     CTLPPER     IF CP OP IN PP CODING
 +        NZ     X4,CTLPP    TYPE 1 - PP OPERATION
          EQ     CTLCP       IF PP OP IN CP CODING
 +        NO                 TYPE 2 - NORMAL PSEUDO OPERATION 
 CTL280   SA1    OPTYPE      TYPE 3 - PSEUDO PROCESSED WHILE IN IF CODE 
          AX1    18          JUMP ON PSEUDO OP
          SB7    X1 
          JP     B7 
 CTL260   SPACE  4
**        CTL260 - TYPE 5, 6, AND 7 PSEUDO OPERATIONS.
  
  
 CTL260   GT     B7,B1,MACALL IF MACRO (TYPES 6 + 7)
          SA1    IFCDGP      CHECK IF THIS CARD IS LEGAL
          ZR     X1,CTL280   JUMP IF SO 
 CTL80    SX6    B1          NOTE OP CODE ERROR 
          SA6    EFLG 
          SA6    OERR        COMPLAIN AND IGNORE OP 
          EQ     CTL70
 CONTROL  SPACE  4
**        CTL200 - CHECK IF SKIP COUNT FOR COMMENT CARDS. 
  
  
 CTL290   SA5    IFCNT
          SB7    X5 
          NE     B7,B1,CTL300 IF STILL IF-SKIPPING
          SX6    B0          TERMINATE IF-SKIPPING
          SA6    A5 
*         EQ     CTL300 
 CTL300   SPACE  4
**        CTL300 - RETURN POINT FOR PSEUDOS WITH NO PASS 2 PROCESSING.
  
  
 CTL300   RJ     CWI         CONDITIONALLY WRITE THE INTERMEDIATE 
          EQ     CTL100      READ NEXT CARD 
 CONTROL  SPACE  4
**        CTL400 - RETURN POINT FOR PSEUDOS THAT HAVE OPCODE CHANGED. 
  
  
 CTL400   SX6    B1 
          SA6    TXTFLG 
          RJ     CWI         WRITE INTERMEDIATE 
          MX6    0
          SA6    TXTFLG 
          EQ     CTL100      READ NEXT CARD 
 ERA      SPACE  4
**        ERA - RETURN POINT FOR PSEUDOS WITH *A* ERROR.
  
  
 ERA      SX6    B1 
          SA6    EFLG 
          SA6    AERR 
          EQ     CTL70
 RJY      SPACE  4
**        SCAN INSTRUCTION FOR SCAD WHILE IN PASS 1.
  
  
 RJY      SA1    EXLGN       SCAN INITIALIZE RJ INSTRUCTION 
          RJ     YEVITEM
 CTLCP    EJECT  4                                                       CPSA097
**        DECODE CENTRAL PROCESSOR OPERATIONS.
  
  
 CTLCP    SA1    COL         RECLAIM FIRST 2 LETTERS OF OP CODE 
          SA2    X1+CARD
          SA3    A2+B1
          LX2    6
          BX6    X2+X3
          MX7    0
          SA6    OPADS
          SA7    A6+B1       OPADS+1
          SA7    A7+B1       OPADS+2
          SX6    X1+B1
          SA7    A7+B1       OPADS+3
          SA7    P1TEMP      SUBFIELD COUNT 
          SA7    P1TEMPC
          SA6    COLUMN 
          RJ     GETCH
          SB7    X1-3        CHECK FOR AN A, B, OR X
          SB6    X1-1RX 
 +        NG     B7,*+1 
          NZ     B6,CTLCP1
          SX1    60 
          RJ     YEVITEM     CHECK FOR OP-CODE REGISTER 
          SA2    ELREG
          ZR     X2,CTLCPER  BAD OP-CODE
          SA1    CHAR 
          SB7    X1-1R
          ZR     B7,CTLCP2   IF END OF OPCODE FIELD 
          NE     B1,B7,CTLCPER IF NOT *,* 
          EQ     CTLCP2A
 CTLCP1   RJ     GETCH       MAKE SURE IT IS 2-LETTER OP CODE 
          SB7    X1-1R
          EQ     B7,B1,CTLCP2A IF COMMA 
          NZ     B7,CTLCPER  ERROR IF NOT 2-LETTER OP 
  
*         ENTRY ON NEW SUBFIELD.
  
 CTLCP2   SA2    P1TEMPC
          NZ     X2,CTLCP2A  IF IN VARIABLE FIELD 
          SA1    COL+1       RESET TO VARIABLE FIELD
          BX6    X1 
          SA6    A2 
          SA6    COLUMN 
 CTLCP2A  RJ     GETCH
          MX6    0
          SA6    P1TEMPA     REGISTER COUNT 
  
*         ENTRY ON NEW TERM.
  
 CTLCP3   SB7    X1-1R       CHECK FOR END OF ADDRESS EXPRESSION
          ZR     B7,CTLCP10  IF END OF ADDRESS FIELD
          EQ     B7,B1,CTLCP9A IF COMMA 
          MX6    0
          SA6    P1TEMP+2    OPERATOR 
          SB7    X1-1R& 
          ZR     B7,CTLCP4   IF LOGICAL MINUS 
          SB7    X1-1R+ 
          ZR     B7,CTLCP4   IF PLUS SIGN 
          NE     B7,B1,CTLCP5 
          SX6    B1          SET FLAG FOR MINUS SIGN
          SA6    A6 
 CTLCP4   RJ     GETCH
 CTLCP5   SX1    60          EVALUATE ITEM
          RJ     YEVITEM
 CTLCP6A  SA2    ELREG
          SA5    P1TEMP      SUBFIELD COUNT 
          SA3    X5+OPADS+1  SUBFIELD MASK
          SA4    A5+B1       REGISTER COUNT 
          SA5    A4+B1       OPERATOR 
          ZR     X2,CTLCP6   IF NOT REGISTER
          AX2    3
          LX5    2
          SB7    X2-3 
 +        NG     B7,*+1      CORRECT FOR X REGISTER 
          SX2    3
          SB7    X4 
          BX5    X5+X2
          GT     B7,B1,CTLCPER ERROR IF 3RD REGISTER
          EQ     B7,B1,CTLCP7A IF SECOND REGISTER 
          LX5    5
          BX6    X3+X5       OR INTO MASK FOR FIRST REGISTER
          SX7    X4+B1
          SA6    A3 
          SA7    A4 
          SB7    X1-1R* 
 +        ZR     B7,*+1      CHECK FOR CONNECTING * OR /
          NE     B7,B1,CTLCP3 
          SX6    X1-45B 
          SA6    A5 
          RJ     GETCH
          SX1    60 
          RJ     YEVITEM
          SA2    ELREG       MAKE SURE IT IS A REGISTER 
          NZ     X2,CTLCP6A 
 CTLCPER  MX6    0           MAKE BAD OP CODE 
          SA6    OPADS
          EQ     CTLCP11
 CTLCP7A  LX5    1           OR IN FOR SECOND REGISTER
          SX7    X4+B1
          BX6    X3+X5
          SA7    A4 
          SA6    A3 
          SB7    X1-1R* 
          ZR     B7,CTLCPER 
          EQ     B7,B1,CTLCPER
          EQ     CTLCP3 
  
 CTLCP6   SX4    B1          SPACE OVER ADDRESS ITEM
          BX6    X3+X4       SET ADDRESS FLAG 
          SA6    A3 
          SB7    X1-1R* 
 +        ZR     B7,*+1 
          NE     B7,B1,CTLCP3 
          RJ     GETCH
          SX1    60 
          RJ     YEVITEM
          SA2    ELREG
          NZ     X2,CTLCPER  COMPLAIN IF REGISTER 
          EQ     CTLCP6A
  
*         END OF SUBFIELD.
  
 CTLCP9A  SA2    P1TEMP      COMMA
          SB6    X1-1R, 
          SX6    X2+B1       UP SUBFIELD COUNT
          SB7    X6-3 
          SA6    A2 
          PL     B7,CTLCPER  IF TOO MANY COMMAS 
          ZR     B6,CTLCP2A  IF COMMA 
          EQ     CTLCP3 
  
*         END OF FIELD. 
  
 CTLCP10  SA2    P1TEMPC     CHECK FOR END OF FIELD 
          NZ     X2,CTLCP11  IF END OF ADDRESS FIELD
          SA1    COL+1       RESET TO ADDRESS FIELD 
          BX6    X1 
          SA6    A2 
          SA6    COLUMN 
          RJ     GETCH
          MX6    0
          SB7    X1-1R
          SA6    P1TEMPA     REGISTER COUNT 
          NZ     B7,CTLCP9A  IF NOT BLANK 
  
*         END OF STATEMENT. 
  
 CTLCP11  SA2    OPADS       CREATE LOOK UP MASK
          SA3    A2+B1
          SA4    A3+B1
          LX2    36 
          LX3    28 
          LX4    20 
          BX6    X2+X3
          IX7    X6+X4
          SA2    A4+B1
          LX2    12 
          SX0    1R 
          BX4    X7+X2
          IX1    X4+X0
          RJ     TLUOP
          SA2    OPTYPE 
          SB7    B0          SET B7 IN CASE THIS IS OPDEF 
          NG     X2,MACALL   IF OPDEF CALL
          NZ     X2,CTLCP7   IF VALID OPCODE ENTRY
          SX7    B1          SET OP CODE ERROR TO A 30-BIT INSTRUCTION
          SA7    EFLG 
          SA7    OERR 
          LX7    27 
          BX2    X7 
          SA7    OPTYPE 
 CTLCP7   SX0    B1 
          AX2    27 
          BX6    X0*X2       FLAG BIT FOR 30-BIT INSTRUCTION
          AX2    1
          BX7    X0*X2       FLAG BIT FOR FORCE UPPER 
          SA5    NFOUP
          AX4    X6          15 OR 30 BIT FLAG
          BX7    X7+X5       OR INTO FORCE FROM LAST INSTRUCTION
          SA7    A5 
          LX6    4
          IX4    X6-X4
          SX1    X4+15
          BX6    X1 
          SA6    P1TEMP      LENGTH OF OPERATION CODE 
          RJ     YPRLOC      PROCESS LOCATION FIELD 
          SX0    B1 
          SA2    OPTYPE 
          AX2    29 
          BX6    X2*X0
          SA6    NFOUP
          SA1    P1TEMP 
          RJ     UPPOS       UP POSITION COUNTER
 CTLCP8   SA1    OPTYPE      CHECK MACHINE TYPE 
          SA2    MTYPE
          SX0    7B 
          ZR     X2,CTL65    IF MACHINE NOT SPECIFIED OR TYPE OMITTED 
          AX1    30 
          BX4    X0*X1
          ZR     X4,CTL65    IF INSTRUCTION VALID ON ANY PROCESSOR
          BX5    X2*X4
          SX6    B1 
          NZ     X5,CTL65    IF INSTRUCTION VALID ON THIS PROCESSOR 
          SA6    EFLG 
          SA6    OERR        OPCODE ERROR 
          SA6    MACHFLG
          EQ     CTL65
 CTLBC    EJECT 
**        PROCESS BC INSTRUCTION. 
  
  
 CTLBC    SX1    16 
          RJ     YPRLOC      PROCESS LOCATION 
          SX1    16 
          RJ     UPPOS       UP POSITION COUNTER
          SA1    OPTYPE      CHECK INSTRUCTION
          MX2    -3 
          LX1    -27
          BX6    -X2*X1 
          NZ     X6,CTLBC1   IF NOT TYPE 0
          LX1    5           CHECK NAD EXTENSION
          MX6    -5 
          BX6    -X6*X1 
          ZR     X6,CTLBC1   IF NOT NAD EXTENSION 
          IX6    X6-X2       TYPE = 7 + NAD EXTENSION 
          SB2    X6-/PASS2/ZBCAL
          NG     B2,CTLBC1
          SX6    B0 
 CTLBC1   SA1    /PASS2/ZBCA+X6 CHECK ADDRESS FIELD CONTROL 
          BX6    X1 
          SA6    P1TEMPA
          SA6    P1TEMPB
 CTLBC2   SX1    60          SCAN FOR LITERALS
          RJ     SCAD 
          SA1    P1TEMPB     CHECK ADDRESS FIELD DESCRIPTOR 
          LX6    X1,B1
          SA6    A1 
          NG     X1,CTLBC2   IF MORE ADDRESS FIELDS 
          SA1    P1TEMPA     ADVANCE OVER INSTRUCTION WORDS 
          AX1    36 
          SX1    X1 
          RJ     UPPOS
          SA2    EXSTOP      CHECK FOR EXTRA ADDRESS FIELD
          ZR     X2,CTL65 
          SX6    B1          SET 8-ERR FOR EXTRA ADDRESS FIELD
          SA6    EFLG 
          SA6    W8ERR
          EQ     CTL65
  
          VFD    3/1,1/0,29/5,27/ MASK FOR BAD 180 INSTRUCTION
          VFD    3/1,1/1,29/0,27/ MASK FOR BAD MC INSTRUCTION 
 CTLPPM   VFD    3/1,1/1,29/6,27/ MASK FOR BAD BC INSTRUCTION 
          VFD    3/1,30/5,27/     MASK FOR BAD PP INSTRUCTION 
          VFD    3/1,1/0,29/5,27/ MASK FOR BAD 7000 PPU INSTRUCTION 
 CTLMC    SPACE  4,30 
**        PROCESS MC INSTRUCTION. 
  
  
 CTLMC    SX1    8
          RJ     YPRLOC      PROCESS LOCATION 
          SX1    8
          RJ     UPPOS       UP POSITION COUNTER
          SX1    60          SCAN ADDRESS 
          RJ     SCAD 
          SA2    OPTYPE 
          MX6    -3 
          AX2    27 
          BX2    -X6*X2 
          SX1    8
          ZR     X2,CMC2     IF NO ADDRESS
          LX2    59 
          NG     X2,CMC1     IF 8-BIT ADDRESS 
          SX1    16 
 CMC1     RJ     UPPOS       UP POSITION COUNTER
 CMC2     SA2    EXSTOP      CHECK FOR EXTRA ADDRESS FIELD
          ZR     X2,CTL65 
          SX6    B1          SET 8-ERR FOR EXTRA ADDRESS FIELD
          SA6    EFLG 
          SA6    W8ERR
          JP     CTL65
 CTLPP    EJECT  4                                                       CPSA097
**        PROCESS PP INSTRUCTION. 
  
  
 CTLPPER  SA4    PPTYPE      FORCE BAD PP INSTRUCTION 
          SA2    CTLPPM+1+X4
          SX7    B1 
          BX6    X2 
          SA6    OPTYPE 
          SA7    OERR        POST OP-CODE ERROR 
          SA7    EFLG 
  
 CTLPP    SA1    LWORD
          SA4    PPTYPE 
          SA2    OPTYPE 
          SB7    X4+3 
          LX2    3
          ZR     B7,CTLPP0
          BX6    X2-X4
          NG     X6,CTLPPER  IF PP IN BCU OR BC IN PPU CODE 
          SB7    X4+2 
          ZR     B7,CTLMC    IF MC INSTRUCTION
          SX4    X4+B1
          ZR     X4,CTLBC    IF BC INSTRUCTION
 CTLPP0   BSS    0
          RJ     YPRLOC      PROCESS LOCATION 
          SA1    LWORD
          RJ     UPPOS       UP POSITION COUNTER
          SA2    OPTYPE 
          SA1    LWORD
          LX2    32 
          PL     X2,CTLPP1   JUMP IF 12-BIT OP
          RJ     UPPOS
          SX1    60 
          RJ     SCAD 
          SA1    OPTYPE 
          AX1    27 
          SX2    5
          BX6    X2*X1
          BX6    X6-X2
          NZ     X6,CTLPP2   IF NO SECOND FIELD 
 CTLPP1   SX1    60          CHECK FOR POSSIBLE LITERALS
          RJ     SCAD 
 CTLPP2   SA2    EXSTOP      CHECK FOR EXTRA ADDRESS FIELD
          ZR     X2,CTLCP8
          SX6    B1          SET 8-ERR FOR EXTRA ADDRESS FIELD
          SA6    EFLG 
          SA6    W8ERR
          EQ     CTLCP8      GO CHECK MACHINE TYPE
  
 PASS2    TITLE  PASS 2 CONTROL.
**        PASS 2 CONTROL. 
  
  
          QUAL   PASS2
 PASS2    RJ     PRS         PRESET CONSTANTS 
          RJ     PLM         PRINT LOAD MAP 
          RJ     PLO         PRESET LIST OPTIONS
          RJ     SUO         SET USE ORIGINS
          RJ     URS         UNDEFINE REDEFINABLE SYMBOLS 
  
**        SEARCH FOR IDENT CARD.
  
 SFI      RJ     RINTER      READ IN PRESUMED IDENT LINE
          RJ     SETUP
          SA2    IOP         CHECK FOR IDENT OPCODE 
          SA3    =0RIDENT 
          BX6    X2-X3
          ZR     X6,SFI2     IF LINE IS IDENT 
          SX3    3REND
          BX4    X3-X2
          ZR     X4,SFI1     IF END OF PROGRAM
          RJ     LISTER 
          EQ     SFI         LOOP 
 SFI1     SX6    B1 
          SA6    OERR 
          SA6    EFLG 
          JOBMSG (=C* IDENT STATEMENT MISSING.*),R
 SFI2     MX6    0           SET DEFAULT (0,0) OVERLAY
          SX1    B0                                                     S002  36
          RJ     SIC         SCAN IDENT CARD
          SA1    P2TEMP      DUMP LOADER INFORMATION                    S002  38
          SA2    A1+B1                                                  S002  39
          BX6    X1                                                     S002  40
          SA6    IDNAM       RESET IDNAM IN CASE OF TRUNCATION          S002  41
          RJ     DFIRST 
          RJ     DLT         DUMP LITERAL TABLES
          RJ     SMO         SET MAX AND MIN ORIGINS
          SA1    IOP
          SA2    =0RIDENT 
          BX3    X1-X2
          NZ     X3,Z101     BYPASS FIRST RINTER IF NOT IDENT 
          RJ     LISTER      LIST IDENT CARD
          SA1    IDNAM       DISPLAY IDENT MESSAGE
          RJ     DIM
          RJ     CRL         CHECK RECURSION LIMIT                      S004   9
 Z100     SPACE  4
**        Z100 - GENERAL PASS 2 PROCESSING. 
  
  
 Z100     RJ     RINTER      READ INTERMEDIATE FILE 
 Z101     RJ     SETUP       AND SET THE LINE UP
          SA1    STYPE       CHECK FOR COMMENTS CARD OR 
          SA2    TXTFLG      TEXT DEFINITION CARD OR IFSKIPS
          SA3    NOAS 
          SX0    X1-1R* 
          IX2    X3+X2
          ZR     X0,ZLIST    COMMENTS CARD
          NZ     X2,ZLIST    BYPASSED CARD
          SA1    POSCTR 
          NZ     X1,Z110
          RJ     ZFOUP
 Z110     SA1    OPTYPE 
          SX0    7
          SB6    X1          POSSIBLE TRANSFER ADDRESS
          AX1    57 
          BX2    X1*X0
          SX6    B1 
          SB7    X2 
          JP     *+1+B7 
  
 +        SA6    IFCDGP      TYPE 0 - CP MACHINE OPS
          EQ     ZCP
 +        SA6    IFCDGP      TYPE 1 - PP MACHINE OPS
          EQ     ZPP
 +        SA6    IFCDGP      TYPE 2 - NORMAL PSEUDOS
          JP     B6 
 +        SA6    IFCDGP      TYPE 3 - PSEUDOS TO PROCESS WHILE
          JP     B6          IF SKIPPING
 +        JP     B6          TYPE 4 - PERMISSIBLE ANYWHERE
 +        SA1    IFCDGP      TYPE 5 - FIRST CARD GROUP ONLY 
          EQ     ZT5
 +        EQ     ZMACALL     TYPE 6 - MACRO CALL
 +        EQ     ZMACALL     TYPE 7 - MACRO CALL
 ZT5      SPACE  4
**        ENTRY ON TYPE 5 PSEUDO-OPS. 
  
  
 ZT5      NZ     X1,ZLIST    IF CARD IS OUT OF PLACE
          JP     B6          JUMP TO PROCESSOR
 RJZ      SPACE  4
**        SCAN INSTRUCTION FOR SCAD WHILE IN PASS 2.
  
  
 RJZ      SA1    EXLGN       INITIALIZED RJ INSTRUCTION FOR SCAD
          RJ     ZEVITEM
 ZCP      EJECT  4                                                       CPSA097
*         CENTRAL PROCESSOR INSTRUCTIONS. 
  
  
 ZCP      SA1    OPTYPE      FETCH OP-CODE EQUIVALENT FROM PASS 1 
          MX0    57 
          AX1    18 
          BX6    -X0*X1      EXTRACT REGISTER FIELDS
          AX1    3
          BX7    -X0*X1 
          SA6    OPADS
          SA7    A6+B1
          AX1    3
          BX6    -X0*X1 
          SX0    B1 
          AX1    3
          BX7    X1*X0       30-BIT INSTRUCTION FLAG TO OPASS+3 
          SA6    A7+B1
          SA7    A6+B1
          AX1    1           FORCE UPPER TO OPADS+4 
          BX6    X1*X0
          AX1    1
          BX7    X0*X1       FORCE NEXT UPPER TO OPADS+5
          SA6    A7+B1
          SA7    A6+B1
          SA2    NFOUP
          BX6    X2+X6
          SA6    A2          OR NFOUP INTO THIS UPPER FORCE 
          AX1    48-29
          NZ     X1,ZCP0     IF NOT 00 INSTRUCTION
          SA1    OERR 
          SA2    LOCSYM      SET SUB-SUBTITLE 
          NZ     X1,ZCP0     IF UNDEFINED OPCODE
          BX6    X2 
          SA6    SUBNAME
 ZCP0     SA3    OPADS+3     PROCESS LOCATION FIELD 
          BX4    X3          CONSTRUCT A 15 OR 30 
          LX3    4
          IX4    X3-X4
          SX1    X4+15
          RJ     ZPRLOC      PROCESS LOCATION FIELD 
          SA1    OPADS+5     RESET NFOUP FOR NEXT INSTUCTION
          BX6    X1 
          MX7    0
          SA6    NFOUP
          SA7    P2TEMP      FOR REGISTER ACCUMULATION
          SA7    A7+B1       P2TEMPA
          SA7    A7+B1       P2TEMPB
          SA7    EXERR                                                  P085   8
          SA1    OPTYPE      SET OPERATION CODE VALUE 
          AX1    48 
          BX6    X1 
          LX6    6
          SA6    OPVAL
          SA2    MACHFLG
          NZ     X2,ZCP0A    IF *MACHINE* VIOLATION 
          SA2    OERR        CHECK IF PASS 1 FOUND AN ERROR 
          NZ     X2,ZCP100A 
  
 ZCP0A    SA2    COL
          SX6    X2+B1
          SA6    COLUMN 
          RJ     GETCH
          SB7    X1-3        TEST FOR A REGISTER
          SB6    X1-1RX 
          NG     B7,ZCP3A    IF A OR B
          ZR     B6,ZCP3A    IF X 
 ZCP3     RJ     GETCH
          EQ     ZCP3B
 ZCP3A    SX1    3
          RJ     ZEVITEM     EVALUATE OPCODE REGISTER 
          SA1    ELREG
          BX6    X1 
 +        SA2    OPVAL       GET UPPER 9 BITS OF OP CODE SHIFTED LEFT 6 
          AX2    12 
          SB7    X2-5 
          NZ     B7,ZCP3C    IF NOT AN SAI INSTRUCTION (5X0)
          MX0    -3 
          BX7    -X0*X1 
          SB7    X7-6 
          MI     B7,ZCP3C    IF NOT REGISTER 6 OR 7 
          SX7    1RS
          SA7    REFLET 
 ZCP3C    SA6    P2TEMPB     SAVE REGISTER LETTER AND NUMBER
          SA1    CHAR 
 ZCP3B    SB7    X1-1R
          SB6    B0          FLAG TO INDICATE BEGIN TO SCAN VARIABLES.
          NZ     B7,ZCP1A    IF NOT END OF OPCODE FIELD 
 ZCP1     SA1    P2TEMPA
          NZ     X1,ZCP2     IF END OF VARIABLE FIELD 
          SA2    COL+1
          BX6    X2          RESET TO VARIABLE FIELD
          SA6    A1 
          SA6    COLUMN 
 ZCP1A    RJ     GETCH
          EQ     B6,B0,ZCP1B IF BEGINNING SCAN OF VARIABLES.
          SA2    CHAR        ELSE CONTINUING SCAN. CHECK FIRST CHAR.
          SB7    X2-1R
          ZR     B7,ZCP2     IF FIRST CHAR OF VARIABLE FIELD IS BLANK.
 ZCP1B    SA2    OPADS+3
          SX1    6
          ZR     X2,*+1 
          SX1    18 
          RJ     SCAD 
          SA4    EXREG       TEST FOR A REGISTER FIELD
          ZR     X4,ZCP2     JUMP IF ADDRESS FIELD
          SA2    P2TEMP      COMBINE REGISTER FIELDS
          LX2    9
          BX6    X4+X2
          SA6    A2 
          SB7    X1-1R       TEST FOR END OF ADDRESS FIELD
          NZ     B7,ZCP1B    IF MORE REGISTERS
          SB6    B1          FLAG TO INDICATE CONTINUE SCAN OF VARIABLES
          EQ     ZCP1        IF BLANK 
 ZCP2     SX6    1R 
          SA6    REFLET 
          SA1    P2TEMPB
          SA2    P2TEMP      OR OPCODE REGISTER INTO REGISTERS
          LX2    9
          BX1    X1+X2
          SA2    OPADS
          SA3    OPVAL
          BX6    X3 
          MX0    57 
          SB3    3
          SB5    B0 
          SB4    9
 ZCP4     LX3    X2,B3
          IX4    X3+X2       COMBINE REGISTERS INTO OP CODE 
          SB7    X4 
          SB6    B7-B4
          AX3    X1,B6
          BX4    -X0*X3 
          LX5    X4,B5
          SA2    A2+B1
 +        SB5    B5+B3
          ZR     B7,*+1 
          BX6    X5+X6
          NE     B5,B4,ZCP4 
          SA4    EXVAL
          SA5    A4+B1       EXREL
          SA1    A5+B1       EXEXT
          NZ     X2,ZCP100   IF 30-BIT INSTRUCTION
          MX0    54 
          PL     X4,ZCP6     IF POSITIVE Q
          SX2    60 
          IX4    X4+X2       TRY Q + 60 
          PL     X4,ZCP6     IF Q IN RANGE
          IX4    X4-X2
          SX7    B1 
          SA7    W7ERR
          SA7    EFLG 
 ZCP6     BX4    -X0*X4      TRUNCATE ADDRESS TO 6 BITS 
          IX6    X6+X4       OR INTO INSTRUCTION
          SA6    OPVAL       AND SAVE 
          BX1    X5+X1       DISAPPROVE OF EXT OR REL 
          SX7    B1 
          ZR     X1,ZCP5     COMPLAIN IF RELOCATABLE OR EXTERNAL
          SA7    AERR 
          SA7    EFLG 
 ZCP5     SX1    15 
          RJ     UPPOS       CALL UPPOS(15) 
          SA1    OPVAL
          SA2    POSCTR      CONSTRUCT PRINT LINE 
          SX3    5
          SX4    3
          IX2    X2/X4
          SX4    36 
          IX2    X4-X2
          RJ     PACKO
          SA1    OPVAL
          SX2    15 
          SX3    B0 
          MX4    0
          RJ     BINOUT      OUTPUT INSTRUCTION 
          EQ     ZLISTG      AND GO LIST
  
 ZCP100   LX6    15          30-BIT INSTRUCTIONS
          MX0    42 
          BX2    -X0*X4      TRUNCATE ADDRESS TO 18-BITS
          IX6    X2+X6
          SA6    OPVAL
          AX4    18 
          SX6    B1 
          ZR     X4,ZCP100A  IF NO ADDRESS OVERFLOW 
          SA6    W7ERR
          SA6    EFLG 
 ZCP100A  SX1    12 
          RJ     UPPOS       CALL UPPOS (12)
          SA1    OPVAL
          SX2    12 
          BX3    X3-X3
          SX4    B0 
          AX1    18 
          RJ     BINOUT      CALL BINOUT (OPVAL/2**18, 12, 0, 0)
          SX1    18 
          RJ     UPPOS       CALL UPPOS (18)
          SA1    OPVAL
          SX2    18 
          SA3    EXREL
          SA4    EXEXT
          RJ     BINOUT      CALL BINOUT (OPVAL, 18, EXREL, EXEXT)
          SA1    OPVAL
          SA2    POSCTR 
          SX0    3
          IX2    X2/X0
          SX3    10 
          SX5    36 
          IX2    X5-X2
          RJ     PACKOR      CALL PACKOR(OPVAL,36-POSCTR/3,10)
 ZLISTG   SPACE  4
**        ZLISTG - LIST CODE-GENERATED LINES. 
  
  
 ZLISTG   RJ     LISTERG
          EQ     Z100 
 ZPP      EJECT  4                                                       CPSA097
**        PP INSTRUCTIONS.
  
  
 ZPP      SA1    LWORD       PROCESS LOCATION FIELD 
          SA4    PPTYPE 
          SB7    X4+2 
          ZR     B7,ZMC      IF MICROPROCESSOR
          SX4    X4+B1
          ZR     X4,ZBC      IF BUFFER CONTROLLER.
          RJ     ZPRLOC      PROCESS LOCATION SYMBOL
          SA1    OPTYPE 
          MX0    -16         ISOLATE 16-BIT OPCODE
          BX7    -X0*X1 
          AX1    27          EXTRACT CONTROL DIGIT
          SX0    B1 
          SA7    OPVAL
          SA2    PSIM        PERIPHERAL STORE INSTRUCTION MASK
          AX7    6           GET 6-BIT OP CODE
          SB7    X7 
          LX2    B7 
          PL     X2,ZPP1     IF NOT A STORE INSTRUCTION 
          SX6    1RS
          SA6    REFLET 
 ZPP1     BX6    X0*X1
          AX1    1
          SX0    3           TYPE OF ADDRESS FIELD
          BX7    X0*X1
          SA6    OPADS       24-BIT FLAG
          SA7    A6+B1
          NZ     X6,ZPP100   IF 24-BIT INSTRUCTION
          SX1    6
          SX6    B7 
          AX6    2
          SB7    X6-44BS-2
          NZ     B7,ZPP1A    IF NOT A STORE INSTRUCTION 
          SX6    1RI
          SA6    REFLET 
 ZPP1A    SB7    X7 
          NE     B7,B1,ZPP1B IF NOT TYPE 2
          SA1    PPMEMSZ     12-4K, 13-8K, 14-16K MEMORY SIZES
 ZPP1B    BSS    0
          RJ     SCAD        SCAN ADDRESS FOR 12-BIT OPCODE 
          SX6    1R 
          SA6    REFLET 
          SA1    OPADS+1
          SB7    X1 
          JP     B7+*        JUMP ON ADDRESS TYPE 
  
 +        SA1    EXVAL       TYPE 2 - RELATIVE BETWEEN 32 AND -32 
          EQ     ZPP21
 +        SA1    EXVAL       TYPE 4 - DIRECT CORE (0-63)
          EQ     ZPP22
 +        SA1    EXVAL       TYPE 6 - ABSOLUTE BETWEEN -32, +32 
          EQ     ZPP23
  
 ZPP21    SA3    LOCCTR 
          SA4    PPJUMP 
          NZ     X4,ZP21A    IF PPJUMP SET
          BX2    X1 
          AX2    5           CHECK FOR BETWEEN +32 AND -32
          ZR     X2,ZPP24 
 ZP21A    IX1    X1-X3
 ZPP23    BX2    X1 
          AX2    5
          ZR     X2,ZPP24 
 ZPP25    SX6    B1          BAD ADDRESS FIELD
          SA6    AERR 
          SA6    EFLG 
 ZPP24    MX0    54 
          BX1    -X0*X1      TRUNCATE TO 6 BITS 
          SA2    OPVAL
          IX6    X1+X2
          SA6    A2 
          SA1    LWORD
          RJ     UPPOS       CALL UPPOS(12) 
          SA1    OPVAL
          SX2    25 
          SA3    PPBYT
          RJ     PACKO       CALL PACKO(OPVAL,25,4) 
          SA1    OPVAL
          SA2    LWORD
          SX3    B0 
          BX4    X3 
          RJ     BINOUT      CALL BINOUT(OPVAL,12,0,0)
          EQ     ZLISTG 
 ZPP22    NG     X1,ZPP25    COMPLAIN IF ADDRESS NEGATIVE 
          SB7    X1-64       CHECK FOR EXCESS OF 63 
          PL     B7,ZPP25 
          SA2    OPVAL       CURRENT OPCODE 
          SA3    PSIM2       INSTRUCTION MASK FOR STORES THAT PREFETCH
          AX2    6            ERROR MAY BE FLAGGED
          SB7    X2 
          LX3    X3,B7
          PL     X3,ZPP24    IF NOT TO CHECK FOR PREFETCH ERROR 
          SX6    B1 
          SA3    LOCCTR      CHECK IF STORING AT *+1
          IX3    X3-X1
          SX3    X3+B1
          NZ     X3,ZPP24    IF NOT *+1 
          SA6    EFLG 
          SA6    WD45ERR     + ERROR
          EQ     ZPP24
  
*         24-BIT PP INSTRUCTIONS. 
  
 ZPP100   SA4    OPVAL       SHIFT OPVALUE LEFT 18 BITS 
          BX7    X4 
          LX7    18 
          SA7    A4 
          SX1    18          SET FOR ADDRESS SIZE = 18
          SA2    OPADS+1
          SX2    X2-1 
          ZR     X2,ZPP101   IF TYPE 3 INSTRUCTION
          SA1    PPMEMSZ     12-4K, 13-8K, 14-16K MEMORY SIZES
          SA3    PPTYPE      MUST SPECIAL-CASE *FNCL* INSTRUCTION 
          SX3    X3+3 
          NZ     X3,ZPP101   IF NOT 180 PPU ASSEMBLY
          SX4    X4-FNCLCDE 
          NZ     X4,ZPP101   IF NOT *FNCL* INSTRUCTION
          SX1    16          SET *FNCL* ADDRESS SIZE = 16 
 ZPP101   RJ     SCAD        EVALUATE FIRST ADDRESS FIELD 
          SX6    1R 
          SA6    REFLET 
          SA1    OPADS+1
          SB7    X1 
          SA2    EXVAL
          JP     *+1+B7 
  
 +        MX0    -16         TYPE 1 - MEMORY (16 BIT) ADDRESS 
          BX2    -X0*X2      WITH NO SECOND FIELD 
          EQ     ZPP104 
 +        MX0    42          TYPE 3 - CONSTANT (18 BIT) ADDRESS 
          BX2    -X0*X2 
          EQ     ZPP104 
 +        MX0    -16         TYPE 5 - MEMORY (16 BIT) ADDRESS 
          BX6    -X0*X2      WITH OPTIONAL SECOND FIELD 
          EQ     ZPP102 
 +        SA1    CHAR        TYPE 7 - MEMORY (12 BIT) ADDRESS 
          SB7    X1-1R       WITH MANDATORY SECOND ADDRESS
  
          NZ     B7,ZPP105   IF CHANNEL NUMBER IS PRESENT 
          SX6    B1          SET MISSING ADDRESS ERROR
          SA6    EFLG 
          SA6    W8ERR
 ZPP105   MX0    -16
          BX6    -X0*X2 
 ZPP102   SA6    P2TEMP 
          SA2    OPVAL       CURRENT OPCODE 
          SA3    PSIM2       INSTRUCTION MASK FOR STORES THAT PREFETCH
          AX2    6+18         ERROR MAY BE FLAGGED
          SB7    X2 
          LX3    X3,B7
          PL     X3,ZPP102A  IF NOT TO CHECK FOR PREFETCH ERROR 
          SA4    LOCCTR      CHECK IF STORING AT *+2
          IX4    X4-X6
          SX7    B1 
          SX4    X4+2 
          NZ     X4,ZPP102A  IF NOT *+2 
          SA7    EFLG 
          SA7    WD45ERR     + ERROR
 ZPP102A  SX1    6
          RJ     SCAD        EVALUATE SECOND ADDRESS
          SA1    EXVAL
          PL     X1,ZPP103
          SX6    B1          POST ADDRESS FIELD OVERFLOW
          SA6    EFLG 
          SA6    W7ERR
 ZPP103   MX0    54 
          BX1    -X0*X1      TRUNCATE TO 6 BITS 
          SA2    P2TEMP 
          LX1    18 
          BX2    X2+X1       OR DIRECT REFERENCE INTO OP
 ZPP104   SA3    OPADS+1
          SX3    X3-1 
          NZ     X3,ZPP104A  IF NOT 18-BIT CONSTANT ADDRESS 
          MX6    -12         MOVE UPPER 6 BITS OF ADDRESS FIELD 
          BX1    -X6*X2       INTO SECOND ADDRESS FIELD 
          BX6    X6*X2
          LX6    6
          BX2    X6+X1
 ZPP104A  SA1    OPVAL       SET UP TO OUTPUT 24 OR 32-BIT INSTR
          BX6    X1+X2
          SA6    A1 
          AX6    18 
          SA6    P2TEMP 
          SA1    LWORD
          RJ     UPPOS       CALL UPPOS(12) 
          SA1    P2TEMP 
          SX2    25 
          SA3    PPBYT
          RJ     PACKO       CALL PACKO(HIGH 12 BITS,25,4)
          SA1    P2TEMP 
          SA2    LWORD
          MX3    0
          BX4    X3 
          RJ     BINOUT      CALL BINOUT(HIGH 12 BITS,12,0,0) 
          RJ     DWORD       DUMP THIS WORD 
          SA1    LWORD
          RJ     UPPOS       CALL UPPOS(12) 
          SA1    OPVAL
          SX2    30 
          MX3    -18
          BX1    -X3*X1 
          SA4    PPTYPE 
          SX4    X4+3 
          NZ     X4,ZPP106   IF NOT 180 PP ASSEMBLY 
          SX2    32 
 ZPP106   SA3    PPBYT
          RJ     PACKO       CALL PACKO(LO 12 BITS,30,4)
          SA1    OPVAL
          SA2    LWORD
          MX3    0
          BX4    X3 
          RJ     BINOUT      CALL BINOUT(LO 12 BITS,12,0,0) 
          EQ     ZLISTG 
 ZBC      EJECT 
**        BC INSTRUCTIONS.
  
  
 ZBC      SX1    16          PROCESS LOCATION FIELD 
          RJ     ZPRLOC      PRLOC(16)
          SA1    OPTYPE 
          MX0    -16         ISOLATE 16-BIT OP CODE 
          BX7    -X0*X1 
          LX1    -27
          MX2    -3 
          SA7    OPVAL
          BX6    -X2*X1 
          NZ     X6,ZBC0     IF NOT TYPE 0
          MX6    -5          MASK FOR NAD EXTENSION 
          LX1    5           CHECK NAD EXTENSION
          BX6    -X6*X1 
          ZR     X6,ZBC0     IF NOT NAD EXTENSION 
          IX6    X6-X2       TYPE = 7 + NAD EXTENSION 
          SB2    X6-ZBCAL 
          NG     B2,ZBC0
          SX6    B0 
 ZBC0     SA1    ZBCA+X6     EXTRACT FIRST ADDRESS FIELD WIDTH
          BX6    X1 
          SA6    OPADS       TYPE FLAG
          AX1    18 
          SX1    X1 
          RJ     SCAD        SCAN ADDRESS FIELD 
          SA3    OPADS       CHECK TYPE 
          SA2    EXVAL       SAVE VALUE 
          BX6    X2 
          SX1    16 
          SA6    A3+B1
 +        PL     X3,*+1      IF NO SECOND FIELD 
          RJ     SCAD 
          SA1    OPADS       CHECK TYPE 
          SA3    OPVAL       (X3) = OPCODE VALUE
          SA2    A1+B1       (X2) = FIRST ADDRESS VALUE 
          SA4    EXVAL       (X4) = SECOND ADDRESS VALUE
          MX0    -4          (X0) = FIELD WIDTH MASK
          SB7    X1 
          SB6    B0          (B6) = SHIFT COUNT 
          JP     B7          JUMP ON ADDRESS TYPE 
  
  
**        0 - 4-BIT ADDRESS.  (SAB) 
  
 ZBC1     BX7    X0*X2       CHECK FOR EXCESS 
          ZR     X7,ZBC3     IF NOT OVER FIELD WIDTH
  
  
**        PROCESS *A* ERROR.
  
 ZBC2     SX6    B1          SET *A* ERROR
          SA6    AERR 
          SA6    EFLG 
  
  
**        FORM INSTRUCTION. 
  
 ZBC3     BX6    -X0*X2      TRUNCATE ADDRESS 
          LX6    X6,B6       POSITION FIELD 
          IX6    X6+X3
          SA6    OPVAL
 ZBC4     SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,16,0,0)
          SX2    16 
          MX3    0
          BX4    X4-X4
          RJ     BINOUT 
          EQ     ZLISTG      RETURN 
  
  
**        1 - (16 - 4-BIT) ADDRESS.  (SLC)
  
 ZBC5     SX6    16 
          ZR     X2,ZBC1     IF NO SHIFT
          IX2    X6-X2
          JP     ZBC1 
  
  
**        2 - (15 - 4-BIT) ADDRESS.  (TAB)
  
 ZBC6     SX6    15 
          IX2    X6-X2
          JP     ZBC1 
  
  
**        3 - 8-BIT ADDRESS.  (ADN) 
  
 ZBC7     MX0    -8 
          JP     ZBC1 
  
  
**        4 - 9-BIT RELATIVE ADDRESS.  (UJR)
  
 ZBC8     BX1    X2          CALL PACKO(VALUE,34,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SA2    OPADS+1
          SA3    OPVAL
          SA4    LOCCTR 
          SB6    B0 
          IX2    X2-X4
          MX0    -8 
          PL     X2,ZBC1     IF JUMP FORWARD
          SX3    X3+0#0400
          BX2    -X2
          JP     ZBC1 
  
  
**        5 - 4-BIT CHANNEL AND NO ADDRESS.  (IAN)
  
 ZBC9     SB6    4           SET SHIFT COUNT
          JP     ZBC1 
  
  
**        6 - 8-BIT ADDRESS AND OPTIONAL INDEXING.  (LDD) (UJI) 
  
 ZBC10    MX0    8
          NG     X4,ZBC2     IF NEGATIVE INDEX
          SB7    X4-3 
          PL     B7,ZBC2     IF INDEX .GE. 3
          LX4    8           MERGE INDEX REGISTER WITH OPVAL
          IX6    X3+X4
          IX3    X3+X4
          SA6    OPVAL
          LX6    -11
          PL     X6,ZBC1     IF NOT INDIRECT
          BX1    -X0*X2      EXTRACT DIRECT CELL
          RJ     RBV         READ BINARY VALUE
          BX1    X6 
          ZR     X6,ZBC11    IF NO INDIRECT VALUE 
          SX2    30 
          SX3    4
          RJ     PACKO
 ZBC11    SA3    OPVAL
          SA2    OPADS+1
          SB6    B0 
          MX0    -8 
          JP     ZBC1 
  
  
**        7 - 4-BIT CHANNEL AND 4-BIT ADDRESS.  (INT) 
  
 ZBC12    BX7    -X0*X4      CHECK 2ND FIELD
          BX6    X0*X4
          SB6    4
          IX3    X3+X7
          ZR     X6,ZBC1     IF NO ADDRESS OVERFLOW 
          JP     ZBC2 
  
**        8 - 1-BIT ADDRESS.  (JFA) 
  
 ZBC8.0   EQU    ZBC4 
  
  
  
**        9 - 8-BIT RELATIVE ADDRESS BACKWARDS.  (RTB)
  
 ZBC9.0   BX1    X2          CALL PACKO(VALUE,34,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SA2    OPADS+1
          SA3    OPVAL
          SA4    LOCCTR 
          SB6    B0 
          IX2    X2-X4
          MX0    -8 
          PL     X2,ZBC2     IF JUMP FORWARD
          BX2    -X2
          JP     ZBC1 
  
**        10 - 12-BIT ADDRESS.  (FNA) 
  
 ZBC10.0  MX0    -12
          JP     ZBC1 
  
  
**        11 - 2 16-BIT ADDRESS I/O.
  
 ZBC11.0  BX6    X4          SAVE 2ND ADDRESS FIELD 
          SA1    CHAR        CHECK 3RD ADDRESS
          SA6    OPADS+2
          SB2    X1-1R
          ZR     B2,ZBC11.1  IF NO 3RD ADDRESS
          SX1    2           SCAN 3RD ADDRESS 
          RJ     SCAD 
          SA1    EXVAL       ENTER PARITY CONTROL 
          SA2    OPVAL
          MX3    -2 
          BX1    -X3*X1 
          LX1    4           POSITION PARITY CONTROL BITS IN INSTRUCTION
          BX6    X1+X2
          SA1    CHAR        CHECK 4TH FIELD
          SA6    A2 
          SB2    X1-1R
          ZR     B2,ZBC11.1  IF NO 4TH ADDRESS
          SX1    2           SCAN 4TH ADDRESS 
          RJ     SCAD 
          SA1    EXVAL       ENTER MODE 
          SA2    OPVAL
          MX3    -2 
          BX1    -X3*X1 
          BX6    X1+X2
          SA6    A2 
          JP     ZBC11.2
 ZBC11.1  SX6    B1          SET A-ERROR
          SA6    AERR 
          SA6    EFLG 
 ZBC11.2  SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+1     CALL PACKO(OPADS+1,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+1     CALL BINOUT(OPADS+1,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+2     CALL PACKO(OPADS+2,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+2     CALL BINOUT(OPADS+2,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SX1    0           CALL PACKO(0,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SX1    0           CALL BINOUT(0,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
**        12 - 2 16-BIT ADDRESS.  (QCL) 
  
 ZBC12.0  SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+1     CALL PACKO(OPADS+1,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+1     CALL BINOUT(OPADS+1,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    EXVAL       CALL PACKO(EXVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    EXVAL       CALL BINOUT(EXVAL,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
**        13 - 7-BIT RELATIVE ADDRESS.  (L1R) 
  
 ZBC13.0  BX1    X2          CALL PACKO(VALUE,34,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SA2    OPADS+1
          SA3    OPVAL
          SA4    LOCCTR 
          SB6    B0 
          IX2    X2-X4
          MX0    -7 
          PL     X2,ZBC1     IF JUMP FORWARD
          SX3    X3+0#0080
          BX2    -X2
          JP     ZBC1 
  
**        14 - 16 BIT INSTRUCTION AND 16 BIT ADDRESS (LJM)
  
 ZBC14.0  SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+1     CALL PACKO(OPADS+1,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+1     CALL BINOUT(OPADS+1,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
**        15 - 16 BIT INSTRUCTION WITH 3 16 BIT ADDRESS FIELDS (QGT)
  
 ZBC15.0  BX6    X4          SAVE 2ND ADDRESS FIELD 
          SA1    CHAR        CHECK 3RD ADDRESS
          SA6    OPADS+2
          SB2    X1-1R
          ZR     B2,ZBC15.1  IF NO 3RD ADDRESS
          SX1    16           SCAN 3RD ADDRESS
          RJ     SCAD 
          SA1    EXVAL       ENTER MODE 
          MX3    -16
          BX1    -X3*X1 
          BX6    X1 
          SA6    OPADS+3
          JP     ZBC15.2
 ZBC15.1  SX6    B1          SET A-ERROR
          SA6    AERR 
          SA6    EFLG 
 ZBC15.2  SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+1     CALL PACKO(OPADS+1,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+1     CALL BINOUT(OPADS+1,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+2     CALL PACKO(OPADS+2,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+2     CALL BINOUT(OPADS+2,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+3     CALL PACKO(OPADS+3,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+3     CALL BINOUT(OPADS+3,16,0,0)
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
  
**        16 - 4 BIT ADDRESS AND 15-4 BIT FLAG (SCM)
  
 ZBC16.0  BX7    -X0*X4      CHECK SECOND FIELD 
          SX6    15 
          IX7    X6-X7       SUBTRACT 15 FROM FLAG
          BX6    X0*X4       CHECK ANY BITS GREATER THAN 4
          SB6    4
          IX3    X3+X7
          ZR     X6,ZBC1     CHECK FIRST FIELD
          JP     ZBC2        SET ERROR
  
**        17 - 16 BIT INSTRUCTION AND 16 BIT RELATIVE FORWARD 
  
 ZBC17.0  SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,25,4) 
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT (OPVAL,16,0,0) 
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     DWORD
          RJ     LISTERG     LIST LINE
  
          SX1    16          CALL UPPOS(16) 
          RJ     UPPOS
          SA1    OPADS+1     CALL PACKO(OPADS+1,25,4) 
          SA3    LOCCTR      LOAD LOCATION COUNTER
          IX1    X1-X3       CONVERT TO RELATIVE FORWARD
          MI     X1,ZBC2     IF BACKWARDS, SET ERROR
          SX2    25 
          SX3    4
          RJ     PACKO
          SA1    OPADS+1     CALL BINOUT(OPADS+1,16,0,0)
          SA4    LOCCTR      LOAD LOCATION COUNTER
          IX1    X1-X4       CONVERT TO RELATIVE
          MI     X1,ZBC2     IF BACKWARDS, SET ERROR
          SX2    16 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
  
  
 ZBCA     BSS    0
  
**        THE BIT LAYOUT OF THE INSTRUCTION FORMAT JUMP TABLE IS..
* 
*         BITS 59-56 = BIT DEFINES NUMBER OF ADDRESS FIELDS MINUS 1.
*         BITS 53-36 = INSTRUCTION LENGTH IN BITS MINUS 16. 
*         BITS 35-18 = WIDTH OF FIRST ADDRESS FIELD.
*         BITS 18-00 = ADDRESS OF NAD INSTRUCTION CREAKER.
* 
          LOC    0
  
          VFD    24/,18/4,18/ZBC1 
          VFD    24/,18/4,18/ZBC5 
          VFD    24/,18/4,18/ZBC6 
          VFD    24/,18/8,18/ZBC7 
  
          VFD    24/,18/16,18/ZBC8
          VFD    24/,18/4,18/ZBC9 
          VFD    1/1,23/,18/8,18/ZBC10
          VFD    1/1,23/,18/4,18/ZBC12
  
          VFD    4/0,20/0/,18/1,18/ZBC8.0 
          VFD    4/0,20/0/,18/16,18/ZBC9.0
          VFD    4/0,20/0/,18/12,18/ZBC10.0 
          VFD    4/16B,20/48,18/16,18/ZBC11.0 
  
          VFD    4/17B,20/32,18/16,18/ZBC12.0 
          VFD    4/0,20/0/,18/16,18/ZBC13.0 
          VFD    4/0,20/16,18/16,18/ZBC14.0 
          VFD    4/14B,20/48,18/16,18/ZBC15.0 
          VFD    1/1,23/,18/4,18/ZBC16.0
          VFD    4/0,20/16,18/16,18/ZBC17.0 
  
 ZBCAL    BSS    0
          LOC    *O 
 ZMC      SPACE  4,30 
**        MCU INSTRUCTIONS. 
  
  
 ZMC      SX1    8           PROCESS LOCATION FIELD 
          RJ     ZPRLOC 
          SA1    OPTYPE 
          MX0    -8          ISOLATE 8-BIT OP CODE
          BX7    -X0*X1 
          AX1    27          EXTRACT CONTROL DIGIT
          MX0    -3 
          SA7    OPVAL
          BX6    -X0*X1 
          SA1    ZMCA+X6     EXTRACT FIELD WIDTH
          BX6    X1 
          SA6    OPADS       TYPE FLAG
          AX1    48 
          ZR     X1,ZMC1     IF NO ADDRESS FIELD
          RJ     SCAD        SCAN ADDRESS FIELD 
 ZMC1     SX1    8           CALL UPPOS(8)
          RJ     UPPOS
          SA1    OPVAL       CALL PACKO(OPVAL,23,2) 
          SX2    23 
          SX3    2
          RJ     PACKO
          SA1    OPVAL       CALL BINOUT(OPVAL,8,0,0) 
          SX2    8
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          SA1    OPADS       CHECK TYPE 
          SA2    EXVAL       (X2) = ADDRESS VALUE 
          MX0    -8          (X0) = FIELD WIDTH 
          SB7    X1 
          JP     B7 
  
  
**        0 - NO ADDRESS FIELD. 
  
 ZMC2     EQU    ZLISTG      RETURN 
  
  
**        1 - 8-BIT ADDRESS FIELD.
  
 ZMC3     BX7    X0*X2       CHECK FOR EXCESS 
          ZR     X7,ZMC5     IF NOT OVER FIELD WIDTH
          BX7    -X0+X2 
          ZR     X7,ZMC5     IF NEGATIVE NUMBER WITHIN FIELD
  
  
**        PROCESS *A* ERROR.
  
 ZMC4     SX6    B1          SET *A* ERROR
          SA6    AERR 
          SA6    EFLG 
  
  
**        FORM ADDRESS FIELD. 
  
 ZMC5     BX6    -X0*X2      TRUNCATE ADDRESS 
          SA6    OPVAL
          RJ     DWORD       DUMP THIS WORD 
          SX1    8           CALL UPPOS(8)
          RJ     UPPOS
          SA3    OPADS       CALL PACKO(OPVAL,24+FW/4,FW/4) 
          SA1    OPVAL
          AX3    20 
          SX2    X3+24
          RJ     PACKO
          SA1    OPADS
          LX1    59-22
          PL     X1,ZMC6     IF 8-BIT FIELD 
          SA1    OPVAL       CALL BINOUT(HIBITS,8,0,0)
          SX2    8
          MX3    0
          BX4    X4-X4
          AX1    8
          RJ     BINOUT 
          RJ     DWORD
          SX1    8
          RJ     UPPOS       CALL UPPOS(8)
 ZMC6     SA1    OPVAL       CALL BINOUT(LOBITS,8,0,0)
          SX2    8
          MX3    0
          BX4    X4-X4
          RJ     BINOUT 
          JP     ZLISTG      RETURN 
  
  
**        2 - 16-BIT ADDRESS FIELD. 
  
  
 ZMC7     MX0    -16
          SA1    RMODE       CHECK FOR REVERSED ADDRESS 
          ZR     X1,ZMC3     IF NORMAL ADDRESS MODE 
  
          BX1    X2          CALL PACKO(VALUE,34,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SA2    EXVAL
          MX0    -16
          MX7    -8 
          BX1    -X7*X2      LSB
          AX2    8
          LX1    8
          BX7    -X7*X2      MSB
          LX2    8
          BX2    X0*X2       MERGE AFTER SWAPPING BYTES 
          BX2    X2+X7
          BX2    X2+X1
          JP     ZMC5 
  
**        3 - 8-BIT RELATIVE ADDRESS. 
  
 ZMC8     BX1    X2          CALL PACKO(VALUE,30,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SA2    EXVAL
          SA4    LOCCTR 
          SX6    B1+B1
          IX4    X4+X6
          IX2    X2-X4
          MX0    -7 
          PL     X2,ZMC3     IF JUMP FORWARD
          SX7    B1          CHANGE TO TWO COMPLEMENT NUMBER
          MX1    1
          BX2    -X1*X2 
          IX2    X2+X7
          BX4    -X0+X1 
          BX6    X4+X2
          MX0    -8 
          ZR     X6,ZMC5     IF NO OVERFLOW 
          JP     ZMC4 
  
 ZMCA     BSS    0
          VFD    12/0,30/0,18/ZMC2
          VFD    12/8,30/8,18/ZMC3
          VFD    12/16,30/16,18/ZMC7
          VFD    12/16,30/8,18/ZMC8 
 AMACALL  EJECT  4                                                       CPSA097
**        MACRO CALL. 
  
  
 ZMACALL  SA1    OPTYPE      SEE IF A LOCATION TERM SHOULD BE 
          SA2    LOCSYM      LISTED 
          LX1    2
          MI     X1,ZMCL1    IF TYPE 2 MACRO (LOCATION ARGUMENT)
          MX1    0
          ZR     X2,ZMCL1    IF NO LOCATION FIELD 
          RJ     ZPRLOC 
          EQ     ZMCL2
 ZMCL1    SA1    LWORD
          SA2    POSCTR 
          BX3    X1-X2
          NZ     X3,ZMCL2    IF POS " LWORD 
          RJ     LLA
 ZMCL2    SA1    EFLG        LIST IF ERROR
          NZ     X1,ZLIST 
          SA1    NLFLG       SET DEFERRED LIST FLAG 
          SA2    DLFLG
          SA3    LG+1 
          SX6    B1 
          NZ     X3,ZLIST    IF LIST G ON 
          BX6    X1-X6
          BX6    X6+X2
          SA6    A2 
          EQ     Z100 
 ZLLA     SPACE  4
**        ZLLA - LIST LOCATION ADDRESS. 
  
  
 ZLLA     RJ     LLA
 ZLIST    SPACE  4
**        ZLIST - LIST CURRENT LINE.
  
  
 ZLIST    SA2    EFLG 
          ZR     X2,ZLST1    IF NO ERROR
          RJ     LDL         LIST DEFERRED LINE 
 ZLST1    RJ     LISTER 
          EQ     Z100 
 ABS      TITLE  PSEUDO-OP PROCESSING.
***       ABS - ABSOLUTE ASSEMBLY.
* 
* 
*         ABS 
*         ABS DECLARES THE PROGRAM TO BE ABSOLUTE.  IF USED, IT MUST
*         APPEAR AT THE BEGINNING OF THE ASSEMBLY.  IN ABSOLUTE 
*         ASSEMBLIES, THE FOLLOWING ARE ILLEGAL.
*                EXT
*                LCC
*                REP
*                REPC 
*                REPI 
  
  
          USE    PSEUDO 
          SEG    PSEUDO-OP PROCESSING (A-E).
          QUAL   PASS1
 ABS      SX6    B1 
          SA6    ABSFG       SET ABSOLUTE ASSEMBLY FLAG 
          MX6    0
          SA6    ORGCTR+1    AND RELOCATION FOR COUNTERS
          SA6    LOCCTR+1 
          EQ     CTL300      RETURN 
 ABS      SPACE  4
**        ABS - ABSOLUTE ASSEMBLY.
  
  
          QUAL   PASS2
 ABS      EQU    ZLIST
 BASE     SPACE  4
***       BASE - NUMERIC DATA MODE. 
* 
* 
*MNAME    BASE   CHAR 
*         (CHAR) = O SET OCTAL BASE.
*                  D SET DECIMAL BASE.
*                  M SET MIXED BASE.
*                  * SET PREVIOUS BASE. 
*                  BLANK LEAVE BASE UNCHANGED.
*         IF (MNAME) IS PRESENT, SAVE THE CURRENT BASE IN MICRO MNAME.
  
  
          QUAL   PASS1
 BASE     SA2    LOCSYM 
          ZR     X2,BASE1    IF NO MICRO NAME 
          SA1    BASEMIC
          SX6    B1+B1
          BX7    X1 
          SA7    RELVEC 
          RJ     EMT         ENTER MICRO TABLE
 BASE1    SA1    CHAR 
          RJ     CBC         CHECK BASE CHARACTER 
          MI     X6,CTL70    IF ERROR 
          LX1    -6 
          SX7    B1 
          BX6    X1+X7
          SA6    BASEMIC     STORE CURRENT BASE MICRO 
          EQ     CTL70
 BASE     SPACE  4
**        BASE - NUMERIC DATA MODE. 
  
  
          QUAL   PASS2
 BASE     SA1    ABASE
          SA2    CBCA+X1     GET CURRENT BASE 
          UX3,B7 X2 
          SX6    -B7
          SX7    CONCAT 
          SA6    OCTAL+33    STORE IN LISTING LINE
          SA7    A6+B1
          SA6    A7+B1
          SA1    CHAR 
          RJ     CBC         CHECK BASE CHARACTER 
          MI     X6,ZLIST    IF ERROR 
          BX6    X1 
          SA6    OCTAL+35    STORE NEW LETTER 
          EQ     ZLIST       AND GO LIST
 BCU      SPACE  4
***       BCU - BUFFER CONTROLLER UNIT ASSEMBLY.
* 
* 
*         BCU 
*         BCU DECLARES THE PROGRAM TO BE A BUFFER CONTROLLER
*         ASSEMBLY AND ABSOLUTE.  THE RULES STATED UNDER ABS APPLY. 
  
  
          QUAL   PASS1
 BCU      SX6    -B1         SET FLAG FOR BCU ASSEMBLY
          SX7    B1+B1
          SA6    PPTYPE 
          SA7    NCHARS 
          SX6    B1          SET FLAGS FOR BCU ASSEMBLY 
          SX7    16 
 BCU.1    SA6    MACHINE
          SA7    LWORD       SET WORD LENGTH TO 16
          SA7    POSCTR      REVISE POSITION COUNTER TO 16
          SA3    /DATA/STCX  SET CHARACTER STORE FOR 8-BIT/NON-ASCII
          BX6    X3 
          SA6    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          LX7    24          RESET BLOCK COUNTERS 
          SA1    O.USETAB 
          SA2    L.USETAB 
 BCU1     SA7    X1+B1
          SX2    X2-4 
          SX1    X1+4 
          NZ     X2,BCU1     LOOP 
          SA1    STCA        CONVERT ASCII TO 8 BIT 
          SB7    63 
          SX2    40B
          LX2    27 
 BCU2     SA3    A1+B7       FETCH CHARACTER SPEC 
          IX6    X3+X2       CONVERT
          SA6    A3 
          SB7    B7-B1
          PL     B7,BCU2     LOOP 
 BCU3     SX6    B1 
          SA6    ABSFG       SET ABSOLUTE FLAG
          MX6    0
          SA6    ORGCTR+1    AND RELOCATION FOR COUNTERS
          SA6    LOCCTR+1 
          EQ     CTL70       RETURN 
 BCU      SPACE  4
**        BCU - BUFFER CONTROLLER UNIT ASSEMBLY.
  
  
          QUAL   PASS2
 BCU      SA3    /DATA/STCX  SET CHARACTER STORE FOR 8-BIT/NON-ASCII
          BX6    X3 
          SA6    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          EQ     ZLIST       AND GO LIST
 BCOP     SPACE  4
***       BCOP - DEFINE BC OPERATION CODE.
* 
* 
*NAME     BCOP   CTL,VAL
*         (NAME) = MNEMONIC NAME. 
*         (CTL) = 0 - 4-BIT ADDRESS.  (SAB) 
*                 1 - (16 - 4-BIT) ADDRESS.  (SLC)
*                 2 - (15 - 4-BIT) ADDRESS.  (TAB)
*                 3 - 8-BIT ADDRESS.  (ADN) 
*                 4 - 9-BIT RELATIVE ADDRESS.  (UJR)
*                 5 - 4-BIT CHANNEL AND NO ADDRESS.  (IAN)
*                 6 - 8-BIT ADDRESS AND OPTIONAL INDEXING.  (LDD) 
*                 7 - 4-BIT CHANNEL AND 4-BIT ADDRESS.  (INT) 
*         (VAL) = 16-BIT OPERATION CODE VALUE.
  
  
          QUAL   PASS1
 BCOP     SX7    140040B     SET BC AND OPSYN 
          JP     PPOP1
 BCOP     SPACE  4
**        BCOP - DEFINE BC OPERATION CODE.
  
  
          QUAL   PASS2
 BCOP     EQU    ZLIST
 BSS      SPACE  4
***       BSS - STORAGE RESERVATION.
* 
* 
*SYM      BSS    AEXP 
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         LOCATION AND ORIGIN COUNTERS ARE INCREMENTED BY THE VALUE 
*         OF (AEXP).
  
  
          QUAL   PASS1
 BSS      SA1    LWORD
          RJ     YPRLOC 
          SX6    3           EVALUATE ADDRESS FIELD 
          SX1    60 
          RJ     SCADCON
          SA1    EXVAL
          BX6    X1 
          AX6    21 
          NZ     X6,ERA      IF VALUE TOO LARGE 
          PL     X1,BSS1     IF NOT NEGATIVE BSS
          SX6    B1 
          SA6    EFLG 
          SA6    W7ERR
          SA2    ORGCTR 
          IX6    X2+X1
          NG     X6,ERA      IF INTO PREVIOUS BLOCK 
          SA3    A2+B1       FETCH BLOCK NUMBER 
          SA5    O.USETAB 
          SA4    UI 
          IX5    X4+X5       BASE ADDRESS OF BLOCK GROUP
          NZ     X3,BSS2     CHANGE 0 (ABSOLUTE) TO 1 
          SA3    UI+1 
 BSS2     LX3    2
          SB6    X3-1 
          SA4    X5+B6       FETCH MAX ORGCTR FOR BLOCK 
          IX4    X2-X4
          PL     X4,BSS1     IF NOT LESS THAN CURRENT ORGCTR
          BX6    X2 
          SA6    A4 
 BSS1     BX6    X1          SAVE EXPRESSION VALUE FOR PASS 2 
          SA6    FLAG 
          RJ     YUPLOC      ADVANCE LOCATION COUNTERS
          EQ     CTL70
 BSS      SPACE  4
**        BSS - STORAGE RESERVATION.
  
  
          QUAL   PASS2
 BSS      SA1    LWORD
          RJ     ZPRLOC 
          SX6    3
          SX1    60 
          RJ     SCADCON
          SA1    AERR 
          SA2    UERR 
          IX3    X1+X2
          NZ     X3,ZLIST    EXIT IF ANY ERRORS 
          SA1    FLAG 
          SA2    ORGCTR 
          IX3    X1+X2
          AX3    21 
          NZ     X3,BSSZR    IF VALUE OUT OF RANGE
  
*         ENTRY FROM BSSZ.
  
 BSS5     SA1    FLAG 
          SA2    EXVAL
          IX6    X1-X2
          BX7    X1 
          ZR     X6,BSS7     IF SAME VALUE IN BOTH PASSES 
          SX6    B1 
          SA7    A2          USE PASS 1 VALUE 
          SA6    EFLG 
          SA6    AERR        SET ADDRESS ERROR
 BSS7     ZR     X1,ZLISTG   IF BSS 0 
          SA2    IOP         CHECK OPCODE 
          SX7    X2-2R                                                  S028 401
          ZR     X7,BSS6     IF BLANK OPCODE                            S028 402
          SX2    36 
          MX3    0
          RJ     PACKO       CALL PACKO (EXVAL, 36, 0)
 BSS6     SA1    FLAG 
          RJ     ZUPLOC 
          SA1    FLAG 
          PL     X1,ZLISTG   IF NOT NEGATIVE BSS                        S028 407
          RJ     DBSSZ       DUMP BSSZ CODE                             S028 408
          RJ     DLAST       DUMP LINK AND FILL TABLES                  S028 409
          EQ     ZLISTG 
 BSSZ     SPACE  4
***       BSSZ - STORAGE RESERVATION. 
* 
* 
*SYM      BSSZ   AEXP 
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         LOCATION AND ORIGIN COUNTERS ARE INCREMENTED BY THE VALUE 
*         OF (AEXP).  AT LOAD TIME, THE NUMBER OF WORDS SPECIFIED 
*         BY (AEXP) WILL BE SET TO ZERO.
  
  
          QUAL   PASS1
 BSSZ     SA1    LWORD
          RJ     YPRLOC 
          SX6    3           EVALUATE ADDRESS FIELD 
          SX1    60 
          RJ     SCADCON
          SA1    EXVAL
          NG     X1,ERA      IF NEGATIVE BSS
          BX6    X1 
          SA2    ORGCTR 
          SA6    FLAG        SAVE VALUE FOR PASS 2
          IX4    X1+X2
          AX4    21 
          NZ     X4,ERA      IF VALUE TOO LARGE 
          RJ     YUPLOC 
          EQ     CTL70
 BSSZ     SPACE  4
**        BSSZ - STORAGE RESERVATION. 
  
  
          QUAL   PASS2
 BSSZ     SA1    LWORD
          RJ     ZPRLOC      PROCESS LOCATION 
          SX6    3
          SX1    60 
          RJ     SCADCON     GET VALUE
          SA3    UERR 
          SA4    AERR 
          BX1    X3+X4
          NZ     X1,ZLIST 
          SA5    FLAG        USE PASS 1 VALUE 
  
*         ENTRY FROM BLNKOP.
  
 BSSZ5    SA1    ORGCTR      CHECK UP ON RANGE OF BSSZ
          SA3    MINORG 
          IX0    X1+X5
          ZR     X5,ZLISTG   IF BSSZ 0
          IX6    X1-X3       ORGCTR-MINORG (MUST BE +)
          SA2    MAXORG 
          IX7    X2-X0       MAXORG-(ORGCTR+EXVAL) (MUST BE + ) 
          BX6    X6+X7
          SA2    ABSFG
          ZR     X2,ZBSSZ6
          SA2    ORGBASE
          SA3    LPGM 
          IX4    X1-X2
          IX2    X3-X0
          BX7    X4+X2
          BX6    X6+X7
 ZBSSZ6   BX6    X6+X5       DEMAND ADDRESS POSITIVE ALSO 
          NG     X6,BSSZR    IF OUT OF RANGE
          SA2    A1+B1       CHECK ORGCTR+1 
          SX4    X2-400B
          NG     X4,BSSZ1    JUMP IF NOT NEGATIVE 
 BSSZR    SX6    B1 
          SA6    EFLG 
          SA6    RERR        RANGE ERROR
          EQ     BSS5 
 BSSZ1    SA2    CNTBSSZ
          SA3    ORGBSSZ
          ZR     X2,BSSZ3 
          IX4    X3+X2
          IX5    X1-X4
          NZ     X5,BSSZ2    ORGBSSZ+CNTBSSZ NE ORGCTR
          SA3    A3+B1       ORGBSSZ(2) 
          SA4    A1+B1       ORGCTR(2)
          SA1    CLF         CONDITIONAL LOAD FLAG
          BX4    X1+X4
          IX5    X3-X4
          ZR     X5,BSSZ4    ALL EQUAL
 BSSZ2    RJ     DBSSZ
 BSSZ3    SA4    ORGCTR 
          SA5    FLAG 
          BX6    X4 
          SA2    CLF
          SA3    A4+B1
          SA6    ORGBSSZ     RESET BSSZ ORG TO ORGCTR 
          BX7    X2+X3
          SA7    A6+B1       RESET BSSZ RELOC TO CURRENT
          BX6    X5 
          SA6    CNTBSSZ     RESET BSSZ COUNT TO EXVAL
          EQ     BSS5 
 BSSZ4    SA1    FLAG 
          IX6    X1+X2       EXVAL+CNTBSSZ IS NEW COUNT 
          SA6    A2          RESET CNTBSSZ
          EQ     BSS5        GO UP LOCATION COUNTER 
 B1=1     SPACE  4
***       B1=1 - DECLARE THAT (B1) CONTAINS A 1.
* 
* 
*         B1=1
*         USED IN CONJUNCTION WITH THE (R=) PSEUDO.  THIS DECLARES
*         THAT (B1) IS 1, AND DEFINES THE SYMBOL B1=1.
  
  
          QUAL   PASS1
 B1=1.    SX6    REQA-1      SET FULL SCAN FOR R= PSEUDO
          SA6    REQC 
 BEQ1     SA1    IOP         DEFINE *B1=1*
          MX2    0
          BX3    X3-X3
          SX4    B0 
          IX5    X5-X5
          RJ     YDEFSYM
          EQ     CTL300      RETURN 
 B1=1     SPACE  4
**        B1=1 - DECLARE THAT (B1) CONTAINS A 1.
  
  
          QUAL   PASS2
 .B1=1    EQU    ZLIST
 B7=1     SPACE  4
***       B7=1 - DECLARE THAT (B7) CONTAINS A 1.
* 
* 
*         B7=1
*         USED IN CONJUNCTION WITH THE (R=) PSEUDO.  THIS DECLARES
*         THAT (B7) IS 1, AND DEFINES THE SYMBOL B7=1.
  
  
          QUAL   PASS1
 B7=1     SX6    REQD-1      SET FULL SCAN FOR R= PSEUDO
          SA6    REQC 
          EQ     BEQ1 
 B7=1     SPACE  4
**        B7=1 - DECLARE THAT (B7) CONTAINS A 1.
  
  
          QUAL   PASS2
 B7=1     EQU    ZLIST
 CC       SPACE  4
***       CC - COMPARE COLLATED (CMU INSTRUCTION).
* 
* 
*         CC     L,KA,CA,KB,CB
*         (L) = DATA FIELD LENGTH IN CHARACTERS (@127). 
*         (KA) = FIRST OPERAND FIELD FIRST WORD ADDRESS.
*         (CA) = FIRST OPERAND FIELD FIRST CHARACTER POSITION (0-9).
*         (KB) = SECOND OPERAND FIELD FIRST WORD ADDRESS. 
*         (CB) = SECOND OPERAND FIELD FIRST CHARACTER POSITION (0-9). 
  
  
          QUAL   PASS1
 CC       SA1    MACHINE     COMPLAIN IF PP ASSEMBLY
          NZ     X1,CTLPPER 
          SA1    LWORD       PROCESS LOCATION FIELD 
          RJ     YPRLOC 
          SX6    5           SCAN UP TO FIVE ARGUMENTS
          SA6    P1TEMP 
 CC1      SX1    18          SCAN ARGUMENT
          RJ     SCAD 
          SA1    P1TEMP 
          SA2    EXSTOP 
          SX6    X1-1 
          ZR     X2,CC2      IF END OF ARGUMENTS
          SA6    A1 
          NZ     X6,CC1      IF NOT 5 SCANNED YET 
 CC2      SX1    B1 
          RJ     YUPLOC      BUMP LOCATION COUNTER
          EQ     CTL65       RETURN 
 CC       SPACE  4
**        CC - COMPARE COLLATED (CMU INSTRUCTION).
  
  
          QUAL   PASS2
 CC       SX6    466B 
 CC1      LX6    3
          SX7    7
          NZ     X6,CC2      IF NOT *MD*
          SX7    13 
 CC2      SA6    OPVAL       MACHINE OPCODE 
          SA7    OPADS       LENGTH OF LENGTH FIELD 
          SA1    LWORD
          RJ     ZPRLOC      PROCESS LOCATION FIELD 
          SA1    OPADS
          SX6    3
          RJ     SCADCON
          SA1    OPADS       PROCESS LENGTH FIELD 
          SA2    EXVAL
          MX6    1
          SB7    X1-59
          LX6    X6,B7       7- OR 13-BIT MASK
          BX6    -X6*X2 
          MX0    -4 
          BX7    -X0*X6      LL = LOWER 4 BITS OF L 
          AX6    4           LU = UPPER 3 OR 9 BITS OF L
          SA3    OPVAL
          LX7    8
          BX6    X3+X6
          SA6    A3          OPVAL = OPCODE, LU 
          SA7    A1          OPADS = LL IN BITS 11-8
          SX1    18 
          SX6    B1 
          RJ     SCADCON     SCAN KS OR KA
          SA1    EXVAL
          SA2    A1+B1       EXREL
          MX0    -18
          SA3    A2+B1       EXEXT
          BX6    -X0*X1 
          LX7    X2 
          SA6    OPADS+1     OPADS+1 = KS/KA VALUE
          SA7    A6+B1       OPADS+2 = RELOCATION 
          BX6    X3 
          SA6    A7+B1       OPADS+3 = EXTERNAL 
          SX6    3
          SX1    X6+B1
          RJ     SCADCON     SCAN CS OR CA
          SA1    EXVAL
          SA2    OPADS
          SX3    X1-10
          BX7    -X3+X1 
          LX1    4
          PL     X7,CC3      IF NOT 0-9, USE 0 AND SET A-ERROR
          SX6    B1 
          MX1    0
          SA6    EFLG 
          SA6    AERR 
 CC3      BX6    X2+X1
          SA6    A2          OPADS = LL IN BITS 11-8, CS/CA IN BITS 7-4 
          SX1    18 
          SX6    B1 
          RJ     SCADCON     SCAN KD OR KB
          SA1    EXVAL
          SA2    A1+B1       EXREL
          MX0    -18
          SA3    A2+B1       EXEXT
          BX6    -X0*X1 
          LX7    X2 
          SA6    OPADS+4     OPADS+4 = KD/KB VALUE
          SA7    A6+B1       OPADS+5 = RELOCATION 
          BX6    X3 
          SA6    A7+B1       OPADS+6 = EXTERNAL 
          SX6    3
          SX1    X6+B1
          RJ     SCADCON     SCAN CD OR CB
          SA1    EXVAL
          SA2    OPADS
          SX3    X1-10
          BX7    -X3+X1 
          PL     X7,CC4      IF NOT 0-9, USE 0 AND SET A-ERROR
          SX6    B1 
          MX1    0
          SA6    EFLG 
          SA6    AERR 
 CC4      BX6    X2+X1       OPADS = 48/ 0, 4/ LL, 4/ CS/CA, 4/ CD/CB 
          SA6    A2 
          SA1    EXSTOP 
          ZR     X1,CC5      IF END OF VARIABLE FIELD 
          SX6    B1 
          SA6    EFLG        TOO MANY ARGUMENTS 
          SA6    W8ERR
 CC5      SX7    48 
          SA1    OPVAL       OUTPUT OPCODE AND LU 
          SX2    12          (BITS 59-48 OF WORD) 
          MX3    0
          BX4    X4-X4
          SA7    POSCTR 
          RJ     BINOUT 
          SX7    30 
          SA1    OPADS+1     OUTPUT KS OR KA FIELD
          SX2    18          (BITS 47-30 OF WORD) 
          SA3    A1+B1
          SA4    A3+B1
          SA7    POSCTR 
          RJ     BINOUT 
          SX7    18 
          SA1    OPADS       OUTPUT LL, CS/CA, CD/CB
          SX2    12          (BITS 29-18 OF WORD) 
          MX3    0
          BX4    X4-X4
          SA7    POSCTR 
          RJ     BINOUT 
          SX7    B0 
          SA1    OPADS+4     OUTPUT KD OR KB FIELD
          SX2    18          (BITS 17-0 OF WORD)
          SA3    A1+B1
          SA4    A3+B1
          SA7    POSCTR 
          RJ     BINOUT 
          SA1    OPVAL
          SA2    OPADS+1     LIST UPPER HALF OF WORD IN OCTAL 
          SA3    A2+B1
          SA4    A3+B1
          LX1    18 
          BX6    X3 
          LX7    X4 
          IX1    X1+X2
          SX2    26 
          SX3    10 
          SA6    EXREL
          SA7    A6+B1
          RJ     PACKOR 
          SA1    OPADS+2
          SA2    A1+B1
          BX6    X1+X2
          ZR     X6,CC6      IF NOT RELOCATABLE NOR EXTERNAL
          RJ     LISTERG     LIST LINE
          MX6    0           CLEAR DETAIL FLAG
          SA6    DETFLG 
 CC6      SA1    OPADS
          SA2    OPADS+4     LIST LOWER HALF OF WORD IN OCTAL 
          SA3    A2+B1
          SA4    A3+B1
          LX1    18 
          BX6    X3 
          LX7    X4 
          IX1    X1+X2
          SX2    36 
          SX3    10 
          SA6    EXREL
          SA7    A6+B1
          RJ     PACKOR 
          RJ     LISTERG     LIST LINE
          EQ     Z100        RETURN 
 CHAR     SPACE  4,8
***       CHAR - CHANGE CHARACTER CODE. 
* 
* 
*         CHAR   AEXP,AEXP
*         DEFINES CHARACTER CODE CONVERSION INVOKED BY *CODE OTHER*.
*         INITIALLY, ALL CHARACTERS HAVE THEIR DISPLAY CODE VALUES. 
*         *CHAR* REDEFINES THE CHARACTER WHOSE DISPLAY CODE VALUE 
*         IS (AEXP1) TO BE CONVERTED TO THE VALUE OF (AEXP2) WHEN 
*         *CODE OTHER* IS IN EFFECT.
*         THIS CHANGE IS MADE IN PASS 1 SO THE CHARACTERS HAVE THIS 
*         VALUE DURING PASS 2.
  
  
          QUAL   PASS1
 CHAR.    SX1    6
          SX6    3
          RJ     SCADCON
          NZ     X1,CTL70    IF ERRORS
          SA1    EXVAL
          MX0    -6 
          BX6    -X0*X1 
          SA6    P1TEMP 
          SX1    8
          SX6    3
          RJ     SCADCON
          NZ     X1,CTL70    IF ERRORS
          SA1    P1TEMP 
          SA2    EXVAL
          MX0    -8 
          SA3    X1+STCA     READ CHARACTER 
          BX6    -X0*X2 
          LX0    36 
          LX6    36 
          BX3    X0*X3
          BX6    X3+X6
          SA6    A3          UPDATE CHARACTER 
          SA6    FLAG 
          JP     CTL70       RETURN 
 CHAR     SPACE  4,8
**        CHAR - CHANGE CHARACTER CODE. 
  
  
          QUAL   PASS2
 CHAR.    SX1    6           COLLECT REFERENCES 
          RJ     SCAD 
          SX1    8
          RJ     SCAD 
          SA1    FLAG 
          ZR     X1,ZLIST    IF ERRORS IN PASS 1
          MX0    -8 
          BX6    X1 
          BX2    -X0*X1 
          SA6    STCA+X2     UPDATE CHARACTER 
          SX3    B1+B1
          SX2    33          OUTPUT OCTAL 
          RJ     PACKO
          SX6    CONCAT 
          SA6    OCTAL+33 
          SA1    FLAG 
          SX2    36 
          SX3    B1+B1
          AX1    36 
          RJ     PACKO
          JP     ZLIST       RETURN 
 CIPPU    SPACE  4,10 
***       CIPPU - 180 PP ASSEMBLY.
* 
* 
*         CIPPU  CH1,CH2
*         DECLARES THE PROGRAM TO BE A 180 PPU PROGRAM AND ABSOLUTE.
*         THE RULES STATED UNDER ABS APPLY. 
*         IF (CH1) = J, LOW-CORE PP JUMPS ARE ASSEMBLED AS (TAG - *). 
*         IF (CH1) = ANYTHING OTHER THAN J, LOW-CORE PP JUMPS ARE 
*                    ASSEMBLED AS JUMP TO (TAG).
*         IF (CH2) = S, CHARACTER DATA FOR *CON* AND *VFD* INSTRUCTIONS 
*                    IS PLACED IN THE RIGHT-MOST 12 BITS OF EACH 16-BIT 
*                    PP WORD.  THIS IS OVERRIDDEN BY USE OF *CONL* AND
*                    *VFDL*.
*         IF (CH2) = ANYTHING OTHER THAN S, CHARACTER DATA FOR *CON*
*                    AND *VFD* IS ASSEMBLED WITH THE FULL 16-BIT WORD 
*                    AS THE FIELD SIZE. 
  
  
          QUAL   PASS1
 CIPPU    SX6    -3          PP TYPE = 180
          SA6    PPTYPE 
          SX7    B0          SET FOR *L* OPTION 
          MX6    0           SET FOR NOT *J* OPTION 
          SA3    COLUMN 
          SA1    X3+CARD-1   GET FIRST CHAR OF ADDRESS FIELD
          SX2    X1-1RJ 
          NZ     X2,CIPPU3   IF *J* OPTION NOT PRESENT
          SX6    B1          SET FOR *J* OPTION 
 CIPPU1   SA1    A1+B1       GET NEXT CHAR
 CIPPU3   SX2    X1-1R
          ZR     X2,CIPPU4   IF END OF ADDRESS FIELD
          SX2    X1-1R, 
          NZ     X2,CIPPU1   LOOP FORWARD TO COMMA
          SA1    A1+B1       GET NEXT CHAR
          SX2    X1-1RS 
          NZ     X2,CIPPU4
          SX7    4           SET FOR *S* OPTION 
 CIPPU4   SA6    PPJUMP      SET PP JUMP INDICATOR
          SA7    VWORD       SET *VFD* AND *CON* ASSEMBLY MODE
          SX6    B1 
          SX7    16 
          SA6    MACHINE     MACHINE TYPE = 1 FOR PP
          SA7    LWORD       WORD LENGTH = 16 FOR 180 PP
          SA7    POSCTR      POSITION COUNTER = 16
          SX6    B1+B1
          SA6    NCHARS      NUMBER OF CHARACTERS = 2 
          SX6    6
          SA6    PPBYT       6 BYTES PER PP WORD FOR 180
          LX7    24          SET POSITION COUNTER IN *USETAB* ENTRIES 
          SA1    O.USETAB 
          SA2    L.USETAB 
 CIPPU2   SA7    X1+B1
          SX2    X2-4 
          SX1    X1+4 
          NZ     X2,CIPPU2
          SX6    4
          SX7    1R8         *VALID* = 8 (TO BE SET TO 8P)
          SA6    MTYPE       *MTYPE* = 3
          LX7    6
          SX6    X6+B1       5
          SA7    VALID
          SX7    45          SET CHARACTER TYPE TO 8-BIT ASCII
          SA3    /DATA/STCZ  SET FOR CHARACTER STORE OF 8-BIT/ASCII 
          SA2    VWORD
          ZR     X2,CIPPU5   IF 16-BIT MODE FOR *CON* AND *VFD* 
          SX6    B0          SET CHARACTER TYPE TO DISPLAY
          MX7    0
          SA3    /DATA/STCW  SET FOR CHARACTER STORE OF 6-BIT/NON-ASCII 
 CIPPU5   SA7    CT          SET DEFAULT CHARACTER TYPE 
          SA6    A7+B1
          BX7    X3          SET CHARACTER STORE
          SA7    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          SA1    PSIM 
          SX3    6000B
          BX6    X1+X3       INCLUDE 60B, 61B CODES IN MASK 
          SA6    A1 
          EQ     BCU3        COMPLETE THE SAME AS FOR *BCU* 
 CIPPU    SPACE  4,10 
**        CIPPU - 180 PP ASSEMBLY.
  
  
          QUAL   PASS2
 CIPPU    SA3    /DATA/STCZ  SET FOR CHARACTER STORE OF 8-BIT/ASCII 
          SA2    VWORD
          ZR     X2,CIPPU1   IF 16-BIT MODE FOR *CON* AND *VFD* 
          SA3    /DATA/STCW  SET FOR CHARACTER STORE OF 6-BIT/NON-ASCII 
 CIPPU1   BX7    X3          SET CHARACTER STORE
          SA7    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          EQ     ZLIST       GO LIST
 CODE     SPACE  4
***       CODE - DECLARE CHARACTER DATA CODE. 
* 
* 
*MNAME    CODE   CHAR 
*         (CHAR) = A SET ASCII 6-BIT SUBSET CODE. 
*                  D SET DISPLAY CODE.
*                  E SET EXTERNAL BCD CODE. 
*                  I SET INTERNAL BCD CODE. 
*                  O SET OTHER CHARACTER CODE DEFINED BY *CHAR*.
*                  * SET PREVIOUS CODE. 
*                  BLANK LEAVE CODE UNCHANGED.
*         IF (MNAME) IS PRESENT, SAVE THE CURRENT CODE IN MICRO MNAME.
  
  
          QUAL   PASS1
 CODE     SA2    LOCSYM 
          ZR     X2,CODE1    IF NO MICRO NAME 
          SA1    CODEMIC
          SX6    B1+B1
          BX7    X1 
          SA7    RELVEC 
          RJ     EMT         ENTER MICRO TABLE
 CODE1    SA1    CHAR 
          RJ     CCC         CHECK CODE CHARACTER 
          MI     X6,CTL70    IF ERROR 
          LX1    -6 
          SX7    B1 
          BX6    X1+X7
          SA6    CODEMIC     STORE CURRENT CODE MICRO 
          EQ     CTL70       RETURN 
 CODE     SPACE  4
**        CODE - DECLARE CHARACTER DATA CODE. 
  
  
          QUAL   PASS2
 CODE     SA1    CT+1 
          SA2    CCCA+X1     GET CURRENT CODE 
          UX3,B7 X2 
          SX6    -B7
          SX7    CONCAT 
          SA6    OCTAL+33    STORE IN LISTING LINE
          SA7    A6+B1
          SA6    A7+B1
          SA1    CHAR 
          RJ     CCC
          NG     X6,ZLIST    IF NO CHANGE 
          BX6    X1 
          SA6    OCTAL+35 
          EQ     ZLIST
 COL      SPACE  4
***       COL - SET COMMENT COLUMN. 
* 
*         COL    AEXP 
*         SETS THE COLUMN NUMBER AT WHICH COMMENT FIELD CAN BEGIN 
*         WHEN VARIABLE FIELD IS BLANK. 
  
  
          QUAL   PASS1
 COL.     SX1    15 
          SX6    3
          RJ     SMC
          NZ     X1,CTL70    IF ERRORS
          SA1    EXVAL
          BX6    X1 
          SX2    X1-12
          PL     X2,COM1     IF AFTER COLUMN 12 
          SX6    12 
          NZ     X1,COM1     IF NOT DEFAULT 
          SX6    COMCOL 
 COM1     SA6    CCOL 
          SA6    FLAG 
          EQ     CTL70
 COL      SPACE  4
**        COL - SET COMMENT COLUMN. 
  
  
          QUAL   PASS2
 COL.     SA1    FLAG 
          BX6    X1 
          SA6    CCOL 
          SX2    36          OUTPUT OCTAL 
          MX3    0
          RJ     PACKO
          EQ     ZLIST
 COMMENT  SPACE  4
***       COMMENT - IDENT TABLE COMMENT.
* 
* 
*         COMMENT STRING
*         ADDS COMMENT TO PREFIX TABLE IN BINARY OBJECT DECK. 
*         THE COMMENT IS IGNORED BY THE LOADER BUT IDENTIFIES THE 
*         RECORD FOR USE BY UTILITY PROGRAMS.  THE STRING STARTS WITH 
*         THE FIRST NON-BLANK CHARACTER AND TERMINATES WITH THE LAST
*         NON-BLANK CHARACTER.
  
  
          QUAL   PASS1
 COMMENT  SA1    COLUMN 
          SA2    LASTCOL
          SB6    X1+CARD-1
          SA2    X2+CARD
          SB7    A2+B1
 CMT1     SA2    A2-B1       FIND LAST NON-BLANK CHARACTER
          SB7    B7-B1
          SB3    X2-1R
          ZR     B3,CMT1
          SB4    PRFXC
          SB5    PRFXC+7
 CMT2     MX6    0           PACK COMMENT TEXT INTO PRFX TABLE IMAGE
          SB3    10 
 CMT3     SA1    B6 
          LX6    6
          SB3    B3-B1
          SB6    B6+B1
          BX6    X6+X1
          NZ     B3,CMT3     IF WORD NOT FULL 
          SA6    B4 
          SB4    B4+B1
          GE     B6,B7,CMT4  IF END OF COMMENT TEXT 
          LT     B4,B5,CMT2  IF PRFX TABLE NOT FULL 
 CMT4     SX6    B4-PRFXC 
          SA6    P1TEMP 
          MANAGE IDTAB,X6 
          SA1    P1TEMP 
          IX6    X3-X1
          IX3    X2+X6
          SX2    PRFXC       MOVE COMMENT TEXT TO IDTAB 
          SA4    =1HT 
          RJ     MOVE 
          EQ     CTL300 
 COMMENT  SPACE  4
**        COMMENT - IDENT TABLE COMMENT.
  
  
          QUAL   PASS2
 COMMENT  EQU    ZLIST
 CON      SPACE  4
***       CON - NUMERIC CONSTANT. 
* 
* 
*SYM      CON    EXP1,EXP2,...,EXPN 
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         GENERATES FIELDS OF BINARY DATA.  THE FIELD SIZE IS NORMALLY
*         ONE WORD.  HOWEVER, FOR A 180 PPU ASSEMBLY WITH THE SHORT DATA
*         OPTION SELECTED (CIPPU  ,S), THE FIELD SIZE IS 12 BITS AND IS 
*         RIGHT-JUSTIFIED IN THE 180 PPU WORD.
  
  
          QUAL   PASS1
 CON      SA1    LWORD       SET FIELD SIZE FOR GENERATED DATA
          SA2    VWORD        = LWORD FOR ALL ASSEMBLIES EXCEPT FOR 
          IX6    X1-X2          180 PPU ASSEMBLIES WITH *S* OPTION
          SA6    WWORD
 CON.0    SA1    LWORD       COMMON CODE FOR *CON* AND *CONL* 
          RJ     YPRLOC 
 CON1     SA1    WWORD
          RJ     SCAD 
          SX1    B1 
          SA4    PPTYPE 
          SX4    X4+2 
          NZ     X4,CON2     IF NOT MCU ASSEMBLY. 
          SX1    B1+B1
 CON2     BSS    0
          RJ     YUPLOC 
          SA1    EXSTOP 
          ZR     X1,CTL65    IF END OF LIST 
          EQ     CON1 
 CON      SPACE  4
**        CON - NUMERIC CONSTANT. 
  
  
          QUAL   PASS2
 CON      SA1    LWORD       SET FIELD SIZE FOR GENERATED DATA
          SA2    VWORD        = LWORD FOR ALL ASSEMBLIES EXCEPT FOR 
          IX6    X1-X2          180 PPU ASSEMBLIES WITH *S* OPTION
          SA6    WWORD
 CON.0    MX6    0           COMMON CODE FOR *CON* AND *CONL* 
          SA6    P2TEMP 
 CON1     SA1    LWORD
          RJ     ZPRLOC 
 CON1.1   SA1    WWORD
          SA4    PPTYPE 
          SX4    X4+2 
          NZ     X4,CON1.2   IF NOT MCU ASSEMBLY. 
          LX1    1
          RJ     SCAD 
          SA1    EXVAL
          SA3    RMODE       CHECK FOR REVERSED ADDRESS MODE
          MX0    -8 
          BX2    X1 
          BX7    -X0*X1 
          AX1    8
          LX7    8
          BX7    X7+X1
          ZR     X3,CON1.3   IF NOT REVERSED ADDRESS MODE 
          SA7    A1 
          BX1    X2          CALL PACKO(VALUE,34,4) 
          SX2    34 
          SX3    4
          RJ     PACKO
          SX6    1R(
          SA6    OCTAL+29 
          SX6    1R)
          SA6    OCTAL+34 
          SX6    B1 
          SA6    P2TEMP 
          SA1    EXVAL       DUMP LSB FIRST 
          AX1    8
  
 CON1.3   SA2    LWORD
          MX6    0
          SA6    POSCTR 
          SX3    B0 
          SX4    B0 
          RJ     BINOUT 
          RJ     ZFOUP
          JP     CON2 
 CON1.2   RJ     SCAD 
          SA5    EXREG       CHECK FOR A REGISTER 
          SX6    B1 
          ZR     X5,CON2
          SA6    AERR 
          SA6    EFLG 
 CON2     SA1    EXVAL       OUTPUT BINARY VALUE
          SA2    LWORD
          SA3    EXREL
          SA4    A3+B1
          MX6    0
          SA6    POSCTR 
          RJ     BINOUT 
          SA1    EXVAL       OUTPUT OCTAL LIST
          SX2    36 
          SX3    20 
          SA4    MACHINE
          ZR     X4,CON3     IF CP
          SX2    30 
          SA4    PPTYPE 
          SX4    X4+3 
          NZ     X4,CON2.1   IF NOT 180 PP ASSEMBLY 
          SX2    32 
 CON2.1   SA3    PPBYT
          SA4    P2TEMP 
          SX5    B1 
          BX6    X4-X5
          SA6    A4 
          ZR     X6,CON3     IF SECOND FIELD
          SA5    EXSTOP 
          SX2    25 
          ZR     X5,CON3     IF END OF LIST 
          RJ     PACKO
          RJ     ZFOUP
          EQ     CON1.1      LOOP 
 CON3     RJ     PACKOR 
          SX6    B0          CLEAR DETAIL FLAG
          SA6    DETFLG 
          RJ     LISTERG     LIST LINE
          SA1    EXSTOP 
          ZR     X1,Z100     IF END OF LIST 
          EQ     CON1 
 CONL     SPACE  4,10 
***       CONL - NUMERIC CONSTANT.
* 
* 
*SYM      CONL   EXP1,EXP2,...,EXPN 
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         GENERATES FIELDS OF BINARY DATA.  THE FIELD SIZE IS ONE WORD. 
*         SIMILAR TO *CON*, EXCEPT THAT IT OVERRIDES THE 12-BIT FIELD 
*         SIZE SPECIFIED FOR 180 PPU ASSEMBLIES BY (CIPPU  ,S). 
*         CONL IS LEGAL ONLY FOR 180 PPU ASSEMBLIES.
  
  
          QUAL   PASS1
 CONL     SA3    PPTYPE 
          SX3    X3+3 
          ZR     X3,CONL1    IF 180 PPU ASSEMBLY
          SX6    B1          *CONL* ILLEGAL, POST O-ERROR 
          SA6    EFLG 
          SA6    OERR 
 CONL1    SA1    LWORD       SET FIELD SIZE FOR GENERATED DATA
          BX6    X1 
          SA6    WWORD
          EQ     CON.0       GO TO COMMON *CON* PROCESSING
          SPACE  4,10 
**        CONL - NUMERIC CONSTANT.
  
  
          QUAL   PASS2
 CONL     SA1    LWORD       SET FIELD SIZE FOR GENERATED DATA
          BX6    X1 
          SA6    WWORD
          EQ     CON.0       GO TO COMMON *CON* PROCESSING
 CPOP     SPACE  4
***       CPOP - DEFINE CP OPERATION CODE.
* 
* 
*SYTX     CPOP   CTL,VAL,REG,TYP
*         (SYTX) IS ABBREVIATED DESCRIPTION OF CP INSTRUCTION.
*         (CTL) = 4 - FORCE UPPER AFTER INSTRUCTION.
*                 2 - FORCE UPPER BEFORE INSTRUCTION. 
*                 1 - 30-BIT INSTRUCTION. 
*         (VAL) = 9-BIT VALUE OF OPERATION CODE.
*         (REG) = IJK.  (I) = CODE FOR I-PORTION. 
*                 1 - OP-CODE PORTION.
*                 2 - 2ND OR ONLY ADDRESS REGISTER. 
*                 3 - 1ST OF 2 ADDRESS REGISTERS. 
*         (TYP) = 6 OR 7 TO RESTRICT INSTRUCTION TO 6000 OR 7000. 
  
  
          QUAL   PASS1
 CPOP     SA1    CARD        SCAN OPERATION SYNTAX
          RJ     SOS
          ZR     X6,CTL70    IF SYNTAX ERROR
          SX6    3           READ CTL 
          SX1    3
          RJ     SCADCON
          SA1    EXVAL
          SX6    3           READ VAL 
          BX7    X1 
          SX1    9
          SA7    P1TEMPA
          RJ     SCADCON
          SA1    EXVAL
          SX6    3           READ REG 
          BX7    X1 
          SX1    9
          SA7    P1TEMPB
          RJ     SCADCON
          SA1    P1TEMPA
          SA1    EXVAL
          SX6    3           READ TYP 
          BX7    X1 
          SX1    3
          SA7    P1TEMPC
          RJ     SCADCON
          SA1    EXVAL       GET TYP
          SX6    B0 
          SB7    X1-6 
          MI     B7,CPOP2    IF NOT 6 OR 7, ASSUME 0
          GT     B7,B1,CPOP2
          SX6    B7+B1
          LX6    3
 CPOP2    SA1    P1TEMPA
          SA2    A1+B1
          SA3    A2+B1
          BX1    X6+X1
          LX1    27 
          LX2    48 
          SX6    1R 
          LX3    18 
          BX1    X1+X2
          IX6    X6+X3
          BX6    X6+X1
          SA1    P1TEMPD
          SB7    X1-3 
          LE     B7,CPOP1    IF @ 3 ARGUMENTS 
          SX7    B1 
          SA7    LERR 
          SA7    EFLG 
 CPOP1    MX0    1           SET OPSYN BIT
          LX0    48 
          BX2    X0+X6
          SA3    EFLG 
          SA1    P1TEMP 
          NZ     X3,CTL70 
          RJ     ENTOP
          EQ     CTL300      RETURN 
 CPOP     SPACE  4
**        CPOP - DEFINE CP OPERATION CODE.
  
  
          QUAL   PASS2
 CPOP     EQU    ZLIST
 CPSYN    SPACE  4
***       CPSYN - CP INSTRUCTION SYNONYMOUS.
* 
* 
*SYTX1    CPSYN  SYTX2
*         THIS MAKES THE CP INSTRUCTION DESCRIBED BY (SYTX1)
*         SYNONYMOUS WITH THE CP INSTRUCTION DESCRIBED BY (SYTX2).
  
  
          QUAL   PASS1
 CPSYN    SA1    OPTYPE      SAVE OPTYPE
          SA2    COLUMN 
          BX6    X1 
          SA6    P1TEMPA
          SA1    X2+CARD-1   SCAN OPERATION SYNTAX
          RJ     SOS
          ZR     X6,CTL70    IF SYNTAX ERROR
          SA1    P1TEMP      FIND EQUIVALENCE 
          RJ     TLUOP
          SB7    AERR 
          ZR     X6,CPS2     IF ADDRESS FIELD NOT DEFINED 
          SA1    CARD        SCAN OPERATION SYNTAX
          RJ     SOS
          SB7    LERR 
          SA2    OPTYPE 
          ZR     X6,CPS2     IF LOCATION FIELD BAD
          SA1    P1TEMP 
          BX6    X2 
          SX0    B1          SET PROGRAM-DEFINED FLAG 
          AX6    57 
          BX3    X6+X0
 +        LX0    47 
          NZ     X3,*+1      IF NOT AN OPDEF
          LX0    57-47
 +        BX2    X2+X0
          RJ     ENTOP
 CPS1     SA1    P1TEMPA     RESET OPTYPE 
          BX6    X1 
          SA6    OPTYPE 
          EQ     CTL300      RETURN 
 CPS2     SX6    B1          SET ERROR FLAG 
          SA6    B7 
          SA6    EFLG 
          EQ     CPS1        RETURN 
 CPSYN    SPACE  4
**        CPSYN - CP INSTRUCTION SYNONYMOUS.
  
  
          QUAL   PASS2
 CPSYN    EQU    ZLIST
 CTEXT    SPACE  4
***       CTEXT - COMMON DECK TEXT. 
* 
* 
*         CTEXT 
*         SET XTEXT FLAG FOR LIST CONTROL.
  
  
          QUAL   PASS1
 CTEXT    RJ     CWI         WRITE INTERMEDIATE 
          SA1    XLEV        INCREMENT NESTING LEVEL                    P036  18
          SX6    B1          SET XTEXT FLAG 
          SX7    X1+B1                                                  P036  20
          SA6    LIBFLG 
          SA7    A1                                                     P036  22
          EQ     CTL100      READ NEXT CARD 
 CTEXT    SPACE  4
**        CTEXT - COMMON DECK TEXT. 
  
  
          QUAL   PASS2
 CTEXT    RJ     LLA         LIST LOCATION ADDRESS
          SA1    LX+1 
          ZR     X1,ZLIST    IF NO LIST X 
          SA2    CHAR        CHECK TITLE
          SX6    X2-1R
          ZR     X6,ZLIST    IF NO TITLE
          SA1    SUBTIT      SET NEW TITLE
          RJ     SNT
          NZ     X6,ZLIST    IF ALREADY IN XTEXT AND LIST X IS OFF      P036  24
          RJ     TLIST       TEST FOR LISTING 
          SA1    LPCNT       FORCE EJECT
          SA2    NEJF        *N* CONTROLLED PAGE SIZE 
          IX7    X1+X2
          SA7    A1 
          MX6    0
          SA6    CTYPE
          EQ     ZLIST       RETURN 
 CU       SPACE  4
***       CU - COMPARE UNCOLLATED (CMU INSTRUCTION).
* 
* 
*         CU     L,KA,CA,KB,CB
*         (L) = DATA FIELD LENGTH IN CHARACTERS (@127). 
*         (KA) = FIRST OPERAND FIELD FIRST WORD ADDRESS.
*         (CA) = FIRST OPERAND FIELD FIRST CHARACTER POSITION (0-9).
*         (KB) = SECOND OPERAND FIELD FIRST WORD ADDRESS. 
*         (CB) = SECOND OPERAND FIELD FIRST CHARACTER POSITION (0-9). 
  
  
          QUAL   PASS1
 CU       EQU    CC 
 CU       SPACE  4
**        CU - COMPARE UNCOLLATED (CMU INSTRUCTION).
  
  
          QUAL   PASS2
 CU       SX6    467B 
          EQ     CC1
 DATA     SPACE  4
***       DATA - DATA DECLARATION.
* 
* 
*SYM      DATA   ITEM1,ITEM2,...,ITEMN
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         SUBFIELDS, SEPARATED BY COMMAS, MAY BE NUMERIC OR CHARACTER 
*         DATA ITEMS. 
  
  
          QUAL   PASS1
 DATA     SA1    LWORD       PROCESS LOCATION 
          RJ     YPRLOC 
 DATA1    SX2    VALUES 
          SX3    NLITS
          MX4    0
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM 
          SB7    X1-1R
          SA2    MACHINE
          ZR     X2,DATA20   IF CP CODE 
          SX2    X3-1 
          NZ     X2,DATA20   IF MORE THAN 1 WORD
          SA5    LWORD
          SA2    VALUES 
          SB2    X5 
          AX2    B2,X2
          ZR     X2,DATA20   IF VALUE FITS IN PP WORD 
          SX6    B1 
          SA6    EFLG 
          SA6    W7ERR
 DATA20   BX1    X3 
          RJ     YUPLOC      UPDATE COUNTERS FOR WORD COUNT 
          SA1    W7ERR
 +        NZ     B7,*+1      IF NOT END OF LINE 
          NZ     X1,CTL70    LIST ERROR 
          ZR     B7,CTL65    EXIT IF END OF FIELD 
          RJ     GETCH       THROW AWAY COMMA 
          EQ     DATA1       GO BACK FOR MORE 
 DATA     SPACE  4
**        DATA - DATA DECLARATION.
  
  
          QUAL   PASS2
 DATA     RJ     ZFOUP
 ZDATA0   SX6    B0          EVALUATE FIRST DATA ITEM 
          SX2    VALUES 
          SA6    AERR 
          SX3    NLITS
          MX4    0
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM 
          BX6    X3          WORD COUNT 
          SX7    VALUES      ORIGIN 
          SA6    P2TEMP 
          SA7    A6+B1
 ZDATA1   SA1    LWORD       LIST LOCATION VALUE
          RJ     ZPRLOC 
          SA5    P2TEMP      WORD COUNT 
          SA1    A5+B1       LOCATION OF VALUE
          ZR     X5,ZDATA2   IF EMPTY DATA STRING 
          MX6    0           GO TO BOTTOM OF WORD 
          SA6    POSCTR 
          SA2    LWORD
          MX3    0
          BX4    X3 
          SX6    X1+B1
          SX7    X5-1 
          SA6    A1 
          SA7    A5 
          SA1    X1 
          RJ     BINOUT      CALL BINOUT(VALUE,LWORD,0,0) 
          SA1    P2TEMPA
          SX2    36 
          SX3    20 
          SA4    MACHINE
          ZR     X4,ZDATA1A  IF CPU 
          SX2    X2-11       CORRECT FOR PP 
          SA4    PPTYPE 
          SA3    PPBYT
          PL     X4,ZDATA1A 
          SB7    X4+2 
          MI     B7,ZDATA1A 
          SX4    X4+B1
          LX4    1
          IX2    X2+X4
          IX3    X3+X4
 ZDATA1A  SA1    X1-1 
          RJ     PACKO       CALL PACKO(VALUE,36-11*MACHINE,20 OR 4)
 ZDATA2   RJ     LISTERG
          SA1    P2TEMP 
          NZ     X1,ZDATA1   IF MORE IN THIS DATA STRING
          SA1    CHAR        TEST FOR END OF STATEMENT
          SB7    X1-1R
          ZR     B7,Z100
          RJ     GETCH
          EQ     ZDATA0 
 DECMIC   SPACE  4
***       DECMIC - DECIMAL CONVERSION.
* 
* 
*MNAME    DECMIC AEXP1,AEXP2
*         USING A DECIMAL CONVERSION, (AEXP1) IS CONVERTED INTO A 
*         CHARACTER STRING.  THE OPTIONAL PARAMETER (AEXP2) DEFINES 
*         THE LENGTH OF THE RESULTING MICRO.  IF THE FIELD IS LARGER
*         THAN REQUIRED, THE CHARACTERS ARE RIGHT JUSTIFIED WITH
*         LEADING ZERO FILL.  IF (AEXP2) IS BLANK, THE CHARACTER
*         STRING HAS LEADING ZERO SUPPRESSION.  A ZERO STRING 
*         WILL PRODUCE ONE ZERO.  MAXIMUM LENGTH IS 10 CHARACTERS.
*         (MNAME) IS THE MICRO NAME.
  
  
          QUAL   PASS1
 DECMIC   SX6    3
          SX1    60 
          RJ     SCADCON
          SA1    EXVAL
          RJ     CDEC 
 DMC1     SA6    P1TEMP 
          SX6    3
          SX1    15 
          RJ     SMC
          SA2    P1TEMP 
          SA1    EXVAL
          BX6    X2 
          MX7    0
          SA6    RELVEC 
          SA7    A6+B1
          SX6    B1 
          ZR     X1,DMC4     IF CHARACTER COUNT = 0 
          SX7    X1-10
          SX6    3
          NG     X1,ERA      IF COUNT < 0 
          ZR     X7,DMC3     IF COUNT = 10
          PL     X7,ERA      IF COUNT > 10
          BX7    X1 
          IX2    X1+X1
          LX1    2
          IX3    X2+X1
          MX0    1
          SB7    X3-1 
          SA1    RELVEC 
          AX0    X0,B7
          SB7    X3-60
          AX6    X1,B7
          BX6    X0*X6
          BX6    X6+X7
          SA6    A1 
          SX6    B1+B1
 DMC3     RJ     EMT         ENTER MICRO TABLE
          EQ     CTL300      RETURN 
 DMC4     SA3    RELVEC      SUPPRESS LEADING ZEROS 
          SA2    =1L0 
          MX0    6
          BX7    X3 
          SB7    10 
 DMC5     BX3    X0*X7
          BX3    X3-X2
          NZ     X3,DMC6     IF NON-ZERO CHARACTER
          BX7    -X0*X7 
          SB7    B7-B1
          LX7    6
          NZ     X7,DMC5     IF NOT ALL ZEROS 
          SB7    B1 
          BX7    X2 
 DMC6     SX1    B7          CHARACTER COUNT
          SB7    B7-10
          IX7    X7+X1
          ZR     B7,DMC7     IF NO LEADING ZEROS
          SX6    B1+B1
          SA7    A3 
          EQ     DMC3 
 DMC7     SX6    3
          EQ     DMC3 
 DECMIC   SPACE  4
**        DECMIC - DECIMAL CONVERSION.
  
  
          QUAL   PASS2
 DECMIC   SX6    3
          SX1    60 
          RJ     SCADCON
          NZ     X1,ZLIST    IF ERRORS
          SA1    EXVAL       OUTPUT VALUE IN OCTAL
          SX2    36 
          MX3    0
          RJ     PACKO
          JP     ZLIST       RETURN 
 DIS      SPACE  4
***       DIS - DISPLAY CODED LINES.
* 
* 
*SYM      DIS    AEXP,STRING
*SYM      DIS    ,*STRING*
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         (AEXP) IS THE WORD COUNT.  (AEXP)*10 (CP) OR (AEXP)*2 (PP)
*         CHARACTERS BEYOND THE *,* ARE EXTRACTED.  IF (AEXP) IS BLANK
*         OR ZERO, THE FIRST CHARACTER AFTER THE COMMA IS CONSIDERED
*         A DELIMITER, AND CHARACTERS ARE EXTRACTED UNTIL THE 
*         DELIMITER IS ENCOUNTERED AGAIN. 
  
  
          QUAL   PASS1
 DIS      SA1    LWORD
          RJ     YPRLOC      PROCESS LOCATION 
          SX6    3           EVALUATE WORD COUNT
          SX1    15 
          RJ     SMC
          SA1    EXSTOP 
          SA2    EXVAL
          SA3    AERR 
          SA4    UERR 
          BX5    X3+X4
          LX3    X2 
          NZ     X5,CTL70    QUIT IF ERROR IN WORD COUNT FIELD
          ZR     X1,ERA      IF NO COMMA AFTER EXPRESSION 
          NZ     X2,DIS1     IF WORD COUNT NON-ZERO 
          SA2    COLUMN 
          SX6    1RC
          SX7    X2-1        DELIMITED STRING, EFFECTIVELY
          SA6    CHAR        REPLACE *,* WITH *C* AND 
          SA7    A2          MAKE SCAN BEGIN THERE
          MX4    0
          SX2    VALUES 
          SX3    NLITS
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM 
          MX2    0
          SA5    AERR 
 DIS1     BX6    X2 
          NG     X2,ERA      IF WORD COUNT IS NEGATIVE
          LX1    X3 
          NZ     X5,ERA      IF A-ERROR 
          SA6    FLAG 
          RJ     YUPLOC 
          EQ     CTL70
 DIS      SPACE  4
**        DIS - DISPLAY CODED LINES.
  
  
          QUAL   PASS2
 DIS      SA1    LWORD
          RJ     ZPRLOC      PROCESS LOCATION 
          MX7    0
          SX6    3
          SX1    15 
          SA7    LOCSYM 
          RJ     SMC         EVALUATE WORD COUNT
          SA1    AERR        CHECK IF PASS 1 FOUND ANY ERRORS 
          SA2    UERR        IN THE WORD COUNT FIELD
          SA3    FLAG 
          BX1    X1+X2
          NZ     X1,ZLIST    EXIT IF ERRORS 
          NZ     X3,DIS1     IF WORD COUNT NON-ZERO 
          SA2    COLUMN 
          SX6    1RC
          SX7    X2-1        DELIMITED STRING, EFFECTIVELY
          SA6    CHAR        REPLACE *,* WITH *C* AND 
          SA7    A2          MAKE SCAN BEGIN THERE
          SX2    VALUES 
          SX3    NLITS
          MX4    0
          SA5    LWORD
          BX6    X2 
          SA6    P2TEMP 
          RJ     SCD         SCAN DATA ITEM 
 DIS1     SA2    LWORD
          BX6    X3          STORE WORD COUNT 
          SA6    P2TEMPA
          RJ     ZPRLOC      LIST LOCATION VALUE
          SA1    FLAG 
          SA2    P2TEMP 
          NZ     X1,DIS2     IF NOT DELIMITED 
          SA1    X2          NEXT VALUE WORD
          SX6    X2+B1       INCREMENT ADDRESS
          BX7    X1 
          SA6    A2 
          EQ     DIS4 
 DIS2     SA1    CHAR        CONSTRUCT BINARY WORD BY COLLECTING
          SA2    NCHARS      CHARACTERS AND CONVERTING THEM 
          SA3    CT 
          SA4    PPTYPE      CHECK PPTYPE TO SET UP MASK
          MX0    -6 
          PL     X4,DIS2.5   IF NOT BCU, MCU, OR 180 PPU
          MX0    -8 
 DIS2.5   BSS    0
          BX7    X7-X7
          SB6    X2 
          SB7    X3 
 DIS3     SA1    X1+STCA     CONVERT CHARACTER
          AX2    X1,B7
          BX3    -X0*X2                                                 P069   7
          LX7    6
          SB6    B6-B1
          SX1    B7-45
          NZ     X1,DIS3A    IF NOT ASCII CONVERSION
          LX7    2
          SX3    X3+ASC6T8   CONVERT 6-BIT ASCII TO 8-BIT 
 DIS3A    BSS    0
          BX7    X7+X3
          RJ     GETCH
          NZ     B6,DIS3     IF NOT END OF WORD 
          BX1    X7 
 DIS4     SA2    LWORD
          SX3    B0 
          MX4    0
          BX6    X3          POSITION AT BOTTOM OF WORD 
          SA7    VALUES      SAVE VALUE WORD
          SA6    POSCTR 
          RJ     BINOUT      CALL BINOUT(VALUE,LWORD,0,0) 
          SA4    MACHINE
          SX2    36 
          SX3    20 
          ZR     X4,*+2 
 +        SX2    X2-11       CORRECT FOR PP 
          SA3    PPBYT
 +        SA1    VALUES      RECLAIM VALUE WORD 
          RJ     PACKO       CALL PACKO(VALUE,36-11*MACHINE,20 OR 4)
          RJ     LISTERG     LIST LINE
          SA1    P2TEMPA
          SX3    X1-1        DECREMENT WORD COUNT 
          NZ     X3,DIS1     LOOP IF MORE 
          EQ     Z100 
 DM       SPACE  4
***       DM - DIRECT MOVE (CMU INSTRUCTION). 
* 
* 
*         DM     L,KS,CS,KD,CD
*         (L) = DATA FIELD LENGTH IN CHARACTERS (@127). 
*         (KS) = SOURCE FIELD FIRST WORD ADDRESS. 
*         (CS) = SOURCE FIELD FIRST CHARACTER POSITION (0-9). 
*         (KD) = DESTINATION FIELD FIRST WORD ADDRESS.
*         (CD) = DESTINATION FIELD FIRST CHARACTER POSITION (0-9).
  
  
          QUAL   PASS1
 DM       EQU    CC 
 DM       SPACE  4
**        DM - DIRECT MOVE (CMU INSTRUCTION). 
  
  
          QUAL   PASS2
 DM       SX6    465B 
          EQ     CC1
 DUP      SPACE  4
***       DUP - DUPLICATION.
* 
* 
*NAME     DUP    AEXP1,AEXP2
*         (NAME) IS BLANK OR AN INSTRUCTION BRACKET NAME.  (AEXP1) IS 
*         THE REPLICATION COUNT.  (AEXP2) IF PRESENT SPECIFIES THE
*         NUMBER OF SUCCEEDING LINES TO BE ASSEMBLED. 
  
  
          QUAL   PASS1
 DUP      SX6    3           EVALUATE REPLICATION COUNT 
          SX1    15 
          RJ     SMC
          SA2    LOCSYM 
          BX6    X2 
          SX1    B1+B1
          SA6    P1TEMP      SAVE LOCATION SYMBOL AS BRACKET NAME 
          SA3    EXVAL
          MX0    45          TRUNCATE DUP COUNT TO 15 BITS
          BX3    -X0*X3 
          SX7    X3+B1
          SA7    P1TEMPA     SAVE REPLICATION COUNT 
          SX6    X1+B1
          SX1    15 
          RJ     SMC         EVALUATE CARD COUNT
          SA1    EXVAL
          BX7    X1 
          SA7    FLAG        SAVE CARD COUNT IN FLAG
          SA1    L.DUPTAB    SAVE DUPTABLE SIZE 
          BX6    X1 
          SA6    P1TEMPB
          RJ     CRL         CHECK RECURSION LIMIT                      S004  11
 DUP1     RJ     CWI
          SX6    B1          SET TEXT DEFINITION FLAG 
          MX7    0           CLEAR PUSHUP FLAG
          SA6    TXTFLG 
          SA7    PUSHUP 
          RJ     INPUT1 
          NZ     X1,DUP6     IF PUSHUP OCCURRED 
          RJ     SETUP
          SA1    STYPE
          SA2    IOP
          SB7    X1-1R* 
          SX3    3REND
          ZR     B7,DUP1     IF COMMENTS CARD 
          BX3    X3-X2
          ZR     X3,END      IF END CARD
          SA1    EXVAL
          SX6    X1-1        DECREMENT CARD COUNTER 
          SA6    A1 
          ZR     X6,DUP2     IF END OF COUNT CONTROLLED UP
          PL     X6,DUP3     IF STILL IN COUNT CONTROLLED DUP 
          SA1    IOP         CHECK FOR AN ENDD CARD 
          SA2    =0RENDD
          BX3    X1-X2       CHECK THE LOCATION SYMBOLS 
          NZ     X3,DUP3     IF NOT *ENDD*
          SA1    LOCSYM 
          SA2    P1TEMP 
          IX3    X1-X2
          ZR     X1,DUP4     IF LOCATION FIELD BLANK
          ZR     X2,DUP4     IF NO BRACKET NAME 
          ZR     X3,DUP4     IF BRACKET NAMES MATCH 
 DUP3     PCARD  TEMTAB      PACK CARD INTO TEMTAB
          EQ     DUP1        AND CONTINUE TO ENTER DEFINITIONS
  
*         END OF DEFINITION BECAUSE OF ENDD STATEMENT.
  
 DUP4     RJ     CWI         WRITE ENDD CARD
          MX6    0
          SX7    1R 
          SA6    SQLGN       PERMIT REPACKING 
          SA5    CARD 
          SA7    A5 
 +        SA5    A5+B1       CLEAR
          BX4    X7-X5       OUT
          SA7    A7+B1       LOCATION 
          NZ     X4,*-1      SYMBOL 
          EQ     DUP5 
  
*         END OF DEFINITION BECAUSE OF COUNT EXHAUSTED. 
  
 DUP2     RJ     CWI
 DUP5     PCARD  TEMTAB      PACK AWAY LAST CARD
          SA1    L.TEMTAB    MOVE TEXT TO DUPTAB
          MANAGE DUPTAB,X1
          SA1    L.TEMTAB 
          IX2    X2+X3
          IX3    X2-X1
          SA2    O.TEMTAB 
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
          MX7    0           CLEAR TEXT FLAG
          SX1    1RT
          LX1    54 
          SA7    L.TEMTAB    DELETE TEXT IN TEMTAB
          SA7    TXTFLG 
          ADDWORD DUPTAB     ADD WORD TO DUP TABLE
          SA1    L.DUPTAB 
          SX1    X1-1 
          SA3    P1TEMPA
          SA4    =5R*DUP* 
 +        SX2    B1+B1
          SA5    A3+B1
          RJ     PUSHDOWN 
          SX6    B1 
          MX7    0
          SA6    ECHFLG 
          SA7    TXTFLG 
          EQ     CTL100 
  
*         ILLEGALLY NESTED DUP. 
  
 DUP6     RJ     ASU         ACCUMULATE STORAGE USED
          SX6    B1          SET *E* ERROR
          MX7    0
          SA6    EFLG 
          SA7    L.TEMTAB    CLEAR TEMTAB 
          SA6    EERR 
          SA7    TXTFLG 
          EQ     CTL105      PROCESS CARD 
 DUP      SPACE  4
**        DUP - DUPLICATE CODE. 
  
  
          QUAL   PASS2
 DUP      SX6    3
          SX1    15 
          RJ     SMC
          NZ     X1,ZLIST 
          SA1    EXVAL
          MX0    -15
          BX1    -X0*X1 
          SX2    36 
          MX3    0
          RJ     PACKO
          EQ     ZLIST
 ECHO     SPACE  4
***       ECHO - DUPLICATE CODE.
* 
* 
*NAME     ECHO   LNCT,P1,(LIST1),...,PN,(LISTN) 
*         ARGUMENTS (PI) MUST START WITH A LETTER, UP TO 63 MAY BE
*         LISTED, TERMINATED BY SPECIAL CHARACTERS ,.+-*/()$=.
*         (LISTI) IS A LIST OF ARGUMENTS TO BE SUBSTITUTED.  SUBSEQUENT 
*         INSTRUCTIONS UNTIL AN (ENDD) ARE THE ECHO SKELETON.  IF 
*         (LNCT) IS PRESENT, (LNCT) LINES MAKE UP THE ECHO SKELETON.
*         (NAME) IS THE BRACKET NAME. 
  
  
          QUAL   PASS1
 ECHO     SX6    3           EVALUATE CARD COUNT
          SX1    15 
          RJ     SMC
          SA1    LOCSYM      SAVE BRACKET NAME
          BX6    X1 
          MX7    0
          SA6    P1TEMPE
          SA7    P1TEMPA     CLEAR PARAMETER COUNT
          SA7    PUSHUP      CLEAR PUSHUP FLAG
          SA1    L.MARGS     SAVE TABLE LENGTHS 
          SA2    L.MARDIS 
          SA3    L.ECHTAB 
          LX1    36 
          LX2    18 
          BX6    X1+X2
          BX6    X6+X3
          SA6    P1TEMPB
 ECH1     RJ     PMACF       ISOLATE FORMAL PARAMETER 
          NZ     X6,ECH2     IF NAME FOUND
          RJ     PMACE       SKIP VALUE 
          NZ     X7,ECH1     LOOP IF NOT END OF CARD
          EQ     ECH4 
 ECH2     RJ     PMA         PACK MACRO ARGUMENT
          UX1,B7             SETUP DESCRIPTOR WORD... 
          SB7    -B7
          PX1    B7          - CHARACTER COUNT
          LX1    59-41
          PX1    B0          CHARACTER OFFSET 
          LX1    41-29
          PX1    B0          WORD OFFSET
          LX1    29-59
          ADDWORD MARDIS
          SA1    CHAR        CHECK FOR END OF FIELD 
          SB7    X1-1R
          NZ     B7,ECH1     LOOP TO END OF ECHO
 ECH4     SX6    B1 
          SA6    TXTFLG 
          RJ     CRL         CHECK RECURSION LIMIT                      S004  13
          RJ     CWI         WRITE CARD 
 ECH5     RJ     INPUT1      READ NEXT CARD 
          NZ     X1,ECH9     IF PUSHUP OCCURRED 
          RJ     SETUP
          SA1    =0RENDD
          RJ     PEC         PROCESS END CARD 
          RJ     PDC         PROCESS DEFINITION CARD
          PCARD  TEMTAB 
          SA2    EXVAL       CHECK LINE COUNT 
          SX6    X2-1 
          SA6    A2 
          ZR     X6,ECH6     IF END OF COUNT
          PL     X6,ECH5     IF IN LINE COUNT CONTROL 
          SA1    P1TEMPD
          ZR     X1,ECH5     IF NOT ENDD CARD 
 ECH6     SA1    P1TEMPA
          ZR     X1,ECH8     IF NO PARAMETERS 
          SA2    O.MARDIS 
          SA3    L.MARDIS 
          IX2    X2+X3
          SB2    X1 
          SB3    X2 
 ECH7     SA1    B3-B2       CHECK ARGUMENT VALUES
          SB2    B2-B1
          UX6,B7 X1 
          ZR     B7,ECH8     IF NULL ARGUMENT 
          NZ     B2,ECH7     LOOP 
          SX1    1RT         PACK TERMINATOR
          LX1    -6 
          ADDWORD TEMTAB
          SA1    L.TEMTAB    MOVE TEXT TO ECHTAB
          MANAGE ECHTAB,X1
          SA1    L.TEMTAB 
          IX2    X2+X3
          IX3    X2-X1
          SA2    O.TEMTAB 
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
          MX7    0           CLEAR TEXT FLAG
          SA7    TXTFLG 
          SA7    L.TEMTAB    CLEAR TEMTAB 
          SA1    P1TEMPB     PUSH DOWN STACK
          SX2    5
          SX1    X1 
          BX3    X1 
          SA4    =6R*ECHO*
          MX5    0
          RJ     PUSHDOWN 
          SA1    O.STACK     RESET MARGS AND MARDIS ORG 
          SA2    L.STACK
          IX1    X1+X2
          SA2    X1-3 
          SA1    P1TEMPB
          MX0    -36
          AX1    18 
          BX6    X0*X2
          IX6    X6+X1
          SA6    A2 
          SX6    B1          SET ECHO FLAG
          SA6    ECHFLG 
          EQ     CTL100      RETURN 
  
*         ENTRY ON NO PARAMETERS OR AT LEAST ONE NULL ARGUMENT. 
  
 ECH8     RJ     ASU         ACCUMULATE STORAGE USED
          SA1    P1TEMPB     RESTORE TABLE LENGTHS
          AX1    18 
          SX6    X1 
          AX1    18 
          SX7    X1 
          SA6    L.MARDIS 
          SA7    L.MARGS
          BX6    X6-X6
          SA6    L.TEMTAB    CLEAR TEMTAB 
          SA6    TXTFLG      CLEAR TEXT FLAG
          EQ     CTL100      RETURN 
  
*         ENTRY ON ILLEGAL NESTING OF ECHO. 
  
 ECH9     RJ     ASU         ACCUMULATE STORAGE USED
          MX7    0           CLEAR TEXT FLAG
          SA7    TXTFLG 
          SX6    B1          SET *E* ERROR
          SA7    L.TEMTAB 
          SA6    EFLG 
          SA1    P1TEMPB
          SA6    EERR 
          SA2    L.MARDIS 
          AX1    18 
          SX6    X1 
 +        IX5    X2-X6
          PL     X5,*+1      IF MARDIS WAS NOT PUSHED UP
          SX6    X2 
          SA6    A2          PUSHUP MARDIS
          SA2    L.MARGS
          AX1    18 
 +        IX5    X2-X1
          PL     X5,*+1      IF MARGS WAS NOT PUSHED UP 
          SX1    X2 
          BX6    X1          PUSHUP MARGS 
          SA6    A2 
          EQ     CTL105      PROCESS CARD 
 ECHO     SPACE  4
**        ECHO - DUPLICATE CODE.
  
  
          QUAL   PASS2
 ECHO     EQU    ZLIST
 EJECT    SPACE  4
***       EJECT - START NEW PAGE. 
* 
* 
*NAME     EJECT 
*         A NEW PAGE IS STARTED AND (NAME) IS THE NEW SUB-SUBTITLE. 
  
  
          QUAL   PASS1
 EJECT    EQU    CTL300 
 EJECT    SPACE  4
**        EJECT - START NEW PAGE. 
  
  
          QUAL   PASS2
 EJECT    RJ     ZTLIST      TEST FOR LISTINGS IN FORCE 
          SX6    B1 
          SA1    LPCNT       CAUSE PAGE EJECT 
          SA2    NEJF        *N* CONTROLLED PAGE SIZE 
          SA6    CTYPE
          IX7    X1+X2
          SA7    A1 
          EQ     ZLIST
 ELSE     SPACE  4
***       ELSE - UNCONDITIONALLY SKIP/ASSEMBLE CODE.
* 
* 
*NAME     ELSE   LNCT 
*         IF CODE IS BEING SKIPPED, ELSE TERMINATES THE IF-SKIPPING.
*         IF CODE IS BEING ASSEMBLED, ELSE INITIATES IF-SKIPPING. 
*         (LNCT) IS THE OPTIONAL SKIP LINE COUNT.  (NAME) IS THE
*         INSTRUCTION BRACKET NAME. 
  
  
          QUAL   PASS1
 ELSE     SA1    LOCSYM 
          SA2    IFNAME 
          SA3    IFCNT
          ZR     X3,IFXXNO   IF COUNT EXHAUSTED 
          IX4    X2-X1
          ZR     X1,ELS1     IF NO INSTRUCTION BRACKET NAME 
          ZR     X4,ELS1     IF NAMES MATCH 
          EQ     CTL70
  
 ELS1     MX6    0           CLEAR COUNT
          SA6    A3 
          EQ     CTL300 
 ELSE     SPACE  4
**        ELSE - UNCONDITIONAL SKIP/ASSEMBLE CODE.
  
  
          QUAL   PASS2
 ELSE     EQU    ZLIST
 END      SPACE  4
***       END - END OF SUBPROGRAM.
* 
* 
*SYM      END    TRASYM 
*         (SYM) IS ASSIGNED THE VALUE OF LWA+1. 
*         (TRASYM) IS AN OPTIONAL TRANSFER ADDRESS VALID ONLY FOR 
*         RELOCATABLE ASSEMBLIES. 
  
  
          QUAL   PASS1
 END      SA1    STYPE       CHECK WHICH END CARD THIS IS 
          SA2    L.STACK
          SB7    X1-1RE 
          ZR     B7,END1     IF OUR END CARD
          NZ     X2,CTL80    IF GENERATED END CARD
          SX6    B1 
          SA4    TXTFLG 
          MX7    0
          SA7    A4 
          SA6    OERR 
          SA6    EFLG 
          SA7    IFCNT
          ZR     X4,END1A 
          SX6    /PASS2/END 
          MX1    1
          BX6    X6+X1
          SA6    OPTYPE 
          RJ     WINTER      WRITE OUT ERRONEOUS END CARD 
 END1A    MX7    0
          SX6    1RE
          SA7    SQLGN       ALLOW REPACKING OF CARD
          SA6    STYPE       SET E FOR END CARD TYPE
          SX1    2*NCARDS    SAVE SEQUENCE FIELDS 
          SX2    SEQ
          SX3    ENDSEQ 
          RJ     MOVE 
          EQ     HEREPK      PACK END CARD
  
*         FINAL END CARD. 
  
 END1     RJ     COB         CLOSE OUT ALL BLOCKS 
          RJ     ASU         ACCUMULATE STORAGE USED
          MX7    0
          SA7    RMTFLG 
          BX6    X7 
          SA6    IFCNT
          SA7    L.STACK
          SA6    MACFLG 
          SA7    ECHFLG 
          SA6    TXTFLG 
          SA7    LIBFLG 
          SA7    SYSFLG 
          SA6    XLEV                                                   P036  26
          SA7    L.RMTAB
          SA6    L.RASTAB 
          SA7    L.DUPTAB 
          SA6    L.MARDIS 
          SA7    L.MARGS
          SA6    L.LASTAB 
          RJ     GSM         GENERATE SYSTEMS MACRO TEXT
          SA1    LSYSMAC     RESET MACRO DEFINITIONS
          SA2    EOFINP 
          BX6    X1 
          MX7    0
          SA7    L.MICTAB 
          SA6    L.MACDEF 
          ZR     X2,END2     IF NOT LAST ASSEMBLY OF BATCH
          MX6    0
          SA7    L.SSYMS     CLEAR SYSTEM TEXT TABLES 
          SA6    A6 
          SA7    L.SYSMIC 
          SA6    SSTCNT 
 END4     SA7    L.OPTAB     CLEAR OPCODE TABLE 
          EQ     END5A
 END2     SA1    LCMOPC 
          NZ     X1,END4     IF OPCODE TABLE IS IN LCM
          SA1    L.OPTAB     CLEAR OUT INSERTIONS FROM OPTAB BY 
          MANAGE DUPTAB,X1   RE-DOING IT
          BX1    X3 
          LX3    X2 
          SA2    O.OPTAB
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
          SA2    O.OPTAB
          SX6    2*NOPCT
          IX3    X6+X2
          SA6    L.OPTAB
          RJ     CLS         CLEAR OPCODE TABLE 
          SB7    57 
 END5     SA3    O.DUPTAB 
          SA4    L.DUPTAB 
          SX6    X3+2 
          SX7    X4-2 
          SA1    X3          LOAD OPCODE ENTRY
          SA2    X3+B1
          MX5    12 
          BX3    -X5*X1 
          ZR     X4,END5A    IF END OF TABLE
          SA6    A3 
          SA7    A4 
          AX4    X2,B7
          SX0    B1 
          BX5    X4+X0
 +        LX2    59-47
          NZ     X5,*+1      IF NOT A MACRO 
          LX2    47-57
 +        ZR     X3,END5     IF ZERO WORD 
          MI     X2,END5     IF PROGRAMMER DEFINED
          BX1    X3 
          SA2    A2 
          RJ     ENTOP       ENTER OPCODE TABLE 
          SB7    57 
          EQ     END5 
 END5A    SX1    2*NCARDS    RESTORE SEQUENCE FIELDS
          SX2    ENDSEQ 
          SX3    SEQ
          RJ     MOVE 
          RJ     DSL         DEFINE SYMBOL LITERALS 
          SA1    UI+1        RELOCATE USE TABLE 
          RJ     RUT
          BX6    X0          PROGRAM LENGTH 
          LX6    39          EXTEND SIGN
          AX6    39 
          SA6    ENDP 
          SA6    ORGCTR 
          MX6    0
          SA6    A6+B1
          LX2    X0 
          SA5    ABSFG
          SX3    B1+B1
          IX3    X3-X5
          IX6    X3-X5
          SA6    A6+B1
          SX4    0
          IX5    X5-X5
          RJ     YDEFLOC     DEFINE END CARD LOCATION SYMBOL
          RJ     RST         RELOCATE SYMBOL TABLE
 END7     SA1    L.SEGTAB 
          SA2    SI 
          IX7    X1-X2
          SX7    X7-4 
 +        NZ     X7,*+1      IF SEGMENT CARDS 
          RJ     RSL         RECORD SEGMENT LENGTH
          RJ     AVO         ADVANCE OVERLAY
          RJ     RSS         RECORD SEGMENT START 
          RJ     RSL         RECORD SEGMENT LENGTH
          RJ     RSG         RELOCATE SEGMENT TABLE 
          RJ     WINTER 
          RJ     RCD         RESTORE CHARACTER DATA 
          MX6    0
          SA6    EFLG        CLEAR ERROR FLAGS THAT MAY 
          SA6    W1ERR       HAVE BEEN SET BY *DSL* 
  
          IFNE   CP#RM,0,3
          SA1    INTERIO
          NZ     X1,END8     IF INTERMEDIATE ON DISK
          ADDWORD INTER      ADD A JUNK WORD TO INTERMEDIATE FOR READ 
  
          SA1    INTERIO
          ZR     X1,END3     IF NO DISK INTERMEDIATE
  
          IFEQ   CP#RM,0,3
          WRITER S           COMPLETE SCRATCH 
          REWIND S
          ELSE   2
 END8     PUT    S,P1TEMPA,10 JUNK WORD FOR RINTER READ AHEAD 
          REWINDM S 
  
 END3     BSS    0
          SA1    /DATA/STCW  RESET CHARACTER STORE FOR 6-BIT/NON-ASCII
          BX6    X1 
          SA6    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          EQ     EXITP1      EXIT FROM PASS 1                            F4810B 
 END      SPACE  4
**        END - END OF SUBPROGRAM.
  
  
          QUAL   PASS2
 END      SA5    STYPE       CHECK WHOSE END CARD THIS IS 
          SB7    X5-1RE 
          NZ     B7,ZLIST    IF NOT OURS
  
 RM       IFEQ   CP#RM,0
          REWIND S
 RM       ELSE
          SA1    INTERIO
          ZR     X1,ZEND0    IF NO INTERMEDIATE OVERFLOW
          REWINDM S 
 RM       ENDIF 
  
 ZEND0    RJ     ZFUALL      FORCE UPPER ON ALL BLOCKS
          RJ     PLT         PRINT LITERAL TABLE
          SA1    ABSFG       SET TO END OF PROGRAM
          SA2    ENDP 
          SA3    UI+1 
          BX6    X2 
          IX7    X3-X1
          SA6    ORGCTR 
          SX7    X7+B1
          SA7    A6+B1
          SA6    LOCCTR 
          SA7    A6+B1
          MX1    0
          RJ     ZPRLOC 
          RJ     SCLIST      SCAN POTENTIAL TRANSFER NAME 
          SA1    ABSFG       CHECK VALIDITY OF TRANSFER NAME
          NZ     X1,ZEND1 
          RJ     VFYLINK
          SA6    LOCSYM      SAVE TRANSFER NAME 
          ZR     X7,ZEND1    IF NO FORMAT ERROR                         S002  43
          SX7    B1                                                     S002  44
          SA7    AERR 
          SA7    EFLG 
 ZEND1    RJ     LIST2L      PRINT *END* CARD AND A BLANK LINE          P057   7
          MX6    0                                                      P057   9
          SA6    L.INTER     CLEAR INTERMEDIATE TABLE 
  
*         TERMINATE BINARY OUTPUT.
  
          RJ     DBSSZ       DUMP BSSZ CODE 
          RJ     DLAST       DUMP TERMINAL LOADER CARDS 
          RJ     DDUMP       DUMP ABSOLUTE BINARY OUTPUT
          SA2    B
          ZR     X2,ZEND10   IF NO BINARY FILE
          SA1    LOCSYM 
          SA2    ABSFG
          ZR     X1,ZEND3    IF NO TRANSFER NAME
          NZ     X2,ZEND3    IF ABSOLUTE ASSEMBLY 
          RJ     LJUST
          SA1    =46000001BS36
          BX6    X1 
          SA7    BINREC+1 
          SA6    A7-B1
  
 RM       IFEQ   CP#RM,0
          WRITEW B,A6,2      DUMP XFER CARD 
 RM       ELSE
          SA1    B-1
          NZ     X1,ZEND2    IF NOT *W* RECORDS 
          PUT    B,BINREC,20
          EQ     ZEND3
 ZEND2    PUTP   B,BINREC,20
 RM       ENDIF 
  
 ZEND3    WEOR   B
          SA1    /DATA/STCW  RESET CHARACTER STORE FOR 6-BIT/NON-ASCII
          BX6    X1 
          SA6    /DATA/STC0  *** SAFE CODE-MODIFICATION *** 
          SA1    ERCNT
          SA2    CP.ERRCT 
          SA3    SYNAME 
          SA4    DKCNT
          ZR     X1,ZEND7    IF NO ERRORS 
          MI     X2,ZEND7    IF *D* OPTION SET (DEBUG MODE) 
          ZR     X3,ZEND5    IF NO SYSTEM TEXT GENERATED
          SX4    X4+B1
 ZEND5    RJ     BKS         ERASE ALL BINARY OUTPUT INCLUDING SYSTEXT
          SA1    CP.ABORT 
          LX1    59-29
          MI     X1,ZEND8    IF *A* OPTION SET (ABORT IF ERROR) 
  
 RM       IFEQ   CP#RM,0
  
          SB6    =C*ERRORS IN ASSEMBLY* 
          WRITEW X2,B6,2
          WRITER X2          WRITE ERROR RECORD 
          EQ     ZEND10 
 ZEND7    ZR     X3,ZEND10   IF NO SYSTEM TEXT GENERATED
          RJ     BKS         ERASE ALL NON-SYSTEXT BINARY OUTPUT
 ZEND8    WRITEF X2          WRITE EOF AND BACKSPACE OVER IT
          BKSP   X2 
  
 RM       ELSE
  
          PUT    B,ZENDB,20  *ERRORS IN ASSEMBLY* 
          SA1    B-1
          NZ     X1,ZEND10   IF NOT *W* RECORDS 
          WEOR   B
          EQ     ZEND10 
 ZEND7    ZR     X3,ZEND10   IF NO SYSTEM TEXT GENERATED
          RJ     BKS         ERASE ALL NON-SYSTEXT BINARY OUTPUT
 ZEND8    ENDFILE B 
          SX4    B1          WRITE EOF AND BACKSPACE OVER IT
          RJ     BKS
  
 RM       ENDIF 
  
*         RESTORE SYSTEM SYMBOL TABLE.
  
 ZEND10   RJ     ASU         ACCUMULATE STORAGE USED
          SA1    SSTCNT 
          MX6    0
          SB7    ERRTAB-QVTAB-2 
          SA6    L.QVTAB+1
 +        SB7    B7-B1       EMPTY TABLES NO LONGER NEEDED
          SA6    A6+B1
          NZ     B7,* 
          SA6    L.MEMORY 
          ZR     X1,ZEND20   IF NO SYSTEM SYMBOLS DEFINED 
          LX1    1
          MANAGE SSYMS,X1    MAKE ROOM IN SYSTEM SYMBOL TABLE 
          IX2    X2+X3
          SA3    SSTCNT 
          SB7    X3 
          SA1    O.SYMTAB 
          SA3    =00000007000007777777B 
          SB5    -B1
          SB6    59-32
          SX1    X1+B1
 ZEND15   RX5    X1 
          SX4    X1+B5
          SX1    X1+2 
          LX6    X5,B6
          PL     X6,ZEND15   IF NOT A SYSTEM SYMBOL 
          RX4    X4 
          SX2    X2-2 
          SB7    B7-B1
          BX7    X3*X5       COPY SYMBOL TABLE ENTRY
          LX6    X4          TO SYSTEM SYMBOL TABLE 
          SA7    X2+B1
          SA6    X2 
          NZ     B7,ZEND15
          RJ     ASU         ACCUMULATE STORAGE USED
  
*         PRODUCE ASSEMBLER STATISTICS. 
  
 ZEND20   SA1    =H*STORAGE USED* 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    LINE 
          SA7    A6+B1
          SA1    REFIO
          SA2    LR+1 
          SA3    MAXCORE
          ZR     X1,ZEND26   IF NO REFTAB OVERFLOW
          ZR     X2,ZEND26   IF NO REFERENCE WANTED 
          SA1    LOSTREF
          SX6    PRTB 
          SB7    L.QVTAB-L.INTER
          IX6    X6+X1
          SA1    L.INTER+1
 ZEND23   SB7    B7-B1       COMPUTE STORAGE NEEDED BY PASS 3 
          IX6    X6+X1
          SA1    A1+B1
          NZ     B7,ZEND23
          IX2    X3-X6
          PL     X2,ZEND26   IF NOT GREATER THAN MAXCORE
          BX3    X6          UPDATE MAXCORE 
          SA6    A3 
 ZEND26   SX2    100B+10D    ADD THE TEN UNUSED WORDS AND 
          MX0    -6          INCREASE TO NEXT MULTIPLE OF 100B
          IX3    X3+X2
          BX1    X0*X3
          SA2    PPTYPE 
          BX7    X2          SAVE PPTYPE
          MX6    0           CLEAR PPTYPE SO MEMORY USED IS OCTAL 
          SA6    A2 
          SA7    ZENDC
          SX2    34                                                     S028 416
          MX3    0
          RJ     PACKO
                                                                        S028 418
          IF     DEF,MODL76 
          SA1    =5RB SCM    ASSEMBLED IF MODEL 76 ASSEMBLY (SCM) 
          ELSE   1
          SA1    =5RB CM     ASSEMBLED IF NOT MODEL 76 ASSEMBLY 
                                                                        S028 423
          MX0    -6                                                     S028 424
          BX6    -X0*X1                                                 S028 425
          SA6    OCTAL+38                                               S028 426
          AX1    6                                                      S028 427
 +        BX6    -X0*X1                                                 S028 428
          AX1    6                                                      S028 429
          SA6    A6-B1                                                  S028 430
          NZ     X1,*-1                                                 S028 431
          SA3    ALCM        MAXIMUM ECS/LCM USED                       S028 432
          ZR     X3,ZEND28   IF NONE                                    S028 433
                                                                        S028 434
          IF     -DEF,LCMTYP
          SA1    =5RB ECS                                               S028 436
          ELSE   1
          SA1    =5RB LCM                                               S028 438
                                                                        S028 439
          BX6    -X0*X1                                                 S028 440
          SA6    OCTAL+26                                               S028 441
          AX1    6                                                      S028 442
 +        BX6    -X0*X1                                                 S028 443
          AX1    6                                                      S028 444
          SA6    A6-B1                                                  S028 445
          NZ     X1,*-1                                                 S028 446
          SX2    100B+10D    ADD THE TEN UNUSED WORDS AND               S028 447
          IX3    X3+X2       INCREASE TO NEXT MULTIPLE OF 100B          S028 448
          BX1    X0*X3                                                  S028 449
          SX2    22                                                     S028 450
          MX3    0                                                      S028 451
          RJ     PACKO                                                  S028 452
 ZEND28   SA1    ZENDC       RESTORE PPTYPE FOR REFERENCE TABLE 
          BX6    X1 
          SA6    PPTYPE 
          SA1    STCNT       STATEMENT COUNT
          RJ     CONDEC 
          SA1    =10HSTATEMENTS 
          LX6    6
          BX7    X1 
          SA6    LINE+2 
          SA7    A6+B1
          SA1    SYMCNT      OUTPUT SYMBOL COUNT
          RJ     CONDEC 
          SA1    =H*SYMBOLS*
          LX6    6
          BX7    X1 
          SA6    LINE+4 
          SA7    A6+B1
          SA1    INVENT      OUTPUT INVENTED SYMBOL COUNT 
          SA2    =6R000000
          MX0    24 
          BX6    -X0*X1 
          BX1    X6-X2
          ZR     X1,ZEND30   IF NO INVENTED SYMBOLS 
          SA2    =4L
          SA3    =H*INVENTED SYMBOLS* 
          SA1    A3+B1
          IX6    X6+X2
          LX6    6
          BX7    X3 
          SA6    A7+B1
          SA7    A6+B1
          BX6    X1 
          SA6    A7+B1
 ZEND30   RJ     LISTL
          SA1    TLINE       ASSEMBLY TIME MESSAGE
          SA6    LINE 
          MX2    1
          MX0    -6 
 ZEND30.1 BX6    -X0*X1 
          SA6    A6-B1
          LX1    -6 
          LX2    6
          PL     X2,ZEND30.1
          SA2    A1+B1
          BX6    X1 
          SA3    A2+B1
          LX7    X2 
          SA7    LINE 
          BX6    X3 
          SA6    A7+B1
          SB7    ATIME
          RJ     CPTIME      CONVERT ASSEMBLY TIME
          SA6    LINE+2 
          SA1    =0HSECONDS 
          BX6    X1 
          SA6    A6+B1
          MX6    0
          SA1    LOSTREF
          RJ     CONDEC 
          SA1    =H*REFERENCES* 
          LX6    6
          SA6    LINE+4 
          BX7    X1 
          SA7    A6+B1
          RJ     LIST2L 
  
  
*         DECODE ERROR COUNT FOR LISTINGS AND DISPLAY.
  
          SA1    IDNAM
          SA2    DKNAM
          BX6    X2-X1
          ZR     X6,ZEND40   IF IDNAM = DKNAM 
          RJ     DIM         DISPLAY IDENT MESSAGE
 ZEND40   SA1    WECNT
          ZR     X1,ZEND50   IF NO WARNING ERRORS 
          RJ     CONDEC      CONVERT TO DECIMAL 
          SA6    ZMSG 
          SB7    X6-3R  1 
          SA1    ASMM+1 
          SA2    =H* WARNING M* 
          SA3    =H*ESSAGE IN ESSAGES IN* 
          BX6    X2 
          SA6    A6+B1
 +        ZR     B7,*+1      IF 1 ERROR 
          SA3    A3+B1
 +        LX7    X3 
          BX6    X1 
          SA7    A6+B1
          SA6    A7+B1
          JOBMSG ZMSG,R 
 ZEND50   SA1    ERCNT
          ZR     X1,ZEND60   IF NO FATAL ERRORS 
          RJ     CONDEC      CONVERT TO DECIMAL 
          SA6    LINE 
          SB7    X6-3R  1 
          SA2    =H+ ERRORS IN+ 
          SA1    IDNAM
 +        NZ     B7,*+1 
          SA2    =H+ ERROR IN+
          BX7    X2 
          SA6    ZMSG 
          SA7    A6+B1
          SA7    LINE+1 
          RJ     LJUST
          LX6    54 
          SA6    LINE+2 
          SA1    ASMM+1 
          BX6    X1 
          SA6    ZMSG+2 
          MESSAGE ZMSG,,R 
          RJ     LISTERF
  
*         PRINT ERROR DIRECTORY.
  
 ZEND60   RJ     PET         PROCESS ERROR TABLE
          SA1    L.ERRTAB 
          ZR     X1,ZEND90
          SA1    =1H         SET UP SUBTITLE
          SX2    SUBTIT 
          SX3    SUBTIT+8 
          RJ     PRESET 
          SA1    LPCNT       CAUSE PAGE EJECT 
          SA2    PSIZE
          IX7    X1+X2
          SA7    A1 
          SA1    =H*        ERROR DIRECTORY.* 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    SUBTIT 
          SA7    A6+B1
          SA1    A2+B1
          BX6    X1 
          SA6    A7+B1
          SA2    PSIZE
          NZ     X2,ZEND61   IF PAGE EJECT NOT SUPPRESSED 
          SX0    2           ELSE PRINT BLANK LINES 
          RJ     LBL
          SA1    LPCNT       CHECK FOR END OF PAGE
          SX0    2
          SA2    CP.PS
          IX6    X1+X0       INCREMENT LINE COUNT 
          IX2    X6-X2
          SA6    A1 
          PL     X2,ZEND61
          RJ     LHDS        AND PRINT SUBTITLE LINE
 ZEND61   BSS    0
          SA1    O.ERRTAB    SORT THE ERROR TABLE 
          SA2    L.ERRTAB 
          MX0    60 
          RJ     DSORT
          MX6    0
          SA6    P2TEMP      INDEX TO ERRTAB
 ZEND64   SA1    =10HTYPE ERROR 
          MX0    54 
          BX6    -X0*X1 
          SB7    9
          SA6    OCTAL+25 
 +        SB7    B7-B1
          AX1    6
          BX6    -X0*X1 
          SA6    A6-B1
          NZ     B7,*-1 
          SA1    P2TEMP 
          SA2    O.ERRTAB 
          IX0    X1+X2
          SA1    X0          ERRTAB ENTRY 
          BX7    X1 
          AX1    30          ISOLATE ERROR TYPE 
          BX4    X1 
          SA2    X1+ERRLETS 
          BX6    X2 
          LX1    2
          IX0    X1+X4
          SA7    P2TEMPB     ERROR TYPE 
          SA6    OCTAL+14 
          SA2    X0+ERDIR    FETCH COMMENTS 
          SA3    A2+B1
          BX6    X2 
          LX7    X3 
          SA2    A3+B1
          SA4    A2+B1
          SA1    A4+B1
          SA6    LINE 
          SA7    A6+B1
          BX6    X2 
          LX7    X4 
          SA6    A7+B1
          SA7    A6+B1
          BX6    X1 
          SA6    A7+B1
          RJ     LISTERF
          SA1    1+=20H   OCCURRED ON PAGES 
          MX0    54 
          SB2    B1 
          SX6    1R 
          SA6    OCTAL+38 
 ZEND68   BX6    -X0*X1 
          SB7    9
          SA6    A6-B1
 +        AX1    6
          BX6    -X0*X1 
          SB7    B7-B1
          SA6    A6-B1
          NZ     B7,*-1 
          SB2    B2-B1
          SA1    A1-B1
          PL     B2,ZEND68
          MX6    0
          SA6    P2TEMPA     ELEMENT COUNT
  
 ZEND70   SA1    P2TEMP      TABLE INDEX
          SA2    A1+B1       ELEMENT COUNT
          SA3    A2+B1       OLD ENTRY
          SA4    O.ERRTAB 
          IX0    X1+X4
          SX6    B1+X1
          SA4    X0          FETCH ENTRY
          BX7    X4-X3
          SA6    A1 
          AX7    30 
          NZ     X7,ZEND80   IF END OF PAGE LIST FOR THIS ERROR 
          SA3    L.ERRTAB 
          IX7    X3-X6
          MI     X7,ZEND82   IF END OF TABLE
          SX6    X4 
          SX7    X2-9 
          SA6    P2TEMPC
          NZ     X7,ZEND75   IF LINE NOT FULL 
          SA7    A2 
          RJ     LISTL
 ZEND75   SA1    P2TEMPC
          RJ     CONDEC 
          LX6    6
          SX0    B1 
          SA2    P2TEMPA
          SX7    X2+B1
          IX6    X6+X0
          SA6    X2+LINE
          SA7    A2 
          EQ     ZEND70 
  
 ZEND80   BX6    X1          RESET LOOP COUNTER 
          SA6    A6 
 ZEND82   SA1    P2TEMPA
          SA2    X1+LINE-1
          SX0    B1 
          IX6    X2-X0
          SA6    A2 
          RJ     LIST2L 
          SA1    P2TEMP 
          SA2    L.ERRTAB 
          IX6    X1-X2
          MI     X6,ZEND64   IF NOT END OF TABLE
          SA6    A2 
  
*         PROCESS REFERENCE TABLE.
  
 ZEND90   RJ     PRT         PROCESS REFERENCE TABLE
  
*         MAINTAIN LISTING OUTPUT PAGE PARITY.
  
          MX6    42 
          SA1    E
          BX1    X6*X1
          ZR     X1,ZEND92   IF NO ERROR LIST 
          SA1    CP.EPAG
          MX6    2
          BX6    X6*X1       SAVE ERROR PAGE PROPAGATION FLAG 
          SA2    EPCNT
          BX6    X6+X2       INSERT ERROR PAGE COUNT FOR THIS SUBROUTINE
          ZR     X2,ZEND91   IF ERROR PAGE COUNT ZR DONT MODIFY CP.EPAG 
          SA6    A1          ELSE MODIFY CP.EPAG
 ZEND91   SA1    CP.PAGE
          PL     X1,ZEND92   IF PAGE PROPAGATION ON 
          SX6    B0 
          SA6    EPCNT       CLEAR ERROR FILE PAGE COUNT
 ZEND92   SA1    CP.LISTF 
          ZR     X1,ZEND98   IF LONG LIST OFF 
 ZEND95   SA1    EOFINP 
          SA2    PGCNT
          ZR     X1,ZEND96   IF NOT END OF SOURCE INPUT 
          SA1    CP.BLF 
          ZR     X1,ZEND98   IF BL IS OFF.
          LX2    -1 
          SX6    B1 
          PL     X2,ZEND98   IF PAGE COUNT IS EVEN
          LX2    1
          IX6    X2+X6       ADD ONE TO PAGE COUNT
          SA6    A2 
  
          IFEQ   CP#RM,0,2
          WRITEW O,(=2L1 ),1 WRITE BLANK PAGE 
          ELSE   1
          PUT    O,ZENDA,10 
  
          EQ     ZEND98 
 ZEND96   SA1    CP.PAGE
          PL     X1,ZEND98   IF PROPAGATING PAGE NUMBERS
          LX2    -1 
          SX6    B0          CLEAR PAGE COUNT 
          SA6    A2 
          PL     X2,ZEND97   IF PAGE COUNT WAS EVEN 
          SA1    CP.BLF 
          ZR     X1,ZEND97   IF PAGE PARITY SUPPRESSED
  
          IFEQ   CP#RM,0,2
          WRITEW O,(=2L1 ),1 WRITE BLANK PAGE 
          ELSE   1
          PUT    O,ZENDA,10 
  
 ZEND97   SA1    E
          ZR     X1,ZEND98   IF NO ERROR FILE 
          WEOR   O
  
*         FINAL WRAPUP. 
  
 ZEND98   MX6    0
          SA6    L.SYMTAB    EMPTY ASSEMBLY TABLES
          SB7    NTABLES-USETAB-1 
          SA6    L.USETAB 
 +        SB7    B7-B1
          SA6    A6+B1
          NZ     B7,* 
          EQ     EXITP2      EXIT FROM PASS2
  
          IFNE   CP#RM,0,2
 ZENDA    LIT    1H1
 ZENDB    DATA   C+ERRORS IN ASSEMBLY+
 ZMSG     BSS    4           ROOM FOR ERROR MESSAGE 
 ZENDC    BSS    1           PPTYPE 
 ENDD     SPACE  4
***       ENDD - END DUPLICATION. 
* 
* 
*NAME     ENDD
*         TERMINATES RANGE OF (DUP) IF SECOND ADDRESS EXPRESSION WAS
*         OMITTED IN PRECEDING (DUP).  (NAME) IS AN INSTRUCTION 
*         BRACKET NAME. 
  
  
          QUAL   PASS1
 ENDD     EQU    CTL300 
 ENDD     SPACE  4
**        ENDD - END DUPLICATION. 
  
  
          QUAL   PASS2
 ENDD     EQU    ZLIST
 ENDIF    SPACE  4
***       ENDIF - CONDITIONAL ASSEMBLY TERMINATOR.
* 
* 
*NAME     ENDIF 
*         (NAME) IS THE INSTRUCTION BRACKET NAME OR BLANK.
*         (ENDIF) IS IGNORED IF IT APPEARS WITHIN A LINE COUNT
*         CONTROLLED RANGE. 
  
  
          QUAL   PASS1
 ENDIF    SA1    IFCNT
          SA2    LOCSYM 
          SA3    IFNAME      BRACKET NAME 
          PL     X1,CTL300
          IX4    X2-X3       COMPARE LOCSYM WITH IF LABEL 
          ZR     X4,ENDIF1   JUMP ON A MATCH
          ZR     X2,ENDIF1   OR IF ENDIF HAS BLANK LOCSYM 
          NZ     X3,CTL300
 ENDIF1   MX6    0
          SA6    A1 
          EQ     CTL300 
 ENDIF    SPACE  4
**        ENDIF - CONDITIONAL ASSEMBLY TERMINATOR.
  
  
          QUAL   PASS2
 ENDIF    EQU    ZLIST
 ENDM     SPACE  4
***       ENDM - MACRO TERMINATOR.
* 
* 
*NAME     ENDM
*         (NAME) IS INSTRUCTION BRACKET NAME.  (ENDM) TERMINATES
*         A MACRO OR OPDEF DEFINITION.
  
  
          QUAL   PASS1
 ENDM     EQU    CTL300 
 ENDM     SPACE  4
**        ENDM - MACRO TERMINATOR.
  
  
          QUAL   PASS2
 ENDM     EQU    ZLIST
 ENDX     SPACE  4
***       ENDX - END OF COMMON DECK TEXT. 
* 
* 
*         ENDX
*         CLEAR XTEXT FLAG FOR LIST CONTROL.
  
  
          QUAL   PASS1
 ENDX     RJ     CWI         WRITE INTERMEDIATE 
          SA1    XLEV        DECREASE NESTING LEVEL                     P036  28
          ZR     X1,CTL100   IGNORE IF NO MATCHING *CTEXT*
          SX6    X1-1                                                   P036  29
 +        NZ     X6,*+1                                                 P036  30
          SA6    LIBFLG      CLEAR XTEXT FLAG                           P036  31
 +        SA6    A1                                                     P036  32
          EQ     CTL100      READ NEXT CARD 
 ENDX     SPACE  4
**        ENDX - END OF COMMON DECK TEXT. 
  
  
          QUAL   PASS2
 ENDX     EQU    ZLIST
 ENTRY    SPACE  4
***       ENTRY - ENTRY POINTS. 
* 
* 
*         ENTRY  SYM1,SYM2,...,SYMN 
*         DECLARES ENTRY POINTS.  MAXIMUM OF 7 CHARACTERS PER SYMBOL
*         THE FIRST CHARACTER MUST BE A CHARACTER FROM A TO Z.
  
  
          QUAL   PASS1
 ENTRY    SA1    MACHINE
          NZ     X1,CTL80    ERROR IF PP CODING 
          MX6    0
          SA6    P1TEMP      CLEAR CONDITIONAL FLAG 
 ENTRY1   SA1    CHAR 
          SB7    X1-1R
          ZR     B7,CTL70    STOP ON BLANK
          RJ     SCLIST      FETCH NEXT ITEM
          ZR     X6,ENTRY1   IGNORE EMPTY FIELD 
          RJ     VFYLINK     CHECK SYMBOL FORMAT
          ZR     X7,ENTRY2
          SX6    B1 
          SA6    AERR        NOTE BAD SYMBOL
          SA6    EFLG 
          EQ     ENTRY1      GO BACK FOR MORE 
 ENTRY2   SA1    O.EPTAB     SEARCH EPTAB FOR THIS ENTRY
          SA2    L.EPTAB
          SA3    P1TEMP 
          SB7    X2-1 
          ZR     X2,ENTRY4   IF TABLE EMPTY 
          MX0    1
 ENTRY3   SA5    X1+B7
          SB7    B7-B1
          BX4    -X0*X5 
          IX2    X6-X4
          ZR     X2,ENTRY5   IF DUPLICATE NAME
          PL     B7,ENTRY3
 ENTRY4   BX1    X6+X3
          ADDWORD EPTAB      ADD ENTRY TO EPTAB 
          EQ     ENTRY1 
 ENTRY5   IX1    X6+X3       CLEAR CONDITIONAL FLAG IF SYMBOL IS
          BX6    X1*X5       DECLARED BY BOTH *ENTRY* AND *ENTRYC*
          SA6    A5 
          EQ     ENTRY1      AND RETURN FOR MORE ENTRY POINTS 
 ENTRY    SPACE  4
**        ENTRY - ENTRY POINTS. 
  
  
          QUAL   PASS2
 ENTRY    SA1    EFLG 
          NZ     X1,ZLIST    IF ERROR IN PASS 1 
          SX6    1RE
          SA6    REFLET 
          MX1    0           SET BLANK QUALIFIER
          RJ     SQV
 ENT1     SA1    CHAR 
          SB7    X1-1R
          ZR     B7,ENT6     STOP ON BLANK
          RJ     SCLIST      FETCH NEXT ITEM
          ZR     X6,ENT1     IGNORE EMPTY FIELD 
          MX7    0
          BX1    X6 
          SA7    EXERR
          RJ     ZTLUSYM     LOOK UP SYMBOL 
          SA1    ELVAL       SET U-ERROR IF EXTERNAL
          SA2    ELEXT
          SX6    B1 
          SA3    EXERR       CHECK EXPRESSION ERROR 
          BX2    X3+X2
          SA4    ELREL
          NZ     X2,ENT4     IF BAD ENTRY POINT 
          SX7    X4-402B
          MI     X7,ENT1     IF NOT NEGATIVE COMMON RELOCATION
 ENT3     SA6    NERR 
          EQ     ENT5 
 ENT4     SA6    UERR 
 ENT5     SA6    EFLG 
          EQ     ENT1        LOOP 
 ENT6     SA1    QVAL+1      RESTORE QUAL VALUE 
          SX6    1R 
          BX7    X1 
          SA6    REFLET 
          SA7    A1-B1
          EQ     ZLIST
 ENTRYC   SPACE  4
***       ENTRYC - CONDITIONAL ENTRY POINTS.
* 
* 
*         ENTRYC SYM1,SYM2,...,SYMN 
*         DECLARES CONDITIONAL ENTRY POINTS.  MAXIMUM OF 7 CHARACTERS 
*         PER SYMBOL.  FIRST CHARACTER MUST BE A LETTER FROM A TO Z.
*         IN A RELOCATABLE ASSEMBLY, IF THE VALUE OF A CONDITIONAL
*         ENTRY POINT IS RELATIVE TO A COMMON BLOCK, LOADER IGNORES 
*         THE DECLARATION IF THAT COMMON BLOCK WAS FIRST DECLARED BY
*         AN EARLIER SUBPROGRAM.  IF SYMBOL VALUE IS ABSOLUTE OR
*         LOCAL, (ENTRYC) IS THE SAME AS (ENTRY). 
  
  
          QUAL   PASS1
 ENTRYC   SA1    ABSFG
          NZ     X1,ENTRY    IF ABSOLUTE ASSEMBLY 
          MX6    1
          SA6    P1TEMP      SET CONDITIONAL FLAG 
          EQ     ENTRY1 
 ENTRYC   SPACE  4
**        ENTRYC - CONDITIONAL ENTRY POINTS.
  
  
          QUAL   PASS2
 ENTRYC   EQU    ENTRY
 EQU      SPACE  4
***       EQU - SYMBOL DEFINITION.
* 
* 
*SYM      EQU    EXP
*         (SYM) IS ASSIGNED THE VALUE OF THE ADDRESS EXPRESSION.
  
  
          QUAL   PASS1
 EQU      SA1    LIBFLG 
          LX6    X1,B1
          EQ     EQU1 
 EQU      SPACE  4
**        EQU - SYMBOL DEFINITION.
  
  
          QUAL   PASS2
 EQU      MX6    0
          EQ     SETEQU 
 ERR      SPACE  4
***       ERR - FORCED ERROR. 
* 
* 
*TYPE     ERR 
*         AN ERROR OF TYPE (TYPE) IS PRODUCED.  IF (TYPE) IS MISSING
*         OR NOT VALID, A *P* ERROR IS PRODUCED.
  
  
          QUAL   PASS1
 ERR      EQU    CTL70
 ERR      SPACE  4
**        ERR - FORCED ERROR. 
  
  
          QUAL   PASS2
 ERR      SA1    LOCSYM      CHECK ERROR TYPE 
          SB7    LEFLG
          SA2    ERRLETS
          SB6    B0 
          SX7    B1 
 ERR1     BX6    X1-X2
          ZR     X6,ERR2     IF ERROR TYPE FOUND
          SB6    B6+B1
          SA2    A2+B1
          NE     B6,B7,ERR1  LOOP 
          SB6    PERR-ERFLAGS 
 ERR2     SA7    ERFLAGS+B6  SET ERROR
          SA7    EFLG 
          EQ     ZLIST
 ERRIF    SPACE  4
***       ERRXX - CONDITIONAL ERROR.
* 
* 
*TYPE     ERRXX  AEXP 
*         TESTS AEXP ACCORDING TO MNEMONIC TEST *XX*.  IF (TYPE) IS 
*         BLANK, A *P* ERROR IS GENERATED IF THE TEST IS TRUE.  IF
*         (TYPE) IS NOT BLANK, A (TYPE) ERROR IS GENERATED. 
* 
*             XX             TEST 
* 
*             MI             MINUS
*             NG             NEGATIVE 
*             NZ             NOT-ZERO 
*             PL             POSITIVE 
*             ZR             ZERO 
  
  
          QUAL   PASS1
 ERRMI    EQU    CTL70
 ERRNG    EQU    CTL70
 ERRNZ    EQU    CTL70
 ERRPL    EQU    CTL70
 ERRZR    EQU    CTL70
 ERRIF    SPACE  4
**        ERRXX - CONDITIONAL ERROR.
  
  
*TYPE     ERRMI  AEXP 
  
          QUAL   PASS2
 ERRMI    BSS    0
  
*TYPE     ERRNG  AEXP 
  
          QUAL   PASS2
 ERRNG    SX1    3
          EQ     EIF
  
*TYPE     ERRNZ  AEXP 
  
          QUAL   PASS2
 ERRNZ    SX1    1
          EQ     EIF
  
*TYPE     ERRPL  AEXP 
  
          QUAL   PASS2
 ERRPL    SX1    2
          EQ     EIF
  
*TYPE     ERRZR  AEXP 
  
          QUAL   PASS2
 ERRZR    SX1    0
*         EQ     EIF
 EIF      SPACE  4
**        EIF - ERROR IF CONDITION MET. 
  
  
 EIF      SA2    EIFB 
          LX1    21 
          BX6    X2+X1
          SA6    EIFA 
          SX1    60 
          SX6    3
          RJ     SCADCON
          SA1    EXVAL
          SX2    36 
          MX3    0
          RJ     PACKO       CALL PACKO(EXVAL,36,7) 
  
 EIFA     SA1    EXVAL       EXPRESSION TEST
          ZR     X1,ERR 
  
          EQ     ZLIST
  
 EIFB     SA1    EXVAL       EXPRESSION TEST
          ZR     X1,ERR 
 EXT      SPACE  4
***       EXT - EXTERNAL NAMES. 
* 
* 
*         EXT    SYM1,SYM2,,,,SYMN
*         DECLARES EXTERNAL NAMES.  MAXIMUM OF 7 CHARACTERS.
  
  
          QUAL   PASS1
 EXT      SA1    ABSFG
          NZ     X1,CTL80    COMPLAIN IF ABSOLUTE CODING
          MX1    0           SET BLANK QUALIFIER
          RJ     SQV
 EXT1     SA1    CHAR 
          SB7    X1-1R       QUIT ON BLANK
          ZR     B7,EXT5
          RJ     SCLIST 
          ZR     X6,EXT1     IGNORE EMPTY FIELD 
          RJ     VFYLINK
          ZR     X7,EXT2
          SX6    B1 
          SA6    AERR        COMPLAIN OF TOO LONG AN EXT NAME 
          SA6    EFLG 
          EQ     EXT1 
 EXT2     SA6    P1TEMP 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          LX2    59-31       CHECK IF EXTERNAL
          NG     X2,EXT4     JUMP IF ALREADY EXTERNAL 
          LX2    1
          NG     X2,EXT3     JUMP IF CURRENTLY DEFINED
          SA2    L.EXTAB
          SB7    X2-777B
          PL     B7,EXT4A    IF EXCEEDS 511 EXTERNALS 
          MANAGE EXTAB,1     EXTER INTO EXTAB 
          SB7    X3-1 
          SA1    P1TEMP 
          BX6    X1 
          SA6    X2+B7
          BX4    X3          EXTERNAL SYMBOL NUMBER 
          SX5    B0 
          BX1    X6 
          MX2    0
          SX3    B0 
          RJ     YDEFSYM     DEFINE SYMBOL
          EQ     EXT1        AND GO BACK FOR MORE 
 EXT4     RX4    X3          KNOWN EXTERNAL, FETCH EQUIVALENT 
          MX0    39 
          BX2    -X0*X4 
          NZ     X2,EXT3
          MX0    51 
          AX4    21 
          BX2    -X0*X4      EXTRACT EXTERNAL NUMBER
          SA3    O.EXTAB
          SB7    X3-1 
          SA4    X2+B7
          BX3    X4-X1
          ZR     X3,EXT1     ERROR IF NOT PRIMITIVE EXTERNAL
 EXT3     SX6    B1          COMPLAIN OF DUPLICATE SYMBOL 
          SA6    EFLG 
 +        SA6    DERR 
          EQ     EXT1 
  
 EXT4A    SX6    B1 
          SA6    EFLG 
          SA6    FERR 
 EXT5     SA1    QVAL+1      RESTORE QUAL VALUE 
          BX6    X1 
          SA6    A1-B1
          EQ     CTL300 
 EXT      SPACE  4
**        EXT - EXTERNAL NAMES. 
  
  
          QUAL   PASS2
 EXT      MX1    0                                                      S003   6
          RJ     SQV         SET BLANK QUALIFIER
 EXT1     SA1    CHAR 
          SB7    X1-1R
          ZR     B7,EXT2     STOP ON BLANK
          RJ     SCLIST      FETCH NEXT ITEM
          ZR     X6,EXT1     IGNORE EMPTY FIELD 
          BX1    X6                                                     S003   8
          RJ     TLUSYMT     LOOK UP SYMBOL 
          ZR     X3,EXT1     IF NOT FOUND                               S003  10
          SX1    1RX
          RJ     ENTREF      ENTER REFERENCE TABLE
          EQ     EXT1        LOOP 
 EXT2     SA1    QVAL+1      RESTORE QUAL VALUE 
          BX7    X1 
          SA7    A1-B1
          EQ     ZLIST
 HERE     SPACE  4
***       HERE - ASSEMBLE RMT CODE. 
* 
* 
*NAME     HERE
*         SAVED REMOTE INSTRUCTIONS ARE ASSEMBLED AT THIS POINT.
*         (NAME) = NAME OF LABELED REMOTE GROUP.
  
  
          SEG    PSEUDO-OP PROCESSING (F-Q).
          QUAL   PASS1
 HERE     SX6    1RT
          SA6    STYPE       SET TERMINATION
          SX7    B1 
          SA7    TXTFLG      SET TEXT DEFINITION FLAG 
          MX6    0           PERMIT REPACKING 
          SA6    SQLGN
          RJ     CRL         CHECK RECURSION LIMIT                      S004  15
          RJ     CWI
          SA1    L.RASTAB 
          BX6    X1 
          SA6    P1TEMP 
          SA1    LOCSYM 
          SA2    BADLOC 
          ZR     X1,HEREPK   IF UNLABELED RMT 
          SX6    B1 
          ZR     X2,HRE1     IF NO LOCATION ERROR 
          SA6    LERR 
          SA6    EFLG 
 HRE1     SA4    O.LRMTAB    SEARCH FOR START OF LABELED RMT
          SA3    L.LRMTAB 
          SB6    X4 
          SB7    B6+X3
          MX0    12 
          SA1    LOCSYM 
 HRE2     EQ     B6,B7,HRE6  IF END OF LABELED RMT
          SA2    B6 
          BX6    X2-X1
          SB6    B6+B1
          NZ     X6,HRE2     LOOP 
          SX7    B6          SEARCH FOR END OF GROUP
 HRE3     EQ     B6,B7,HRE4  IF END OF LABELED RMT
          SA2    B6 
          BX6    X0*X2
          SB6    B6+B1
          ZR     X2,HRE3     LOOP IF END-OF-LINE
          NZ     X6,HRE3     LOOP IF NOT NEXT LABEL 
          SB6    B6-B1
 HRE4     IX6    X7-X4       SET REMOTE INDEX 
          SA6    P1TEMPA
          SX2    B6          SET LENGTH 
          IX6    X2-X7
          SA6    A6+B1
          ZR     X6,HRE5     IF ZERO LENGTH RMT 
          MANAGE RASTAB,X6   TRANSFER TEXT
          SA1    P1TEMPB
          SA4    O.LRMTAB 
          SA5    A1-B1
          IX3    X2+X3
          IX3    X3-X1
          IX2    X4+X5
          RJ     MOVE 
          RJ     ASU         ACCUMULATE STORAGE USED
 HRE5     SA1    L.LRMTAB    DELETE TEXT FROM LRMTAB
          SA2    O.LRMTAB 
          SA3    P1TEMPA
          SA4    A3+B1
          SX5    B1 
          IX7    X2+X1
          IX3    X3+X2
          IX2    X3+X4
          IX3    X3-X5
          IX6    X2-X3
          IX6    X1-X6
          IX1    X7-X2
          SA6    A1 
          ZR     X6,HRE6     IF END OF LABELED RMT TABLE
          ZR     X1,HRE1     IF NO DATA TO MOVE 
          RJ     MOVE 
          EQ     HRE1        LOOP 
 HRE6     PCARD  RASTAB      PACK TERMINATION CARD
          SA4    LOCSYM 
          EQ     HEREPK1
  
*         END CARD PROCESSING COMES HERE TO ASSEMBLE ALL WAITING
*         RMT CODE. 
  
 HEREPK   PCARD  RMTAB       PACK TERMINATION CARD
          SA1    L.RASTAB 
          BX6    X1 
          SA6    P1TEMP 
          SA1    L.RMTAB
          MANAGE RASTAB,X1
          RJ     ASU         ACCUMULATE STORAGE USED
          SA2    O.RASTAB 
          SA3    L.RASTAB 
          SA1    L.RMTAB
          IX2    X3+X2
          IX3    X2-X1
          SA2    O.RMTAB
          MX6    0
          SA6    A1 
          RJ     MOVE 
          SA4    =5R*RMT* 
 HEREPK1  SA1    P1TEMP 
          SX2    3           TYPE 3 
          SX3    X1 
          MX5    0
          RJ     PUSHDOWN 
          SX6    B1 
          SA6    RMTFLG 
          MX7    0
          SA7    TXTFLG 
          EQ     CTL100 
 HERE     SPACE  4
**        HERE - ASSEMBLE RMT CODE. 
  
  
          QUAL   PASS2
 HERE     EQU    ZLIST
 IDENT    SPACE  4
***       IDENT - PROGRAM IDENTIFIER. 
* 
* 
*         IDENT  NAME,ORIGIN,ENTRY,L1,L2
*         IDENT DECLARES THE START OF THE PROGRAM.  IF IDENT OCCURS 
*         IN THE MIDDLE OF A PROGRAM, THE ACCUMULATED BINARY
*         IS WRITTEN OUT AND A NEW BINARY IS STARTED. 
*         (NAME) IS THE NAME OF THE OVERLAY GENERATED.
*         (ORIGIN) IS THE FIRST WORD ADDRESS OF THE OVERLAY.
*         FOR A CP ABSOLUTE PROGRAM - 
*                (ENTRY) SPECIFIES THE ENTRY POINT. 
*                (L1,L2) IS THE OVERLAY LEVEL NUMBER.  (0,0) IS 
*                ASSUMED FOR THE FIRST OVERLAY AND (1,0) IS 
*                ASSUMED IF (L1,L2) IS MISSING. 
  
  
          QUAL   PASS1
 IDENT    SA1    ABSFG
          ZR     X1,CTL80    IF RELOCATABLE CP CODE 
          RJ     COB         CLOSE OUT BLOCKS 
          MX6    0
          SA6    LOCSYM 
          RJ     DSL         DEFINE SYMBOL LITERALS 
          SA1    UI+1        RELOCATE USE TABLE 
          RJ     RUT
          BX6    X0          OVERLAY LENGTH 
          LX6    -21         EXTEND SIGN
          AX6    -21
          SA6    P1TEMP 
          SA1    ORGCTR+1    RELOCATE ORIGIN
 +        NZ     X1,*+1      IF NOT ABSOLUTE BLOCK
          SA1    UI+1 
          SA2    O.USETAB 
          SA3    UI 
          IX2    X2+X3       BASE ADDRESS OF BLOCK GROUP
          LX1    2
          IX3    X1+X2
          SA2    X3-2        BLOCK ORIGIN 
          SA1    ORGCTR 
          MX0    -21
          BX2    -X0*X2 
          IX6    X1+X2
          MX7    0
          SA6    A1 
          SA7    A6+B1
          RJ     RST         RELOCATE SYMBOL TABLE
          SA1    L.SEGTAB 
          SA2    SI 
          BX6    X1 
          IX7    X1-X2
          SA6    A2 
          SX7    X7-4 
          NZ     X7,IDT1     IF SEGMENT CARDS 
          SA1    P1TEMP      RESET ORG
          MX7    0
          BX6    X1 
          SA6    ORGCTR 
          SA7    A6+B1
          RJ     RSL         RECORD SEGMENT LENGTH
 IDT1     RJ     AVO         ADVANCE OVERLAY
          RJ     AUT         ALLOCATE USE TABLE 
          RJ     RSS         RECORD SEGMENT START 
          RJ     SCLIST      READ OVERLAY NAME
          RJ     VFYLINK                                                S002  47
          MX6    0           RESET ORG AND LOC COUNTERS 
          SA2    ORGCTR 
          BX7    X2 
          SA7    LOCCTR 
          SA6    A2+B1
          SA6    A7+B1
          ZR     X1,CTL70    IF NO NAME ON IDENT
          SA6    A2 
          SA6    A7 
          RJ     DIM         DISPLAY IDENT MESSAGE
          EQ     CTL70
 IDENT    SPACE  4
**        IDENT - PROGRAM IDENTIFIER. 
  
  
          QUAL   PASS2
 IDENT    SA1    ABSFG
          ZR     X1,ZLIST    IF RELOCATABLE CP CODE 
          RJ     ZFUALL      FORCE UPPER ALL BLOCKS 
          RJ     PLT         PRINT LITERAL TABLE
          RJ     DBSSZ       DUMP BSSZ CODE 
          RJ     DDUMP       WRITE BINARY 
          RJ     AEI         ADVANCE ENTRY INDEX
          SX6    0100B       SET DEFAULT (1,0) OVERLAY
          SX1    B0                                                     S002  49
          RJ     SIC         SCAN IDENT CARD
          SA1    P2TEMP      CHECK NAME 
          ZR     X1,IDT1     IF NO NAME 
          SA2    B
          ZR     X2,IDT0     IF NO BINARY FILE
          WEOR   B
 IDT0     SA1    P2TEMP      DUMP IDENT TABLE 
          SA2    A1+B1
          RJ     DFIRST 
          RJ     DLT         DUMP LITERAL TABLE 
          RJ     SMO         SET MAX AND MIN ORIGINS
          EQ     ZLIST
 IDT1     SA1    LPGM        SET NEXT ORG ADDRESS 
          BX6    X1 
          SA6    ORGBASE
          RJ     SBL         SET BINARY LENGTH
          RJ     DLT         DUMP LITERAL TABLE 
          RJ     SMO         SET MAX AND MIN ORIGINS
          SA1    ORGBASE     SET ORG AND LOC COUNTERS 
          BX7    X1 
          SA7    ORGCTR 
          SA7    LOCCTR 
          EQ     ZLIST
 IF       SPACE  4
***       IF - TEST SYMBOL OR EXPRESSION ATTRIBUTE. 
* 
* 
*NAME     IF     ATT,EXP,LNCT 
*         TESTS EXPRESSION (EXP) ACCORDING TO MNEMONIC TEST 
*         DEFINED BY (ATT).  A *-* PREFIX TO THE MNEMONIC CAUSES
*         ASSEMBLY ON A FALSE CONDITION.
*         (NAME) IS INSTRUCTION BRACKET NAME.  OPTIONAL COUNT (LNCT)
*         IS NUMBER OF LINES TO BE ASSEMBLED IF ATTRIBUTE IS TRUE.
* 
*           ATTRIBUTE        TEST 
* 
*              ABS           EXPRESSION ABSOLUTE. 
*              COM           EXPRESSION IS RELOCATABLE IN COMMON BLOCK. 
*              DEF           ALL SYMBOLS IN EXPRESSION HAVE BEEN
*                            DEFINED. 
*              EXT           EXTERNAL SYMBOL IN EXPRESSION. 
*              LCM           EXPRESSION IS RELOCATABLE IN ECS/LCM BLOCK.
*              LOC           EXPRESSION IS PROGRAM RELOCATABLE. 
*              MAC           NAME IS DEFINED MACRO, PSEUDO, OR PP INSTR.
*              MIC           NAME IS MICRO. 
*              REG           SYMBOL IN EXPRESSION IS REGISTER NAME. 
*              REL           EXPRESSION IS RELOCATABLE. 
*              SET           SYMBOL REDEFINABLE.
*              SST           SYMBOL DEFINED BY SST. 
  
  
          QUAL   PASS1
 IF       SA1    CHAR        TEST FOR LEADING MINUS SIGN
          SX6    X1-1R- 
          SA6    P1TEMP 
          NZ     X6,IF1 
          RJ     GETCH
 IF1      RJ     SCLIST      EXTRACT MODIFIER 
          SB7    LIFMODS-1
          MX0    42 
          LX6    18 
 IF2      SA2    IFMODS+B7
          BX3    X0*X2
          IX5    X3-X6
          SB7    B7-B1
          ZR     X5,IF3      IF MODIFIER FOUND
          PL     B7,IF2 
          EQ     CTL80       COMPLAIN IF NOT RECOGNIZED MODIFIER
 IF3      SB7    X2 
          JP     B7 
 IF       SPACE  4
**        ATTRIBUTES FOR IF.
  
  
 IFMODS   BSS    0
          VFD    42/0RLCM,18/IFLCM
          VFD    42/0RMAC,18/IFMAC
          VFD    42/0RMIC,18/IFMIC
          VFD    42/0RSET,18/IFSET
          VFD    42/0RSST,18/IFSST
          VFD    42/0RREL,18/IFREL
          VFD    42/0RABS,18/IFABS
          VFD    42/0RREG,18/IFREG
          VFD    42/0RCOM,18/IFCOM
          VFD    42/0RLOC,18/IFLOC
          VFD    42/0REXT,18/IFEXT
          VFD    42/0RDEF,18/IFDEF
 LIFMODS  EQU    *-IFMODS 
  
*         IF     LCM,EXP,LNCT 
  
 IFLCM    SX1    60 
          RJ     SCAD 
          SA1    EXREL
          SA2    O.USETAB 
          SA3    UI 
          SX6    B0 
          LX1    2
          ZR     X1,IF4      IF ABSOLUTE
          SB7    X1-4 
          IX2    X2+X3
          SA1    X2+B7       FETCH BLOCK NAME 
          MX6    1
          BX6    X6*X1       TRUE IF BLOCK NAME COMPLEMENTED
          EQ     IF4
  
*         IF     MAC,NAME,LNCT
  
 IFMAC    RJ     SCLIST      SCAN NAME
          BX1    X6 
          SX6    B1 
          ZR     X1,IF4      IF BLANK, CONDITION IS TRUE
          SA2    OPTYPE 
          BX6    X2          SAVE OPTYPE
          SA6    P1TEMPA
          RJ     TLUOP       LOOK UP OPCODE 
          SA1    P1TEMPA
          BX7    X1          RESTORE OPTYPE 
          SA7    OPTYPE 
          EQ     IF4
  
*         IF     MIC,NAME,LNCT
  
 IFMIC    RJ     SCLIST      LOOK UP SYMBOL 
          BX7    X6 
          MX6    0
          ZR     X7,IF4      IF NULL MICRO NAME 
          RJ     TLUMIC      LOOK UP MICRO
          SX6    B4 
          SX7    B1 
          SA7    FLAG 
          EQ     IF4
  
*         IF     SET,SYM,LNCT 
  
 IFSET    SX6    4           SET BIT MASK 
 IFS1     SA6    P1TEMPA
          SA1    CHAR 
          SB7    X1-1R/ 
          ZR     B7,IFS2     IF SLASH 
          RJ     SCITEM      SCAN UNQUALIFIED SYMBOL
          ZR     X6,IFS7     IF NO SYMBOL 
          BX1    X6 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          NZ     X3,IFS4     IF FOUND 
          EQ     IFS8 
 IFS2     RJ     GETCH       SKIP LEADING SLASH 
          SA1    CHAR 
          SX6    X1-1R/ 
          ZR     X6,IFS3     IF BLANK QUALIFIER 
          RJ     SCITEM      SCAN QUALIFIER NAME
          SB7    X1-1R/ 
          NZ     B7,IFS7     IF NO TRAILING SLASH 
 IFS3     BX1    X6 
          RJ     SQV         SET QUALIFIER VALUE
          RJ     GETCH       SKIP TRAILING SLASH
          RJ     SCITEM      SCAN SYMBOL
          ZR     X6,IFS6     IF NO SYMBOL 
          SA1    QVAL 
          BX1    X1+X6
          RJ     TLUSYMT     LOOK UP SYMBOL 
          SA4    QVAL+1 
          BX6    X4          RESTORE QUALIFIER VALUE
          SA6    A4-B1
          ZR     X3,IFS8     IF SYMBOL NOT FOUND
          SX3    X3-1 
          RX1    X3 
          BX4    X1-X5
          NZ     X4,IFS8     IF NOT SPECIFIED QUALIFIER 
 IFS4     SA1    P1TEMPA
          LX2    59-30
          BX6    X1*X2       EXTRACT BIT
          PL     X2,IFS8     IF SYMBOL NOT DEFINED
          SA1    CHAR        LOOK AT NEXT CHARACTER 
          SB7    X1-1R
          ZR     B7,IF4      IF BLANK 
          NE     B7,B1,IFS7  IF NOT COMMA 
          SA6    P1TEMPA
          RJ     GETCH       SKIP COMMA 
          SA1    P1TEMPA
          BX6    X1 
          EQ     IF4
 IFS6     SA4    QVAL+1      RESTORE QUALIFIER VALUE
          BX6    X4 
          SA6    A4-B1
 IFS7     SX6    B1          SET ADDRESS ERROR
          SA6    EFLG 
          SA6    AERR 
          EQ     CTL300 
 IFS8     SX6    B1          SET UNDEFINED SYMBOL ERROR 
          SA6    EFLG 
          SA6    UERR 
          EQ     CTL300 
  
*         IF     SST,SYM,LNCT 
  
 IFSST    SX6    2           SST BIT MASK 
          EQ     IFS1 
  
*         IF     REL,EXP,LNCT 
  
 IFREL    SX1    60 
          RJ     SCAD 
          SA1    EXREL
          BX6    X1 
          EQ     IF4
  
*         IF     ABS,EXP,LNCT 
  
 IFABS    SX1    60 
          RJ     SCAD 
          SA1    EXREL
          SA2    EXEXT
          MX6    0
          BX1    X2+X1
          NZ     X1,IF4 
          SX6    B1 
          EQ     IF4
  
*         IF     REG,EXP,LNCT 
  
 IFREG    SX6    B1          PREVENT U-ERRORS 
          SA6    IFDF 
          SX1    60 
          RJ     SCAD 
          SA1    EXREG
          BX6    X1 
          EQ     IFNOU
  
*         IF     COM,EXP,LNCT 
  
 IFCOM    SX1    60 
          RJ     SCAD 
          MX6    0
          SX5    B0 
          SA1    EXREL
 IFCOMLOC MX0    60-8 
          ZR     X1,IF4 
          BX1    -X0*X1 
          LX1    2
          SB7    X1-2 
          SA1    O.USETAB 
          SA3    UI 
          IX1    X1+X3
          SA2    X1+B7
          SX0    B1 
          BX3    X0*X2
          BX6    X5-X3
          EQ     IF4
  
*         IF     LOC,EXP,LNCT 
  
 IFLOC    SX1    60 
          RJ     SCAD 
          MX6    0
          SX5    B1 
          SA1    EXREL
          EQ     IFCOMLOC 
  
*         IF     EXT,EXP,LNCT 
  
 IFEXT    SX6    B1          PREVENT U-ERRORS 
          SA6    IFDF 
          SX1    60 
          RJ     SCAD 
          SA1    EXEXT
          BX6    X1 
          EQ     IFNOU
  
*         IF     DEF,EXP,LNCT 
  
 IFDEF    SX6    B1          PREVENT U-ERRORS 
          SA6    IFDF 
          SX1    60 
          RJ     SCAD 
          SA1    IFDF        UNDEFINED SYMBOL CAUSES IFDF = 2 
          SX6    X1-2 
*                            DEF EXT REG DONT GIVE U ERRORS 
 IFNOU    SX7    B0 
          SA7    IFDF        CLEAR IF DEF FLAG
          SX7    B1          SIGNAL PASS 2 TO PREVENT U-ERRORS
          SA7    FLAG 
          EQ     IF4A 
  
*         N.B.   X6 " 0 IF CONDITION TRUE, X6 = 0 IF FALSE. 
  
 IF4      SA1    UERR 
          NZ     X1,CTL70 
 IF4A     SA1    P1TEMP 
          ZR     X6,IF5      JUMP IF CONDITION FALSE
          ZR     X1,IFXXNO   IF TRUTH WANTED
          EQ     CTL300 
 IF5      NZ     X1,IFXXNO   JUMP IF FALSENESS WANTED 
          EQ     CTL300 
 IF       SPACE  4
**        IF - TEST SYMBOL OR EXPRESSION ATTRIBUTE. 
  
  
          QUAL   PASS2
 IF       SA1    LR+1        CHECK FOR REFERENCE AND F-LIST 
          SA2    LF+1 
          BX6    X1*X2
          ZR     X6,ZLIST    IF NO REFERENCE OF IF STATEMENTS 
          SA1    CHAR 
          SB7    X1-1R- 
 +        NZ     B7,*+1      SKIP MINUS PREFIX
          RJ     GETCH
 +        RJ     SCLIST      SCAN ATTRIBUTE NAME
          SX1    3RMIC
          SX2    3RMAC       AVOID CROSS-REFERENCING
          IX1    X1-X6       MICRO AND MACRO NAMES AS SYMBOLS 
          BX2    X2-X6
          ZR     X1,ZLIST    IF *MIC* 
          ZR     X2,ZLIST    IF *MAC* 
          SA1    FLAG        SET IF DEF FLAG FROM PASS 1
          BX6    X1 
          SA6    IFDF 
          SX6    1RF
          SA6    REFLET 
          SX1    60 
          RJ     SCAD 
          SX6    1R 
          SA6    REFLET 
          SX6    B0          CLEAR IF DEF FLAG
          SA6    IFDF 
          EQ     ZLIST       RETURN 
 IFC      SPACE  4
***       IFC - TEST CHARACTER STRINGS. 
* 
* 
*NAME     IFC    XX,*STRING1*STRING2*,LNCT
*         (NAME) IS INSTRUCTION BRACKET NAME.  OPTIONAL (LNCT) IS 
*         NUMBER OF LINES TO BE SKIPPED IF COMPARISON IS FALSE. 
*         DELIMITER IS ANY CHARACTER (*). (XX) IS A RELATIONAL MNEMONIC.
*         (-XX) IS THE OPPOSITE OF THE RELATIONAL MNEMONIC. 
* 
*           RELATION         COMPARISON OF FIELDS 
* 
*              EQ            EQUAL
*              NE            NOT EQUAL
*              GE            GREATER THAN OR EQUAL
*              LT            LESS THAN
*              LE            LESS THAN OR EQUAL 
*              GT            GREATER THAN 
  
  
          QUAL   PASS1
 IFC      SA1    CHAR        CHECK LEADING MINUS SIGN 
          SB7    X1-1R- 
          SX0    B0 
          MX4    12 
          NZ     B7,IFC1     IF FIRST CHAR WAS NOT -
          SX0    B1 
          RJ     GETCH       THROW AWAY MINUS SIGN
 IFC1     SB5    LIFCM-1
          RJ     SCITEM 
          LX6    48 
          SB7    X1-1R, 
          SX3    B1 
 +        SA5    IFCM+B5
          BX7    X5*X4
          SB5    B5-B1
          BX2    X7-X6
          ZR     X2,IFC2
          PL     B5,*-2 
          EQ     CTL80
 IFC2     NZ     B7,CTL80    ERROR IF MODIFIER NOT FOLLOWED BY ,
          SB6    X5 
          AX5    18 
          BX0    X5-X0       CORRECT FOR TRUTH CONDITION
          SA5    B6+X0
          BX6    X5 
          SX4    B1 
          MX0    0
          SA1    A1+B1       FETCH DELIMITER
          SA6    IFCT 
          SA2    LASTCOL
          BX7    X1 
          SA7    X2+CARD
          SA7    A7+B1
          SA2    A1+B1       SEARCH FOR SECOND DELIMITER
 +        BX5    X7-X2
          SA2    A2+B1
          NZ     X5,* 
          SA2    A2-B1
 IFC3     MI     X1,IFC3A    IF NOT AT END OF FIRST STRING
          SA1    A1+B1       FETCH NEXT CHARACTER 
          BX3    X1-X7
          NZ     X3,IFC3A    IF NOT DELIMITER 
          SX1    -1 
 IFC3A    MI     X2,IFC3B    IF NOT AT END OF SECOND STRING 
          SA2    A2+B1       FETCH NEXT CHARACTER 
          BX3    X2-X7
          NZ     X3,IFC3B    IF NOT DELIMITER 
          SX2    -1 
 IFC3B    NZ     X0,*+1      IF INEQUALITY HAS BEEN FOUND 
          IX0    X1-X2       MAKE STRING COMPARISON 
 +        PL     X2,IFC3     LOOP UNTIL END OF SECOND STRING
          SX6    A2-CARD+1
          SA6    COLUMN 
          SA1    LASTCOL
          IX2    X1-X6
          SX6    1R          RESTORE BLANKS AT END OF STATEMENT 
          SA6    X1+CARD
          SA6    A6+B1
          SX7    X7-1R
 +        ZR     X7,*+1      IF BLANK DELIMITER 
          NG     X2,IFC5     IF MISSING SECOND DELIMITER
          RJ     GETCH       THROW AWAY COMMA 
          SB7    X1-1R
          ZR     B7,IFCT     IF TERMINATOR IS BLANK 
          EQ     B7,B1,IFC4  IF TERMINATOR IS COMMA 
 IFC5     SX6    B1 
          SA6    AERR 
          SA6    EFLG 
          EQ     CTL70       RETURN 
 IFC4     RJ     GETCH       THROW COMMA AWAY 
          NZ     B7,IFCT
          RJ     GETCH       THROW KNOWN COMMA AWAY 
 IFCT     BSS    1
          EQ     IFXXNO 
  
*         TABLE OF RECOGNIZED MODIFIERS.
  
 IFCM     VFD    12/0REQ,30/0,18/IFCEQ
          VFD    12/0RNE,30/1,18/IFCEQ
          VFD    12/0RGE,30/0,18/IFCGE
          VFD    12/0RLT,30/1,18/IFCGE
          VFD    12/0RLE,30/0,18/IFCLE
          VFD    12/0RGT,30/1,18/IFCLE
 LIFCM    EQU    *-IFCM 
  
*         TABLE OF TRUE/FALSE TESTS.
  
 IFCEQ    ZR     X0,CTL70 
 +        NZ     X0,CTL70 
 IFCGE    PL     X0,CTL70 
 +        NG     X0,CTL70 
 IFCLE    ZR     X0,CTL70 
          NG     X0,CTL70 
 +        ZR     X0,IFXXNO
          PL     X0,CTL70 
 IFC      SPACE  4
**        IFC - TEST CHARACTER STRINGS. 
  
  
          QUAL   PASS2
 IFC      EQU    ZLIST
 IFXX     SPACE  4
***       IFXX - COMPARE VALUES.
* 
* 
*NAME     IFXX   EXP1,EXP2,LNCT 
*         TESTS (EXP1) AGAINST (EXP2) ACCORDING TO XX WHICH IS A
*         RELATIONAL MNEMONIC.  OPTIONAL (LNCT) IS NUMBER OF LINES
*         TO BE SKIPPED IF COMPARISON IS NOT SATISFIED.  (NAME) IS
*         INSTRUCTION BRACKET NAME. 
* 
*             XX             COMPARISON OF FIELDS 
* 
*             EQ             EQUAL
*             NE             NOT EQUAL
*             GT             GREATER THAN 
*             GE             GREATER THAN OR EQUAL
*             LT             LESS THAN
*             LE             LESS THAN OR EQUAL 
  
  
*         IFEQ   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFEQ     SA1    *+1
          EQ     IFXX 
          NZ     X1,IFXXNO
          ZR     X2,CTL300
  
*         IFNE   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFNE     SA1    *+1
          EQ     IFXX 
          NZ     X1,CTL300   TEST VALUE INEQUALITY
          NZ     X2,CTL300   TEST PROPERTY INEQUALITY 
  
*         IFGT   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFGT     SA1    *+1
          EQ     IFXX 
          ZR     X1,IFXXNO
          PL     X1,CTL300
  
*         IFGE   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFGE     SA1    *+1
          EQ     IFXX 
          ZR     X1,CTL300                                              S028 455
          PL     X1,CTL300
  
*         IFLT   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFLT     SA1    *+1
          EQ     IFXX 
          ZR     X1,IFXXNO
          NG     X1,CTL300
  
*         IFLE   EXP1,EXP2,LNCT 
  
          QUAL   PASS1
 IFLE     SA1    *+1
          EQ     IFXX 
          ZR     X1,CTL300
          NG     X1,CTL300
 IFXX     SPACE  4
**        IFXX - COMPARE VALUES.
  
  
          QUAL   PASS1
 IFXX     BX6    X1 
          SA6    IFXXT       STORE TRUTH TESTING INSTRUCTION
          SX1    60 
          RJ     SCAD        EVALUATE FIRST ADDRESS FIELD 
          SA1    EXVAL       RECORD PROPERTIES
          SA2    EXREL
          BX6    X1 
          SA6    P1TEMP      STORE FIRST VALUE
          LX2    18 
          SA3    EXREG
          SA4    EXEXT
          LX4    24+3 
          BX6    X4+X3
          IX7    X6+X2
          SA7    P1TEMPA     STORE PROPERTIES 
          SX1    60 
          RJ     SCAD        EVALUATE SECOND ADDRESS
          SA1    EXVAL
          SA2    EXEXT
          SA5    P1TEMP 
          SA3    EXREL
          SA4    EXREG
          IX1    X5-X1
          LX2    27 
          SA5    P1TEMPA
          LX3    18 
          IX2    X2+X3
          IX3    X2+X4
          BX2    X3-X5
          SA3    UERR 
          NZ     X3,CTL300
 IFXXT    PS
 IFXXNO   SX6    3
          SX1    15 
          RJ     SMC
          RJ     CWI
          SA1    EXVAL
          SA2    LOCSYM      SAVE BRACKET NAME
          SX6    X1+B1
          BX7    X2 
          SA6    IFCNT       SET SKIPPING COUNT 
          SA7    IFNAME 
          NZ     X1,CTL100
          SA1    UERR 
          NZ     X1,CTL100   IF LINE COUNT UNDEFINED
          SX6    -B1         SET TO SKIP UNTIL ENDIF
          SA6    IFCNT
          EQ     CTL100 
 IFXX     SPACE  4
**        IFXX - COMPARE VALUES.
  
  
          QUAL   PASS2
 IFEQ     BSS    0
 IFGE     BSS    0
 IFGT     BSS    0
 IFLE     BSS    0
 IFLT     BSS    0
 IFNE     BSS    0
          SA1    LR+1        CHECK FOR REFERENCE AND F-LIST 
          SA2    LF+1 
          BX6    X1*X2
          ZR     X6,ZLIST    IF NO REFERENCE OF IF STATEMENTS 
          SX6    1RF
          SA6    REFLET 
          SX1    60 
          RJ     SCAD 
          SX1    60 
          RJ     SCAD 
          SX6    1R 
          SA6    REFLET 
          EQ     ZLIST       RETURN 
 IFYY     SPACE  4
***       IFYY - TEST ASSEMBLY ENVIRONMENT. 
* 
* 
*NAME     IFYY   LNCT 
*         OPTIONAL (LNCT) IS NUMBER OF LINES TO SKIP IF CONDITION 
*         IS FALSE.  (NAME) IS INSTRUCTION BRACKET NAME.
* 
*             YY             CONDITION
* 
*             PP             PERIPHERAL ASSEMBLY IN PROGRESS
*             PP6            6000 PERIPHERAL ASSEMBLY IN PROGRESS 
*             PP7            7000 PERIPHERAL ASSEMBLY IN PROGRESS 
*             CP             CENTRAL ASSEMBLY IN PROGRESS 
*             CP6            6000 CENTRAL ASSEMBLY IN PROGRESS
*             CP7            7000 CENTRAL ASSEMBLY IN PROGRESS
  
  
*         IFPP   LNCT 
  
          QUAL   PASS1
 IFPP     SA1    MACHINE
          ZR     X1,IFXXNO
          EQ     CTL300      RETURN 
  
*         IFPP6  LNCT 
  
 IFPP6    SX6    2           FALSE IF MTYPE = 2 (7000 ASSEMBLY) 
          EQ     IFPP7A 
  
*         IFPP7  LNCT 
  
 IFPP7    SX6    1           FALSE IF MTYPE = 1 (6000 ASSEMBLY) 
 IFPP7A   SA1    MTYPE
          SA2    MACHINE
          BX3    X1-X6
          ZR     X2,IFXXNO   IF CENTRAL ASSEMBLY
          ZR     X3,IFXXNO   IF WRONG MTYPE 
          EQ     CTL300      RETURN 
  
*         IFCP   LNCT 
  
 IFCP     SA1    MACHINE
          NZ     X1,IFXXNO
          EQ     CTL300      RETURN 
  
*         IFCP6  LNCT 
  
 IFCP6    SX6    2           FALSE IF MTYPE = 2 (7000 ASSEMBLY) 
          EQ     IFCP7A 
  
*         IFCP7  LNCT 
  
 IFCP7    SX6    1           FALSE IF MTYPE = 1 (6000 ASSEMBLY) 
 IFCP7A   SA1    MTYPE
          SA2    MACHINE
          IX3    X1-X6
          NZ     X2,IFXXNO   IF PERIPHERAL ASSEMBLY 
          ZR     X3,IFXXNO   IF WRONG MTYPE 
          EQ     CTL300      RETURN 
 IFYY     SPACE  4
**        IFYY - TEST ASSEMBLY ENVIRONMENT. 
  
  
          QUAL   PASS2
 IFCP     EQU    ZLIST
 IFCP6    EQU    ZLIST
 IFCP7    EQU    ZLIST
 IFPP     EQU    ZLIST
 IFPP6    EQU    ZLIST
 IFPP7    EQU    ZLIST
 IFZZ     SPACE  4
***       IFZZ - TEST SIGN OF EXPRESSION VALUE. 
* 
* 
*NAME     IFZZ   EXPR,LNCT
*         TESTS SIGN OF VALUE OF (EXPR) ACCORDING TO ZZ.  OPTIONAL
*         (LNCT) IS NUMBER OF LINES TO BE SKIPPED IF CONDITION IS 
*         NOT SATISFIED.  (NAME) IS INSTRUCTION BRACKET NAME. 
* 
*             ZZ             CONDITION
* 
*             PL             SIGN IS PLUS.
*             MI             SIGN IS MINUS. 
  
  
*         IFPL   EXPR,LNCT
  
          QUAL   PASS1
 IFPL     MX6    0
          EQ     IFZZ 
  
*         IFMI   EXPR,LNCT
  
 IFMI     MX6    60 
 IFZZ     SPACE  4
**        IFZZ - TEST SIGN OF EXPRESSION VALUE. 
  
  
 IFZZ     SA6    P1TEMP      SAVE SIGN CONDITION
          SX1    60 
          RJ     SCAD        EVALUATE EXPRESSION
          SA1    EXVAL
          SA2    P1TEMP 
          SA3    UERR 
          BX4    X1-X2       INVERT SIGN FOR IFMI 
          LX3    59          U-ERROR FORCES SUCCESS 
          BX5    -X3*X4 
          PL     X5,CTL300   IF CONDITION MET OR U-ERROR
          EQ     IFXXNO      GO INITIATE SKIPPING 
 IFZZ     SPACE  4
**        IFZZ - TEST SIGN OF EXPRESSION VALUE. 
  
  
          QUAL   PASS2
 IFPL     BSS    0
 IFMI     BSS    0
          SA1    LR+1        CHECK FOR REFERENCE AND F-LIST 
          SA2    LF+1 
          BX6    X1+X2
          ZR     X6,ZLIST    IF NO REFERENCE OF IF-STATEMENTS 
          SX6    1RF
          SA6    REFLET      SET REFERENCE TYPE *F* 
          SX1    60 
          RJ     SCAD        SCAN EXPRESSION
          SX6    1R 
          SA6    REFLET      RESTORE BLANK REFERENCE TYPE 
          SA1    EXVAL
          SX2    36 
          MX3    0
          RJ     PACKO       CALL PACKO (EXVAL, 36, 0)
          EQ     ZLIST       RETURN 
 IRP      SPACE  4
***       IRP - INDEFINITE REPEAT.
* 
* 
*         IRP    P1 
*         (P1) IS THE PARAMETER LIST FOR ITERATION INSIDE A MACRO.
*         IRP IS A NULL OPERATION OUTSIDE A MACRO.  THE CARD IMAGES 
*         BETWEEN THE OPENING (IRP) AND TERMINATING (IRP) ARE REPEATED
*         WITH SUCCESSIVE PARAMETERS FROM THE LIST P1 SUBSTITUTED FOR 
*         THE FORMAL MACRO PARAMETER. 
  
  
          QUAL   PASS1
 IRP      EQU    CTL300 
 IRP      SPACE  4
**        IRP - INDEFINITE REPEAT.
  
  
          QUAL   PASS2
 IRP      EQU    ZLIST
 LCC      SPACE  4
***       LCC - LOADER CONTROL CARD.
* 
* 
*         LCC    STRING 
*         CHARACTER STRING IS PASSED TO BINARY OUTPUT FOR SUBSEQUENT
*         RECOGNITION BY THE LOADER.
  
  
          QUAL   PASS1
 LCC      SA1    ABSFG       TEST FOR VALIDITY OF OPERATION 
          NZ     X1,CTL80    INVALID IN PP AND ABSOLUTE CP CODES
 +        SA2    B
          ZR     X2,CTL70    IF NO BINARY FILE
  
 RM       IFEQ   CP#RM,0
          RECALL B           WAIT FOR BINARY
 RM       ENDIF 
  
          SB7    10          CONSTRUCT LOADER DIRECTIVE CARD
          SA2    COLUMN 
          SA1    CARD-1+X2
          SA6    RELVEC 
          SB5    -1R
          SB4    B1 
 LCC1     SB3    B7 
          MX6    0
 LCC2     LX6    6
          SB3    B3-B1
          SB2    X1+B5
          BX6    X1+X6
          SA1    A1+B1
          ZR     B2,LCC4     IF BLANK COLUMN WAS FOUND
          NZ     B3,LCC2
          SA6    A6+B1       STORE WORD 
          EQ     LCC1        AND GO BACK FOR MORE 
 LCC3     LX6    6           APPEND ZERO BYTES TO WORD
          SB3    B3-B1
          SB4    B4-B1
 LCC4     NZ     B3,LCC3
          SA6    A6+B1
          SB3    B7 
          MX6    0
          PL     B4,LCC3     GO BACK IF NOT TWO BYTES STORED
  
 RM       IFEQ   CP#RM,0
          WRITEW B,RELVEC+1,A6-RELVEC 
          WRITER B
 RM       ELSE
          SX4    A6-RELVEC
          IX3    X4+X4
          LX4    3
          IX2    X3+X4
          PUT    B,RELVEC+1,X2
          SA1    B-1
          NZ     X1,CTL70    IF NOT *W* RECORDS 
          WEOR   B
 RM       ENDIF 
  
          EQ     CTL70
 LCC      SPACE  4
**        LCC - LOADER CONTROL CARD.
  
  
          QUAL   PASS2
 LCC      SA1    DKCNT       INCREMENT DECK COUNT 
          SX6    X1+B1
          SA6    A1 
          EQ     ZLIST
 LDSET    SPACE  4
***       LDSET - LOADER OBJECT DIRECTIVES. 
* 
* 
*         LDSET  OPTIONS
*         OPTIONS - ONE OR MORE OPTIONS SEPARATED BY COMMAS.
*         EACH OPTION IS SPECIFIED IN ONE OF THE FOLLOWING FORMS
*           KEY 
*           KEY=PARAM 
*           KEY=PARAM1/PARAM2/.../PARAMN
*         SEE LOADER REF. MANUAL FOR PARAMETERS DETAILS.
  
  
          QUAL   PASS1
 LDSET    SA1    ABSFG
          NZ     X1,CTL80    IF NOT RELOCATABLE 
          SA1    CHAR        FETCH CURRENT CHARACTER
          SB7    X1-1R
          ZR     B7,CTL70    IF EMPTY VARIABLE FIELD
 RM       IFEQ   CP#RM,0
          SA2    L.TLDS      LENGTH OF TABLE
          SA1    K.TLDS      CONTROL WORD POINTER 
          IX1    X2-X1       WC OF CURRENT LDSET TABLE
          ZR     X2,LDS4     IF FIRST LDSET 
          SB7    X1-7700B 
          PL     B7,LDS4     IF APPROACHING OVERFLOW CONDITION
 RM       ENDIF 
          EQ     LDS2 
 LDS1     SA1    CHAR        FETCH CURRENT CHARACTER
          SB7    X1-1R
          ZR     B7,CTL70    IF END OF OPTIONS
          RJ     GETCH       GET NEXT CHARACTER 
 LDS2     SB2    B0          ALLOW AS SEPARATORS , = / - SPACE
          RJ     SCE         SCAN ELEMENT 
          ZR     X6,LDS1     IF NULL ELEMENT
          SA1    LDSA-1 
          MX0    42 
 LDS3     SA1    A1+B1       LOOK UP KEYWORD
          BX2    X0*X1
          ZR     X1,LDE3     IF END OF KEYWORD TABLE
          BX2    X2-X6
          NZ     X2,LDS3     LOOP 
          NG     B2,LDE2     TEST SEPARATOR CODE
          GT     B2,B1,LDE2  IF NOT SPACE COMMA OR =
          BX1    -X0*X1      EXTRACT PARAMETERS 
          LX1    -6 
          MX0    -3 
          BX2    -X0*X1 
          SA4    LDSB+X2-1   FETCH PROCESSOR ADDRES 
          AX1    3
          SX6    X1          SAVE PROCESSOR PARAMETER 
          AX1    3           CREATE HEADER WORD 
          BX7    X4 
          BX1    X1+X6       INSERT FLAG BIT
          SA7    P1TEMPA     STORE PROCESSOR ADDRESS
          SX6    B2 
          SA6    A7+B1       STORE SEPARATOR CODE IN P1TEMPB
          ADDWORD TLDS       PUT HEADER WORD IN TLDS
          IX7    X3-X2       LWA+1 - ORIGIN 
          SA7    P1TEMP      SAVE L.TLDS
          SA5    A7+B1       FETCH PROCESSOR ADDRESS
          SA4    A5+B1       FETCH SEPARATOR CODE 
          SB3    X5 
          SB2    X4 
          JP     B3          JUMP TO PROCESSOR
  
  
**        BUILD NEW CONTROL WORD
  
 RM       IFEQ   CP#RM,0
 LDS4     RJ     LDHDR
          EQ     LDS2 
 RM       ENDIF 
  
  
**        PROCESS REWIND, NOREWIN.
  
 LDS10    NZ     B2,LDE4     IF = 
          EQ     LDS1 
  
  
**        PROCESS LIB, OMIT, USE, USEP, COMMON = NAME1/NAME2/.../NAMEN.  FEAT184
  
 LDS20    ZR     B2,LDS1     IF NOT = 
          SX0    B0 
 LDS21    RJ     GETCH       GET CHARACTER
          SB2    B1+B1       ALLOW AS SEPARATORS , / SPACE
          RJ     SCE         SCAN ELEMENT 
          SX7    B2          SAVE SEPARATOR CODE
          SA7    P1TEMPB
          ZR     X6,LDS22    IF EMPTY ELEMENT 
          ADDWORD TLDS       ADD ELEMENT TO TLDS
          SX0    B1 
 LDS22    SA4    P1TEMPB     FETCH SEPARATOR CODE 
          SB3    X4-2 
          ZR     B3,LDS21    IF / 
          ZR     X0,LDS23    IF NO ENTRIES ADDED
          SA2    O.TLDS 
          SA3    L.TLDS 
          SA5    P1TEMP      FETCH POINTER TO HEADER WORD 
          IX7    X3-X5       WORD COUNT 
          IX5    X2+X5
          SA1    X5-1        INSERT WORD COUNT INTO HEADER WORD 
          LX7    36 
          BX6    X1+X7
          SA6    A1 
 LDS23    NZ     X4,LDE2     IF NOT SPACE OR COMMA
          EQ     LDS1 
  
  
**        PROCESS PRESET, PRESETA = P 
  
 LDS30    ZR     B2,LDS1     IF NOT = 
          RJ     GETCH       GET NEXT CHARACTER 
          SB3    X1-1R
          ZR     B3,LDS1     IF SPACE 
          EQ     B3,B1,LDS1  IF COMMA 
          SB3    X1-1R- 
          GT     B3,LDE3     IF FIRST CHARACTER NOT ALPHANUM. 
          SB3    X1-1R0 
          PL     B3,LDS32    IF FIRST CHAR IS 0-9 OR + OR - 
          SB2    B0          ALLOW AS SEPARATORS , = / - SPACE
          RJ     SCE         SCAN ELEMENT 
          SA4    =4LNONE
          BX4    X6-X4
          ZR     X4,LDS1     IF *NONE*
          SA4    LDSC-1 
          MX0    42 
 LDS31    SA4    A4+B1       LOOK UP PRESET WORD
          BX1    X0*X4
          ZR     X4,LDE3     IF NOT FOUND 
          BX1    X1-X6
          NZ     X1,LDS31    LOOP 
          BX1    -X0*X4      EXTRACT INDEX TO LDSD.                      FEAT184
          SA1    X1+LDSD     FETCH VALUE.                                FEAT184
          SX6    B0          INDICATE NO CONSTANT SCANNED 
          SA6    P1TEMPB
          EQ     LDS33
  
 LDS32    SA1    NBASE       SAVE ASSUMED NUMBER BASE 
          SX6    8
          BX7    X1 
          SA6    A1          ASSUME OCTAL 
          SA7    P1TEMPB
          SA1    LWORD       SCAN CONSTANT
          SX6    3
          RJ     SCADCON
          SA2    P1TEMPB     RESTORE BASE 
          BX6    X2 
          SA6    NBASE
          NZ     X1,LDE3     IF SCADCON DETECTED ERROR
          SA1    EXVAL
 LDS33    ADDWORD TLDS       PUT VALUE INTO TLDS
          SA2    A6-B1       FETCH HEADER WORD
          SX4    B1 
          LX4    36 
          BX6    X2+X4       SET WORD COUNT TO 1
          SA6    A2          RESTORE HEADER WORD
          SA3    P1TEMPB
          NZ     X3,LDS34    IF CONSTANT WAS SCANNED
          SA1    CHAR 
          SB7    X1-1R
          ZR     B7,LDS1     IF SPACE 
          EQ     B7,B1,LDS1  IF COMMA 
          EQ     LDE2        ERROR
 LDS34    SA1    EXSTOP      EXSTOP=0 IF SPACE, =1 IF COMMA 
          NZ     X1,LDS2     IF COMMA 
          EQ     CTL70       IF SPACE 
  
  
**        PROCESS ERR = P.
  
 LDS40    ZR     B2,LDS1     IF NOT = 
          RJ     GETCH       GET NEXT CHARACTER 
          SB2    B0          ALLOW AS SEPARATORS , = / - SPACE
          RJ     SCE         SCAN ELEMENT 
          ZR     X6,LDS42    IF EMPTY ELEMENT 
          SA2    LDSE-1 
          MX0    42 
 LDS41    SA2    A2+B1       LOOK UP ERR KEYWORD
          BX4    X0*X2
          ZR     X2,LDE3     IF NOT FOUND 
          BX4    X4-X6
          NZ     X4,LDS41    LOOP 
          BX4    -X0*X2 
          SA2    P1TEMP      GET POINTER TO HEADER WORD 
          SA3    O.TLDS 
          IX2    X2+X3
          SA2    X2-1        FETCH HEADER WORD
          BX6    X2+X4       INSERT KEYWORD CODE
          SA6    A2          RESTORE HEADER WORD
 LDS42    NZ     B2,LDE2     IF NOT SPACE OR COMMA
          EQ     LDS1 
  
  
**        PROCESS MAP = P/LFN.
  
 LDS50    ZR     B2,LDS1     IF NOT = 
          RJ     GETCH       GET NEXT CHARACTER 
          SB3    X1-1R/ 
          ZR     B3,LDS53    IF / 
          BX7    X7-X7       INITIALIZE VALUE TO ZERO 
          BX3    X7          INITIALIZE FLAG TO 0 
          SA4    LDSF        MASK FOR NSBEX 
          SA5    LDSG        NSBEX CODES AND FLAGS
 LDS51    SB7    X1          COMPUTE MAP TYPE 
          AX6    X4,B7
          LX6    59 
          PL     X6,LDS52    IF NOT MAP TYPE
          SB6    B7+B7       COMPUTE SHIFT COUNT
          LX6    X5,B6
          MX0    -4 
          BX2    -X0*X6      EXTRACT VALUE
          BX7    X2+X7       INSERT VALUE 
          MX0    1
          BX6    X0*X6       EXTRACT FLAG 
          BX3    X3+X6       OR IT TO OLD FLAG
          RJ     GETCH       GET NEXT CHARACTER 
          EQ     LDS51       LOOP 
  
 LDS52    SA2    =02060000B  MASK FOR SPACE COMMA SLASH 
          LX6    X2,B7
          PL     X6,LDE2     IF NOT SPACE COMMA OR SLASH
          BX0    -X0
          IX4    X0+X7       MAP TYPE LOGICAL VALUE 
          BX6    X4*X3       AND(LOGICAL VALUE,FLAG)
          MI     X6,LDE3     IF N WITH OTHER LETTERS
          BX5    -X0*X4 
          BX4    X5+X3       COMPUTE S BIT (0 IF NO LETTERS)
          BX7    X7+X4
          LX7    B1 
          SA2    P1TEMP      GET POINTER TO HEADER WORD 
          SA3    O.TLDS 
          IX2    X2+X3
          SA2    X2-1        FETCH HEADER WORD
          BX6    X2+X7       INSERT TYPE AND S-BIT INTO HEADER WORD 
          SA6    A2          RESTORE HEADER WORD
          SB3    X1-1R/ 
          NZ     B3,LDS1     IF NOT / 
  
 LDS53    RJ     GETCH       GET NEXT CHARACTER 
          SB2    B0          ALLOW AS SEPARATORS , = / - SPACE
          RJ     SCE         SCAN FILE NAME 
          ZR     X6,LDS1     IF EMPTY ELEMENT 
          SX7    B2 
          SA7    P1TEMPB     SAVE SEPARATOR CODE
          ADDWORD TLDS
          SX7    B1 
          LX7    36 
          SA2    A6-1        FETCH HEADER WORD
          BX6    X2+X7       INSERT WORD COUNT
          SA6    A2          RESTORE HEADER WORD
          SA1    P1TEMPB     FETCH SEPARATOR CODE 
          NZ     X1,LDE2     IF NOT SPACE OR COMMA
          EQ     LDS1 
  
  
**        PROCESS SUBST = NAME11-NAME12/.../NAMEN1-NAMEN2.
  
 LDS60    ZR     B2,LDS1     IF NOT = 
 LDS61    RJ     GETCH       GET NEXT CHARACTER 
          SB2    B1          ALLOW AS SEPARATORS , / - SPACE
          RJ     SCE         SCAN ELEMENT - 1ST OF PAIR 
          SB3    B2-3 
          NZ     B3,LDE1     IF NOT - 
          ADDWORD TLDS
          RJ     GETCH       GET NEXT CHARACTER 
          SB2    B1          ALLOW AS SEPARATORS , / - SPACE
          RJ     SCE         SCAN ELEMENT - 2ND OF PAIR 
          SX7    B2          SAVE SEPARATOR CODE
          SA7    P1TEMPB
          ADDWORD TLDS
          SA4    P1TEMPB     FETCH SEPARATOR
          SB3    X4-2 
          ZR     B3,LDS61    IF / 
          SA5    P1TEMP      FETCH POINTER TO HEADER WORD 
          IX3    X3-X2
          IX7    X3-X5       WORD COUNT 
          IX5    X2+X5
          SA1    X5-1        FETCH HEADER WORD
          LX7    36 
          BX6    X1+X7       INSERT WORD COUNT INTO HEADER WORD 
          SA6    A1          RESTORE HEADER WORD
          NZ     X4,LDE2     IF NOT SPACE OR COMMA
          EQ     LDS1 
  
  
**        PROCESS PD=N, PS=M                                             FEAT184
                                                                         FEAT184
 LDS70    ZR     B2,LDS1     IF NOT =                                    FEAT184
          RJ     GETCH       GET NEXT CHARACTER.                         FEAT184
          MX6    0           SETUP FOR EVALUATION OF CONSTANT.           FEAT184
          SA6    ELVAL       ZERO OUT RETURN CELL.                       FEAT184
          SX2    ELVAL       VALUE WILL BE RETURNED TO THIS ADDRESS.     FEAT184
          SX3    B1          WORD COUNT.                                 FEAT184
          BX4    X3          ADDRESS FIELD FLAG.                         FEAT184
          SX5    60          FIELD WIDTH FOR CHARACTER DATA.             FEAT184
          RJ     SCD         EVALUATE DECIMAL CONSTANT.                  FEAT184
          SA2    P1TEMP      GET THE POINTER TO THE HEADER WORD.         FEAT184
          SA3    O.TLDS      GET ORGIN OF LDSET TABLE.                   FEAT184
          SA4    ELVAL       GET THE VALUE.                              FEAT184
          IX2    X2+X3       ADDRESS+1 OF HEADER WORD.                   FEAT184
          SA2    X2-1        FETCH HEADER WORD FROM LDSET TABLE.         FEAT184
          BX6    X2+X4       INSERT VALUE INTO HEADER WORD.              FEAT184
          SA6    A2          RESTORE HEADER WORD INTO LDSET TABLE.       FEAT184
          SA1    CHAR        GET CURRENT CHARACTER.                      FEAT184
          SB4    X1                                                      FEAT184
          SB3    1R                                                      FEAT184
          EQ     B3,B4,LDS1  IF CURRENT CHARACTER IS A BLANK.            FEAT184
          SB3    1R,                                                     FEAT184
          EQ     B3,B4,LDS1  ELSE IF CURRENT CHARACTER IS A COMMA.       FEAT184
          EQ     LDE2        ELSE ERROR IF NOT BLANK OR COMMA.           FEAT184
                                                                         FEAT184
                                                                         FEAT184
**        ERROR PROCESSING FOR LDSET. 
*         SEARCH FOR SPACE OR COMMA.
  
  
*         LDE1 - UPDATE WORD COUNT IN HEADER WORD.
  
 LDE1     SA5    P1TEMP      FETCH POINTER TO HEADER WORD 
          SA2    L.TLDS 
          SA3    O.TLDS 
          IX2    X2-X5       WORD COUNT 
          IX5    X3+X5       FETCH HEADER WORD
          SA1    X5-1 
          LX2    36 
          BX6    X1+X2       INSERT WORD COUNT INTO HEADER WORD 
          SA6    A1          RESTORE HEADER WORD
          EQ     LDE3 
  
*         LDE2 - DISCARD CURRENT CHARACTER. 
  
 LDE2     RJ     GETCH       GET NEXT CHARACTER 
  
*         LDE3 - SEARCH FOR SPACE OR COMMA. 
  
 LDE3     SA1    CHAR 
          SB7    X1-1R
          ZR     B7,LDE4     IF SPACE 
          NE     B7,B1,LDE2  IF NOT COMMA 
  
*         LDE4 - ONLY NOTE ERROR. 
  
 LDE4     SX7    B1          NOTE ERROR 
          SA7    AERR 
          SA7    EFLG 
          EQ     LDS1 
  
  
*         LDSA - LDSET KEYWORD TABLE. 
*         VFD    42/0LKEYWORD, 6/, 3/FLAG, 3/PROC, 6/CODE 
* 
*                FLAG = PARAMETER TO PROCESSOR. 
*                PROC = PROCESSOR INDEX INTO LDSB.
*                CODE = SUBTABLE TYPE CODE. 
  
 LDSA     BSS    0
          CON    0LLIB+0210B
          CON    0LMAP+0511B
          CON    0LPRESET+0312B 
          CON    0LPRESETA+1312B
          CON    0LERR+0413B
          CON    0LREWIND+0114B 
          CON    0LNOREWIN+1114B
          CON    0LUSEP+0215B 
          CON    0LUSE+0216B
          CON    0LSUBST+0617B
          CON    0LOMIT+0220B 
          CON    0LEPT+0225B
          CON    0LNOEPT+0226B
          CON    0LCOMMON+0232B                                          FEAT184
          CON    0LPD+0733B                                              FEAT184
          CON    0LPS+0734B                                              FEAT184
          DATA   0           LIST TERMINATOR
  
  
*         LDSB - PROCESSOR ADDRESS. 
  
 LDSB     BSS    0
          CON    LDS10       REWIND,NOREWIN 
          CON    LDS20       LIB, OMIT, USE, USEP, EPT, NOEPT, COMMON    FEAT184
          CON    LDS30       PRESET,PRESETA 
          CON    LDS40       ERR
          CON    LDS50       MAP
          CON    LDS60       SUBST
          CON    LDS70       PD, PS                                      FEAT184
  
  
*         LDSC - PRESET/PRESETA KEYWORD TABLE.
*         VFD    42/0LKEYWORD, 12/, 6/INDEX                              FEAT184
*                INDEX = INDEX INTO LDSD TABLE                           FEAT184
  
 LDSC     BSS    0
          CON    0LZERO                                                  FEAT184
          CON    0LONES+1B                                               FEAT184
          CON    0LINDEF+2B                                              FEAT184
          CON    0LNGINDEF+3B                                            FEAT184
          CON    0LINF+4B                                                FEAT184
          CON    0LNGINF+5B                                              FEAT184
          CON    0LALTZERO+6B                                            FEAT184
          CON    0LALTONES+7B                                            FEAT184
          CON    0LDEBUG+10B                                             FEAT184
  
  
*         LDSD - PRESET/PRESETA KEYWORD VALUES.                          FEAT184
  
 LDSD     DATA   0           LIST TERMINATOR OF LDSC
          CON    77777777777777777777B                                   FEAT184
          CON    17770000000000000000B                                   FEAT184
          CON    60000000000000000000B                                   FEAT184
          CON    37770000000000000000B                                   FEAT184
          CON    40000000000000000000B                                   FEAT184
          CON    25252525252525252525B                                   FEAT184
          CON    52525252525252525252B                                   FEAT184
          CON    60000000000400400000B                                   FEAT184
  
  
*         LDSE - ERR KEYWORD TABLE. 
*         VFD    42/0LKEYWORD, 18/VALUE 
  
 LDSE     BSS    0
          CON    0LALL+0
          CON    0LFATAL+1
          CON    0LNONE+2 
          DATA   0           LIST TERMINATOR
  
  
 LDSF     BSS    0           MASK FOR MAP TYPE LETTERS
          ECHO   2,L=(N,S,B,E,X)
          POS    1R_L+1 
          VFD    1/1
          POS    0
  
  
 LDSG     BSS    0           VALUES FOR MAP TYPE LETTERS
          ECHO   2,L=(N,S,B,E,X),M=(0,1,2,4,10B),N=(1,0,0,0,0)
          POS    64-2*1R_L
          VFD    4/M,1/N
          POS    0
 LDSET    SPACE  4
  
  
**        LDSET - LOADER OBJECT DIRECTIVES. 
  
          QUAL   PASS2
 LDSET    EQU    ZLIST
 LIST     SPACE  4
***       LIST - EXTENT OF LISTING. 
* 
* 
*         LIST   P1,P2,...,PN 
*         LIST   *
*         CONTROLS LIST OUTPUT WHEN THE LIST PARAMETER (L) ON THE 
*         COMPASS CONTROL CARD IS OTHER THAN *0*.  ONE OR MORE OPTIONS
*         ARE SPECIFIED IN THE VARIABLE FIELD.  A MINUS PREFIX TO AN
*         OPTION CAUSES THE OPTION TO BE DISCONTINUED.
*         AN ASTERISK CAUSES RETURN TO THE PREVIOUS SETTINGS. 
* 
*           OPTION           DESCRIPTION OF OUTPUT
* 
*             A              LIST SUBSTITUTED LINES.  WHEN SELECTED,
*                            THE LINE IS LISTED BEFORE AND AFTER
*                            MICRO AND CONCATENATION SUBSTITUTION 
*                            AND REMOVAL. 
* 
*             C              CONTROL CARD LIST.  CONTROLS THE LISTING 
*                            OF EJECT, SPACE, AND TITLE.
* 
*             D              DETAIL.  SUBSEQUENT LINES FOR DATA, DIS
*                            RMT, VFD AND LIST OF LITERALS AND
*                            DEFERRED SYMBOLS.
* 
*             E              ECHOED LINES.  INCLUDES ALL ITERATIONS 
*                            OF DUPLICATED CODE.
* 
*             F              IF-SKIPPED LINES.
* 
*             G              CODE GENERATIVE LINES.  THIS INCUDES 
*                            BSS, BSSZ, CON, DATA, DIS, R=, AND VFD.
* 
*             L              NORMALLY SELECTED, WHEN CANCELED, ONLY 
*                            REFERENCE TABLE, ERROR FLAGGED LINES AND 
*                            LIST INSTRUCTIONS ARE LISTED ON THE
*                            LONG OUTPUT FILE.
* 
*             M              MACRO.  LINES GENERATED BY MACRO 
*                            EXPANSION. 
* 
*             N              NORMALLY SELECTED.  WHEN CANCELED, 
*                            ASSEMBLER DOES NOT PRINT NON-SST SYMBOLS 
*                            THAT HAVE NO REFERENCE TABLE ENTRIES.
* 
*             R              NORMALLY SELECTED.  WHEN CANCELED, 
*                            ASSEMBLER DOES NOT ACCUMULATE REFERENCE
*                            TABLE INFORMATION. 
* 
*             S              SYSTEMS MACROS.  LINES GENERATED BY
*                            SYSTEMS MACRO EXPANSION. 
* 
*             T              SST AND XTEXT SYMBOLS THAT HAVE NO 
*                            REFERENCE TABLE ENTRIES. 
* 
*             X              XTEXT LINES AND LINES BRACKETED BY 
*                            CTEXT AND ENDX.
* 
*             $              ALL OF THE ABOVE.
  
  
          QUAL   PASS1
 LIST     SA3    CP.LISTF 
          ZR     X3,CTL70    IF NO EXTERNAL LIST
          RJ     SLO         SET LIST OPTIONS 
          EQ     CTL70
 LIST     SPACE  4
**        LIST - EXTENT OF LISTINGS.
  
  
          QUAL   PASS2
 LIST     SA3    CP.LISTF 
          ZR     X3,ZLIST    IF NO EXTERNAL LIST
          RJ     SLO         SET LIST OPTIONS 
          RJ     LDL         LIST DEFERRED LINE 
          RJ     CPL         CREATE PRINT LINE
          RJ     LISTL
          EQ     Z100 
 LIT      SPACE  4
***       LIT - LITERAL VALUES. 
* 
* 
*SYM      LIT    ITEM1,ITEM2,,,ITEMN
*         (SYM) IS ASSIGNED THE VALUEOF THE LOCATION  OF ITEM1 IN THE 
*         LITERAL BLOCK.  UP TO 100 WORDS OF DATA ITEMS, SEPARATED
*         BY COMMAS, MAY BE INCLUDED IN ONE (LIT) INSTRUCTION.
  
  
          QUAL   PASS1
 LIT      MX6    0
          SA6    P1TEMP      COUNT OF ITEMS IN LIT
 LIT1     SA2    P1TEMP      TEST ITEM COUNT
          SB7    X2-NLITS 
          PL     B7,LIT3
          SX2    VALUES+X2
          SX3    -B7
          MX4    0
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM (NEXT LITERAL)
          SA2    P1TEMP      CUMULATE COUNT 
          SB7    X1-1R
          IX6    X2+X3
          SA6    A2 
          ZR     B7,LIT2     JUMP IF END OF FIELD 
          RJ     GETCH
          EQ     LIT1        GO BACK FOR MORE 
 LIT2     SX2    VALUES      LOOK UP VALUES IN LITERAL TABLE
          BX3    X6 
          ZR     X6,ERA      IF NO DATA 
          RJ     YTLULIT
          SX6    X3 
          SA6    FLAG        STORE LITERAL INDEX
          SA2    LOCSYM      DEFINE SYMBOL
          SA3    UI+1 
          SX3    X3+2 
          ZR     X2,CTL70    IGNORE IF NO LOCATION SYMBOL 
          BX2    X6 
          SX4    0
          MX5    0
          RJ     YDEFLOC
          EQ     CTL300      RETURN 
 LIT3     SX6    B1 
          SA6    EFLG 
 +        SA6    FERR 
          EQ     CTL70
 LIT      SPACE  4
**        LIT - LITERAL VALUES. 
*         ENTRY  (FLAG) = INDEX INTO LITAB. 
  
  
          QUAL   PASS2
 LIT      SA1    LOCSYM 
          ZR     X1,LIT1     IF LOCATION FIELD IS EMPTY 
          SB7    X1-1R+ 
          ZR     B7,LIT1     IF + 
          EQ     B7,B1,LIT1  IF - 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          ZR     X3,LIT1     IF NOT FOUND 
          SX1    1RL         USAGE = L
          RJ     ENTREF      ENTER REFERENCE TABLE
 LIT1     SA1    FLAG 
          SA2    O.USETAB 
          SA3    UI          USE INDEX
          IX2    X2+X3
          SA3    X2+2*4+2    ORIGIN OF LITERALS BLOCK 
          MX0    -21
          IX4    X3+X1
          MX5    -8 
          BX1    -X0*X4 
          AX4    24 
          BX6    -X5*X4      RELOCATION 
          MX7    0
          SA6    EXREL
          SA7    EXEXT
          SX2    36 
          MX3    0
          RJ     PACKOR 
          EQ     ZLIST
 LOC      SPACE  4
***       LOC - LOCATION COUNTER. 
* 
* 
*         LOC    REXP 
*         SET LOCATION COUNTER TO (REXP). 
  
  
          QUAL   PASS1
 LOC      RJ     YFOUP       FORCE UPPER
          SX6    B1+B1       EVALUTE NEW VALUE OF $ 
          SX1    21 
          RJ     SCADCON
          SA2    AERR 
          SA3    UERR 
          SA4    EXVAL
          SA5    EXREL
          BX2    X3+X2
          LX6    X4 
          SX7    X5 
          NZ     X2,CTL70 
          SA6    LOCCTR 
          SA7    A6+B1
          EQ     CTL70
 LOC      SPACE  4
**        LOC - LOCATION COUNTER. 
  
  
          QUAL   PASS2
 LOC      RJ     ZFOUP       FORCE UPPER
          SX6    B1+B1
          SX1    21 
          RJ     SCADCON
          NZ     X1,ZLIST    EXIT IF ERRORS 
          SA1    EXVAL
          SA3    A1+B1       EXREL
          BX6    X1 
          SA6    LOCCTR      RESET LOCCTR 
          BX7    X3 
          SA7    A6+B1       RESET LOCCTR RELOCATION
          EQ     ZLLA        EXIT 
 MACHINE  SPACE  4
***       MACHINE - DECLARE OBJECT PROCESSOR TYPE.
* 
* 
*         MACHINE TYPE,H1,H2,...,HN 
*         SETS *TARGET*, *VALID*, AND *HARDWARE* FIELDS IN PREFIX TABLE 
*         IN BINARY OUTPUT, UNDEFINES MACHINE INSTRUCTIONS FOR MACHINES 
*         OTHER THAN (TYPE), AND SETS A FLAG THAT CAN BE TESTED BY THE
*         PSEUDO INSTRUCTIONS IFCP6, IFCP7, IFPP6, AND IFPP7. 
*         (TYPE) = OBJECT PROCESSOR TYPE, INTERPRETED AS FOLLOWS -
*                      TYPE         TARGET          VALID 
*                                 (CP)  (PP)      (CP)  (PP)
*                       6          --    --        6X    6P 
*                       6N         6N    --        6X    6P 
*                       7          --    --        7X    7P 
*                       7N         7N    --        7X    7P 
*                      OTHER       --    --        --    YP 
*                  WHERE N IS A NUMERIC CHARACTER, -- REPRESENTS BLANKS,
*                  AND Y IS 6 IF *PERIPH* SPECIFIED OR 7 IF *PPU* SPEC. 
*         (HI) = HARDWARE INSTRUCTION DEPENDENCIES.  ONLY THE FIRST 
*                CHARACTER OF EACH IS USED. 
  
  
          QUAL   PASS1
 MCH      SA1    CHAR        GET FIRST CHARACTER
  
 RM       IFEQ   CP#RM,0
  
          BX6    X1 
          SB7    X1-1R8 
          NZ     B7,MCHA     IF NOT 8 GO CHECK FOR 6 OR 7 
          SB7    3           ELSE SET MTYPE TO 4 (SEE MCHB) 
          EQ     MCHB 
  
 RM       ENDIF 
  
 MCHA     SB7    X1-1R6 
          BX6    X1 
          MI     B7,MCH1     IF NOT 6 OR 7
          GT     B7,B1,MCH1 
 MCHB     LX6    6           POSITION *TYPE* FOR ENTRY INTO *VALID* 
          SX7    B7+B1
          SA6    VALID       SET VALID AND MTYPE
          SA7    MTYPE
          SA2    PSIM 
          SX6    6000B
          EQ     B7,B1,MCH0  IF TYPE = 7
          BX7    X2+X6       INCLUDE 60B,61B CODES IN MASK
          SA7    A2 
          EQ     MCH0A
 MCH0     BX7    -X6*X2      EXCLUDE 60B,61B CODES FROM MASK
          SA7    A2 
 MCH0A    RJ     GETCH       GET NEXT CHARACTER 
          SB6    X1-1R0 
          SB7    X1-1R9-1 
          MI     B6,MCH1     IF NOT NUMERIC (0-9) 
          PL     B7,MCH1
          SA1    VALID
          BX6    X1+X6
          SA6    TARGET      SET TARGET 
 MCH1     SA5    =9R
          SB2    48 
 MCH2     RJ     SCLIST      SKIP FIELD 
          SA1    CHAR 
          SB7    X1-1R
          ZR     B7,MCH3     IF BLANK (END OF STATEMENT)
          EQ     B7,B1,MCH2  IF COMMA (IGNORE EMPTY SUBFIELD) 
          SX1    B7 
          LX2    X1,B2       POSITION FIRST CHARACTER OF SUBFIELD 
          SB2    B2-6 
          IX5    X5+X2       ADD TO HARDWARE DEPENDENCY STRING
          PL     B2,MCH2     LOOP 
 MCH3     BX6    X5 
          SA6    HTYPE       STORE STRING 
  
 RM       IFEQ   CP#RM,0
  
          SA1    MTYPE
          SX1    X1-4 
          NZ     X1,MCH4     IF MTYPE.NE.4 GO RETURN
          RJ     RIV         ELSE GO REDEFINE INSTRUCTIONS FOR V
  
 RM       ENDIF 
  
 MCH4     BSS    0
          EQ     CTL300      RETURN 
 MACHINE  SPACE  4
**        MACHINE - DECLARE OBJECT PROCESSOR TYPE.
  
  
          QUAL   PASS2
 MCH      EQU    ZLIST
 MACRO    SPACE  4
***       MACRO - MACRO DEFINITION. 
* 
* 
*NAME     MACRO  P1,P2,P3,,,PN
*         ARGUMENTS (PI) MUST START WITH A LETTER, UP TO 63 MAY BE
*         LISTED, SEPARATED BY SPECIAL CHARACTERS ,.+-*/()$=. 
*         SUBSEQUENT INSTRUCTIONS UNTIL (ENDM) ARE SAVED AS A MACRO 
*         DEFINITION. 
* 
* 
*         MACRO  NAME,PL,P1,P2,,,PN 
*         THE FIRST SUBFIELD IS THE MACRO NAME.  THE SECOND SUBFIELD
*         (PL) IS AN ARGUMENT FROM THE LOCATION FIELD.  SUBSEQUENT
*         FIELDS ARE THE REMAINING MACRO PARAMETERS.
  
  
          QUAL   PASS1
 MACRO    MX0    0
          RJ     PMACRO 
          EQ     CTL100 
 MACRO    SPACE  4
**        MACRO - MACRO DEFINITION. 
  
  
          QUAL   PASS2
 MACRO    EQU    ZLIST
 MACROE   SPACE  4
***       MACROE - EQUIVALENCED MACRO DEFINITION. 
* 
* 
*NAME     MACROE P1,P2,...,PN 
*         ARGUMENTS PI MUST START WITH A LETTER, UP TO 63 MAY BE
*         LISTED, SEPARATED BY SPECIAL CHARACTERS ,.+-/()$=.
*         SUBSEQUENT INSTRUCTIONS UNTIL (ENDM) ARE SAVED AS A MACRO 
*         DEFINITION. 
* 
* 
*         MACROE NAME,PL,P1,P2,...,PN 
*         THE FIRST SUBFIELD IS THE MACRO NAME.  THE SECOND SUBFIELD
*         (PL) IS AN ARGUMENT FROM THE LOCATION FIELD.  SUBSEQUENT
*         FIELDS ARE THE REMAINING MACRO PARAMETERS.
  
  
          QUAL   PASS1
 MACROE   SX0    20000B 
          RJ     PMACRO 
          EQ     CTL100 
 MACROE   SPACE  4
**        MACROE - EQUIVALENCED MACRO DEFINITION. 
  
  
          QUAL   PASS2
 MACROE   EQU    ZLIST
 MAX      SPACE  4
***       MAX - CALCULATE MAXIMUM EXPRESSION. 
* 
* 
*SYM      MAX    EXP1,EXP2,...,EXPN 
*         (SYM) IS REDEFINED TO THE VALUE OF THE LARGEST ADDRESS
*         EXPRESSION (EXPI).
  
  
          QUAL   PASS1
 MAX      SA1    MAXB 
 MAX1     MX7    0
          BX6    X1 
          SA7    P1TEMPD
          SA6    MAXA 
          SA2    LOCSYM 
          NZ     X2,MAX2     IF LOCATION FIELD PRESENT
          SX7    B1 
          SA7    EFLG 
          SA7    W6ERR
          EQ     CTL70       RETURN 
 MAX2     SX6    B1          SCAN FIRST EXPRESSION
          SX1    21 
          RJ     SCADCON
 MAX3     SA1    EXVAL       SAVE SYMBOL PROPERTIES 
          SA2    A1+B1
          SA3    A2+B1
          BX6    X1 
          LX7    X2 
          SA4    A3+B1
          SA6    P1TEMP 
          SA7    A6+B1
          BX6    X3 
          LX7    X4 
          SA6    A7+B1
          SA7    A6+B1
          SA3    A7+B1       SET FLAG 
          BX6    X3 
          SA6    FLAG 
 MAX4     SA2    EXSTOP 
          ZR     X2,MAX5     IF END OF EXPRESSIONS
          SX6    B1          SCAN NEXT EXPRESSION 
          SX1    21 
          RJ     SCADCON
          SA3    P1TEMPD     INCREMENT EXPRESSION COUNT 
          SX6    X3+B1
          SA6    A3 
          SA1    P1TEMP 
          SA2    EXVAL
  
 MAXA     IX6    X2-X1       **TEST STORED FOR MAX OR MIN** 
          PL     X6,MAX3     IF NEW \ OLD 
  
 +        EQ     MAX4        LOOP 
 MAX5     SA2    P1TEMP      DEFINE SYMBOL
          SA3    A2+B1
          SA4    A3+B1
          SA1    EFLG 
          NZ     X1,MAX6     IF ERRORS IN ADDRESS 
          SA5    LIBFLG 
          LX6    X5,B1
          SX5    X6+B1
          RJ     YDEFLOC
          EQ     CTL70       RETURN 
 MAX6     SX6    B1 
          SA6    W2ERR
          EQ     CTL70       RETURN 
  
 MAXB     IX6    X2-X1
          PL     X6,MAX3     IF NEW \ OLD 
 MAX      SPACE  4
**        MAX - CALCULATE MAXIMUM EXPRESSION. 
  
  
          QUAL   PASS2
 MAX      SA1    FLAG 
          SX6    B1 
          IX7    X1-X6
          ZR     X1,SETEQU   IF EXPRESSION FOUND
          SA7    A1 
          SX6    B1 
          SX1    21 
          RJ     SCADCON
          EQ     MAX         LOOP 
 MCU      SPACE  4
***       MCU - MICROPROCESSOR CONTROL UNIT ASSEMBLY. 
* 
* 
*         MCU 
*         MCU DECLARES THE PROGRAM TO BE A MICROPROCESSOR (6800)
*         ASSEMBLY AND ABSOLUTE.  THE RULES STATED UNDER ABS APPLY. 
  
  
          QUAL   PASS1
 MCU      SX6    -2          SET FLAG FOR MCU ASSEMBLY
          SA6    PPTYPE 
          SA1    CHAR        CHECK FOR 8080 ADDRESSING
          MX6    0
          SB3    X1-1R8 
 +        NZ     B3,*+1      IF NORMAL ADDRESSING MODE
          SX6    B1 
          SA6    RMODE
          SX6    B1 
          SA6    NCHARS      SET NUMBER OF CHARACTERS TO 1
          SX7    8
          JP     BCU.1       PROCESS AS BCU 
 MCU      SPACE  4
**        MCU - MICROPROCESSOR CONTROL UNIT ASSEMBLY. 
  
  
          QUAL   PASS2
 MCU      EQU    BCU
 MD       SPACE  4
***       MD - MOVE DESCRIPTOR WORD (FOR CMU INSTRUCTION *IM*). 
* 
* 
*         MD     L,KS,CS,KD,CD
*         (L) = DATA FIELD LENGTH IN CHARACTERS (@8191).
*         (KS) = SOURCE FIELD FIRST WORD ADDRESS. 
*         (CS) = SOURCE FIELD FIRST CHARACTER POSITION (0-9). 
*         (KD) = DESTINATION FIELD FIRST WORD ADDRESS.
*         (CD) = DESTINATION FIELD FIRST CHARACTER POSITION (0-9).
  
  
          QUAL   PASS1
 MD       EQU    CC 
 MD       SPACE  4
**        MD - MOVE DESCRIPTOR WORD (FOR CMU INSTRUCTION *IM*). 
  
  
          QUAL   PASS2
 MD       SX6    B0 
          EQ     CC1
 MEMSEL   SPACE  4,10 
***       MEMSEL - SELECT PP MEMORY SIZE. 
* 
*         MEMSEL VAL
*         SETS TARGET MEMORY SIZE FOR PP ASSEMBLY.  IGNORED FOR CPU 
*         ASSEMBLIES. 
* 
*         (VAL) = MEMORY SIZE, INTERPRETED AS FOLLOWS...
* 
*                      VAL        MEMORY SIZE 
*                       4          4K - 12 BIT ADDRESS FIELDS 
*                       8          8K - 13 BIT ADDRESS FIELDS 
*                       16        16K - 14 BIT ADDRESS FIELDS 
*                       32        32K - 15 BIT ADDRESS FIELDS 
*                       64        64K - 16 BIT ADDRESS FIELDS 
  
  
          QUAL   PASS1
 MEMSEL   SX7    12          SET FOR 4K 
          SA1    CHAR        GET FIRST CHARACTER
          SX2    X1-1R       CHECK FOR END OF STATEMENT 
          ZR     X2,MEMSEL2  IF NO ADDRESS FIELD
          SX1    7
          SX6    3
          RJ     SCADCON     GET EXPRESSION VALUE 
          NZ     X1,CTL300   IF ERRORS
          SX7    12          SET FOR 4K 
          SA1    EXVAL       EXPRESSION VALUE 
          SX3    X1-4 
          ZR     X3,MEMSEL2  IF VALUE = 4 
          SX7    13          SET FOR 8K 
          SX3    X1-8 
          ZR     X3,MEMSEL2  IF VALUE = 8 
          SX7    14          SET FOR 16K
          SX3    X1-16
          ZR     X3,MEMSEL1  IF VALUE = 16
          SX7    15          SET FOR 32K
          SX3    X1-32
          ZR     X3,MEMSEL1  IF VALUE = 32
          SX7    16          SET FOR 64K
          SX3    X1-64
          ZR     X3,MEMSEL1  IF VALUE = 64
          SX6    B1          SET A-ERROR
          SA6    EFLG 
          SA6    AERR 
          EQ     CTL300      RETURN 
  
 MEMSEL1  SA1    PSIM2+1     SET TO CHECK FOR PREFETCH ERRORS ON STORES 
          BX6    X1 
          SA6    A1-B1
 MEMSEL2  SA7    PPMEMSZ     SET MEMORY SIZE
          EQ     CTL300      RETURN 
 MEMSEL   SPACE  4,10 
**        MEMSEL - SELECT PP MEMORY SIZE. 
  
          QUAL   PASS2
 MEMSEL   EQU    ZLIST
 MICCNT   SPACE  4
***       MICCNT - MICRO CHARACTER COUNT. 
* 
* 
*SYM      MICCNT MNAME
*         REDEFINES (SYM) TO HAVE A VALUE EQUAL TO THE NUMBER OF
*         CHARACTERS IN THE MICRO (MNAME).
  
  
          QUAL   PASS1
 MICCNT   RJ     SCLIST 
          ZR     X6,MCT5     IF MICRO NAME IS NULL
          BX7    X6 
          RJ     TLUMIC      LOOK UP MICRO NAME 
          SX2    B4-B1       N = NUMBER OF VALUE WORDS
          ZR     B4,MCT5     IF MICRO NOT FOUND 
          SB3    X2 
          ZR     X2,MCT4     IF N = 0 
          IX3    X2+X2
          LX2    3
          SA1    A2+B3       LAST VALUE WORD
          MX0    -6 
          IX2    X2+X3       10 * N 
          BX6    -X0*X1 
          SX2    X2-10       10 * (N - 1) + NUMBER OF CHARACTERS
          IX2    X2+X6       IN LAST VALUE WORD 
 MCT4     BX6    X2          SET MICRO COUNT AND DEFINE LOCATION
          SA6    FLAG 
          SX3    B0 
          MX4    0
          SX5    B1 
          RJ     YDEFLOC
          EQ     CTL70
 MCT5     SX6    B1          SET ERROR FLAG 
          SA6    W2ERR
          SA6    EFLG 
          SX6    B0 
          SA6    AERR 
          EQ     CTL70
 MICCNT   SPACE  4
**        MICCNT - MICRO CHARACTER COUNT. 
  
  
          QUAL   PASS2
 MICCNT   SA2    FLAG        DEFINE LOCATION SYMBOL 
          SA3    EFLG 
          NZ     X3,ZLIST    IF ERRORS IN PASS 1
          SA1    LOCSYM 
          MX6    0
          IX4    X4-X4
          SA6    EXREL
          SX5    B1 
          SA6    A6+B1       EXEXT
          RJ     ZDEFSYM
          EQ     ZLIST
 MICRO    SPACE  4
***       MICRO - DEFINE MICRO. 
* 
* 
*MNAME    MICRO  AEXP1,AEXP2,*STRING* 
*         THE MICRO STRING (MNAME) IS FORMED BY EXTRACTING (AEXP2)
*         CHARACTERS FROM (STRING) BEGINNING WITH THE CHARACTER 
*         SPECIFIED BY (AEXP1).  IF (AEXP1) IS ZERO OR BLANK, THE 
*         CHARACTER STRING IS EMPTY.  IF (AEXP2) IS ZERO OR BLANK,
*         THE LENGTH OF THE STRING IS DELIMITED BY THE CHARACTER (*). 
  
  
          QUAL   PASS1
 MICRO    SX6    3           ABSOLUTE ONLY
          SX1    15 
          RJ     SMC         GET FIRST SUBFIELD - POSITION
          SA5    EXVAL
          BX7    X5 
          SX6    3
          SA7    P1TEMP      SAVE POSITION SUBFIELD 
          SX1    15 
          RJ     SMC
          SA1    AERR 
          SA2    UERR 
          BX2    X1+X2
          ZR     X2,MIC3     IF NO ERROR
          SX6    B1          SET *A* ERROR
          SA6    AERR 
          SA6    EFLG 
          EQ     CTL70       RETURN 
 MIC3     SA1    COLUMN      SCAN OFF MICRO 
          SA2    LASTCOL
          SA3    EXVAL       CHARACTER COUNT
          SA4    P1TEMP      BIAS 
          BX6    X3+X4
          PL     X6,MIC2     IF NEITHER IS NEGATIVE 
          SX6    B1 
          SA6    W7ERR       SET *7* ERROR
          SA6    EFLG 
 MIC2     SA1    X1+CARD-1   FETCH FIRST CHARACTER OF MICRO 
          BX7    X1          SAVE DELIMITER 
          MX6    0
          SA0    10 
          SB7    A0 
          SB3    -B1
          SA7    X2+CARD     STORE DELIMITER AFTER END OF STATEMENT 
          SB4    B0 
          ZR     X4,MIC6     IF BIAS=0, CONSIDER MICRO EMPTY
          MI     X4,MIC6
 +        SA1    A1+B1       SPACE OVER INITIAL CHARACTERS
          SX4    X4+B3
          BX5    X7-X1
          ZR     X5,MIC6     STOP ON TERMINATOR 
          NZ     X4,*-1 
 MIC4     LX6    6           PACK MICRO 
          BX6    X1+X6
          SB7    B7-B1
          NZ     B7,MIC5
          SA6    RELVEC+B4   STORE COMPLETED WORD 
          SB7    A0 
          MX6    0
          SB4    B4+B1
 MIC5     SA1    A1+B1
          BX2    X7-X1
          SX3    X3+B3
          ZR     X3,MIC6     STOP ON COUNT
          NZ     X2,MIC4     STOP ON TERMINATOR 
 MIC6     SX3    A0-B7
          NZ     B4,MIC7     IF MICRO VALUE NON-NULL
          ZR     X3,MIC8     IF MICRO VALUE IS NULL 
 MIC7     SB7    B7-B1       LEFT JUSTIFY LAST VALUE WORD, ZERO FILL
          LX6    6
          NZ     B7,* 
          IX6    X6+X3       APPEND CHARACTER COUNT 
          SA6    RELVEC+B4   STORE LAST VALUE WORD
          SB4    B4+B1
 MIC8     SX6    B4+B1       LENGTH OF MICRO VALUE AND ITS NAME 
          SX7    1R 
          SA7    A7          RESTORE BLANK AT END OF STATEMENT
          RJ     EMT         ENTER MICRO IN TABLE 
          EQ     CTL70       WRITE TO THE INTERMEDIATE
 MICRO    SPACE  4
**        MICRO - DEFINE MICRO. 
  
  
          QUAL   PASS2
 MICRO    SX6    3
          SX1    15 
          RJ     SMC         GET FIRST SUBFIELD 
          SX6    3
          SX1    15 
          RJ     SMC         GET SECOND SUBFIELD
          EQ     ZLIST
 MIN      SPACE  4
***       MIN - CALCULATE MINIMUM EXPRESSION. 
* 
* 
*SYM      MIN    EXP1,EXP2,...,EXPN 
*         (SYM) IS REDEFINED TO THE VALUE OF THE SMALLEST ADDRESS 
*         EXPRESSION. 
  
  
          QUAL   PASS1
 MIN      SA1    *+1
          EQ     MAX1 
  
 +        IX6    X2-X1
          NG     X6,MAX3     IF NEW < OLD 
 MIN      SPACE  4
**        MIN - CALCULATE MINIMUM EXPRESSION. 
  
  
          QUAL   PASS2
 MIN      EQU    MAX
 NDOP     SPACE  4
***       NDOP - DEFINE NAD OPERATION CODE. 
* 
* 
*NAME     NDOP   CTL,VAL
*         (NAME) = MNEMONIC NAME. 
*         (CTL) = 0 - 4-BIT ADDRESS.  (SAB) 
*                 1 - (16 - 4-BIT) ADDRESS.  (SLC)
*                 2 - (15 - 4-BIT) ADDRESS.  (TAB)
*                 3 - 8-BIT ADDRESS.  (ADN) 
*                 4 - 9-BIT RELATIVE ADDRESS.  (UJR)
*                 5 - 4-BIT CHANNEL AND NO ADDRESS.  (IAN)
*                 6 - 8-BIT ADDRESS AND OPTIONAL
*                            INDEXING. (LDD)
*                 7 - 4-BIT CHANNEL AND 4-BIT ADDRESS.  (INT) 
*                 8 - 16 BIT INSTRUCTION,NO ADDRESS (JFA) 
*                 9 - 8 BIT ADDRESS BACKWARD ONLY (RTB) 
*                10 - 12-BIT ADDRESS.  (FNA)
*                11 - 2 16-BIT ADDRESS I/O.  (IAM)
*                            WITH 2 INSTRUCTION PARAMETERS. 
*                12 - 2 16-BIT ADDRESS.  (TST)
*                            WITH 3 INSTRUCTION PARAMETERS. 
*                13 - 7 BIT ADDRESS (BIT 8 SET = BACKWARD)  (L1R) 
*                                          (BIT 8 ZERO = FORWARD) 
*                14 - 16 BIT INSTRUCTION WITH 16 BIT
*                            ADDRESS.  (LJM)
*                15 - 16 BIT INSTRUCTION WITH 3 16 BIT
*                            ADDRESSES  (QGT) 
*                16 - 4 BIT ADDRESS AND 15-4 BIT FLAG.   (SCM)
*                17 - 16 BIT INSTRUCTION AND 16 BIT RELATIVE FORWARD
*                            ADDRESS.   (CCU) 
*         (VAL) = 16-BIT OPERATION CODE VALUE.
* 
  
  
          QUAL   PASS1
 NDOP     SX6    3           READ CTL 
          SX1    5
          RJ     SCADCON
          SA1    EXVAL
          SX6    3           READ VAL 
          BX7    X1 
          SX1    16 
          SA7    P1TEMPA
          RJ     SCADCON
          SA1    BADLOC 
          SX6    B1 
          ZR     X1,NDOP1    IF NO LOCATION ERROR 
          SA6    LERR 
          SA6    EFLG 
 NDOP1    SA1    P1TEMPA
          SA2    EXVAL
          SA3    EFLG 
          SX6    140040B     SET BCU AND OPSYN
          SB2    X1-10B      CHECK CTL
          SB3    X1-/PASS2/ZBCAL
          NG     B2,NDOP2    IF NOT NAD EXTENSION 
          PL     B3,CTL70    IF OUT OF RANGE
          SX7    B2+B1       SET EXTENSION CONTROL
          SX1    B0 
          LX7    55 
          BX1    X1+X7
 NDOP2    LX1    27 
          MX0    -16
          BX2    -X0*X2 
          BX1    X1+X2
          LX6    42 
          IX2    X1+X6
          SA1    LOCSYM 
          NZ     X3,CTL70    IF ERROR 
          RJ     ENTOP
          EQ     CTL300      RETURN 
 NDOP     SPACE  4
**        NDOP - DEFINE NAD OPERATION CODE. 
  
  
          QUAL   PASS2
 NDOP     EQU    ZLIST
 NIL      SPACE  4
***       NIL - DO NOTHING. 
* 
* 
*         NIL 
*         DOES NOTHING.  ALLOWS A MACRO OR PP INSTRUCTION TO BE 
*         DISABLED BY (OPSYN).
  
  
          QUAL   PASS1
 NIL      EQU    CTL300 
 NIL      SPACE  4
**        NIL - DO NOTHING. 
  
  
          QUAL   PASS2
 NIL      EQU    ZLIST
 NOLABEL  SPACE  4
***       NOLABEL - DELETE BINARY IDENT TABLE.
* 
* 
*         NOLABEL CHAR
*         IF (CHAR) IS BLANK, DELETE THE 7700 IDENT TABLE AND THE 5000
*         OVERLAY WORD OR THE PP HEADER WORD. 
*         IF (CHAR) IS (I), DELETE ONLY THE IDENT TABLE.
  
  
          QUAL   PASS1
 NOLABEL  SA1    ABSFG
          ZR     X1,CTL80    ERROR IF NOT ABSOLUTE CODE 
          SA1    CHAR        CHECK TYPE 
          SX6    B1          ALL LABELS 
          SX7    B1+B1       IDENT LABEL ONLY 
          SB7    X1-1R
          SB6    X1-1RI 
          SA6    NOLFG
          ZR     B7,CTL300   IF ALL LABELS
          SA7    A6          IDENT LABEL ONLY 
          ZR     B6,CTL300
          SA6    AERR        SET AERR = A 
          SA6    EFLG 
          EQ     CTL70
 NOLABEL  SPACE  4
**        NOLABEL - DELETE BINARY IDENT TABLE.
  
  
          QUAL   PASS2
 NOLABEL  EQU    ZLIST
 NOREF    SPACE  4
***       NOREF - NO REFERENCE. 
* 
* 
*         NOREF  P1,P2,...,PN 
*         SUPPRESSES THE LISTING OF NAMED SYMBOLS IN THE CROSS
*         REFERENCE TABLE.  THE PARAMETERS CAN BE OF THE FOLLOWING
*         FORM -
*                SYM         SUPPRESS LISTING OF SYMBOL (SYM).
*                /QUAL/SYM   SUPPRESS LISTING OF SYMBOL (/QUAL/SYM).
*                /QUAL/      SUPPRESS LISTING OF ALL SYMBOLS WITH 
*                            QUALIFIER (QUAL).
*         IF LOCATION FIELD IS PRESENT, IT IS USED AS QUALIFIER FOR 
*         ALL SYMBOLS IN VARIABLE FIELD THAT DO NOT HAVE EXPLICIT 
*         QUALIFIERS. 
  
  
          QUAL   PASS1
 NOREF    SA1    QVAL        SAVE CURRENT QUALIFIER 
          SA2    CHAR 
          BX6    X1 
          SB7    X2-1R/      LOOK AT NEXT CHARACTER 
          SA6    A1+B1
          NZ     B7,NOR3     IF NOT SLASH 
          RJ     GETCH
          SA2    CHAR 
          SX6    X2-1R/ 
          ZR     X6,NOR1     IF BLANK QUALIFIER 
          RJ     SCITEM      SCAN QUALIFIER NAME
          SB7    X1-1R/ 
          NZ     B7,ERA      IF NO TRAILING SLASH 
 NOR1     BX1    X6 
          RJ     SQV         SET QUALIFIER VALUE
          RJ     GETCH       SKIP TRAILING SLASH
          RJ     SCITEM      SCAN SYMBOL
          NZ     X6,NOR4
  
*         PROCESS /QUALNAME/ WITH NO SYMBOL.
  
          SA1    QVAL 
          SA2    O.QVTAB
          SB2    B1+B1
          LX1    12 
          SB7    X2-1 
          ZR     X1,NOR7     IF BLANK QUALIFIER 
          SA3    X1+B7       SET NOREF BIT
          MX6    1
          NG     X3,NOR7     IF ALREADY SET IN QVTAB ENTRY
          BX6    X6+X3
          SX4    B1 
          LX1    -12
          SA6    A3 
          SA2    O.SYMTAB    SET NOREF IN SYMBOL TABLE
          SA3    L.SYMTAB 
          MX0    12 
          RX5    X2 
          SB7    X3 
          LX4    35 
 NOR2     SX2    X2+B2
          BX6    X0*X5
          SB7    B7-B2
          RX5    X2 
          BX6    X6-X1
          NG     B7,NOR7     IF END OF TABLE
          NZ     X6,NOR2     IF NOT SAME QUALIFIER
          SX7    X2-1 
          RX3    X7 
          BX6    X3+X4
          WX6    X7 
          EQ     NOR2 
  
*         PROCESS SYMBOL WITHOUT QUALIFIER. 
  
 NOR3     SA1    LOCSYM 
          NZ     X1,NOR3A    IF QUALIFIER IN LOCATION FIELD 
          RJ     SCITEM 
          ZR     X6,NOR7     IF NO SYMBOL 
          BX1    X6 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          NZ     X3,NOR5     IF FOUND 
          EQ     NOR6 
  
 NOR3A    RJ     SQV         SET QUALIFIER VALUE
          RJ     SCITEM 
  
*         PROCESS /QUALNAME/SYMBOL. 
  
 NOR4     BX1    X6 
          RJ     TLUSYMT
          ZR     X3,NOR6     IF NOT IN SYMBOL TABLE 
          SX0    X3-1 
          RX4    X0 
          BX5    X4-X5
          NZ     X5,NOR6     IF NOT SAME QUALIFIER
  
*         SET NOREF BIT FOR SYMBOL. 
  
 NOR5     SX4    B1 
          LX4    35 
          BX6    X2+X4       SET NOREF BIT
          WX6    X3 
          EQ     NOR7 
 NOR6     SX2    B1          MAKE SYMBOL TABLE ENTRY
          LX2    35          WITH NOREF BIT SET 
          RJ     ENTSYMT
 NOR7     SA1    QVAL+1      RESTORE CURRENT QUALIFIER
          BX6    X1 
          SA2    CHAR 
          SB7    X2-1R       LOOK AT NEXT CHARACTER 
          SA6    A1-B1
          ZR     B7,CTL300   IF BLANK 
          NE     B7,B1,ERA   IF NOT COMMA 
          RJ     GETCH       SKIP COMMA 
          EQ     NOREF       LOOP 
 NOREF    SPACE  4
**        NOREF - NO REFERENCE. 
  
  
          QUAL   PASS2
 NOREF    EQU    ZLIST
 OCTMIC   SPACE  4
***       OCTMIC - OCTAL CONVERSION.
* 
* 
*MNAME    OCTMIC AEXP1,AEXP2
*         USING AN OCTAL CONVERSION, (AEXP1) IS CONVERTED INTO A
*         CHARACTER STRING.  THE OPTIONAL PARAMETER (AEXP2) DEFINES 
*         THE LENGTH OF THE RESULTING MICRO.  IF THE FIELD IS LARGER
*         THAN REQUIRED, THE CHARACTERS ARE RIGHT JUSTIFIED WITH
*         LEADING ZERO FILL.  IF (AEXP2) IS BLANK, THE CHARACTER
*         STRING HAS LEADING ZERO SUPPRESSION.  A ZERO STRING 
*         WILL PRODUCE ONE ZERO.  MAXIMUM LENGTH IS 10 CHARACTERS.
*         (MNAME) IS THE MICRO NAME.
  
  
          QUAL   PASS1
 OCTMIC   SX6    3
          SX1    60 
          RJ     SCADCON
          SA1    EXVAL
          RJ     COCT 
          EQ     DMC1 
 OCTMIC   SPACE  4
**        OCTMIC - OCTAL CONVERSION.
  
  
          QUAL   PASS2
 OCTMIC   EQU    DECMIC 
 OPDEF    SPACE  4
***       OPDEF - SPECIAL MACRO FORM. 
* 
* 
*SYTX     OPDEF  P1,P2,P3 
*         (SYTX) IS ABBREVIATED DESCRIPTION OF CP INSTRUCTION TO BE 
*         RECOGNIZED AS AN OPDEF CALL.  VARIABLE SUBFIELDS ARE FORMAL 
*         ARGUMENTS LISTED AS FOR (MACRO).  PROVIDES DESCRIPTION
*         OF MACROS IN CP MACHINE INSTRUCTION FORMAT. 
  
  
          QUAL   PASS1
 OPDEF    MX0    59 
          RJ     PMACRO 
          EQ     CTL100 
 OPDEF    SPACE  4
**        OPDEF - SPECIAL MACRO FORM. 
  
  
          QUAL   PASS2
 OPDEF    EQU    ZLIST
 OPSYN    SPACE  4
***       OPSYN 
* 
* 
*NAME     OPSYN  NAME 
*         THIS MAKES THE OPERATION CODE IN THE LOCATION FIELD 
*         SYNONYMOUS WITH THE PP INSTRUCTION, PSEUDO OPERATION, 
*         OR MACRO NAME IN THE ADDRESS FIELD. 
  
  
          QUAL   PASS1
 OPSYN    SA1    OPTYPE      SAVE OPTYPE
          BX6    X1 
          SA6    P1TEMP 
          SA1    BADLOC      CHECK LOCATION FIELD 
          SA2    LOCSYM 
          SB7    LERR 
          NZ     X1,OPS1     IF BAD LOCATION
          ZR     X2,OPS1     IF NO LOCATION SYMBOL
          RJ     SCLIST                                                  CPS126 
          SB7    AERR 
          ZR     X6,OPS1     IF ADDRESS FIELD EMPTY 
          BX1    X6 
          RJ     TLUOP       FIND EQUIVALANCE 
          SB7    AERR 
          ZR     X6,OPS1     IF ADDRESS FIELD NOT DEFINED 
          BX2    X6 
          SX0    B1          SET PROGRAM-DEFINED FLAG 
          AX2    57 
          BX3    X2+X0
 +        LX0    47 
          NZ     X3,*+1      IF NOT A MACRO 
          LX0    57-47
 +        BX2    X6+X0
          SA1    LOCSYM 
          RJ     ENTOP
          EQ     CTL400      RETURN 
 OPS1     SX6    B1          SET ERROR FLAG 
          SA6    B7 
          SA6    EFLG 
          EQ     CTL400      RETURN 
 OPSYN    SPACE  4
**        OPSYN - OPERATION SYNONYMOUS. 
  
  
          QUAL   PASS2
 OPSYN    EQU    ZLIST
 ORG      SPACE  4
***       ORG - ORIGIN. 
* 
* 
*         ORG    REXP 
*         RESET ORIGIN AND LOCATION COUNTERS.  SYMBOLS IN (REXP)
*         MUST BE DEFINED PREVIOUSLY.  (ORG) MAY CAUSE A CHANGE IN
*         THE USE BLOCK.
  
  
          QUAL   PASS1
 ORG      SX6    B1+B1
          SX1    21 
          RJ     SCADCON     EVALUATE ADDRESS FIELD 
 ORG1     SA2    EXREL
          SA3    UI+1 
          SB7    X2-3        FORBID ORG INTO LITERALS 
          AX2    8           COMPLAIN IF NEGATIVE RELOCATION
          IX1    X2+X1
          SX7    B0          CLEAR CONDITIONAL LOAD FLAG
          ZR     B7,ERA 
          NZ     X1,ERA      IF ERRORS
          SA1    EXVAL       EXPRESSION VALUE 
          MI     X1,ERA      IF NOT POSITIVE ADDRESS
  
 ORG2     SA2    A2 
          NZ     X2,*+1 
          SX2    X3 
          SA7    P1TEMPC
          BX6    X2 
          LX2    2
          SA1    O.USETAB 
          SA3    UI 
          IX1    X1+X3       BASE ADDRESS OF BLOCK GROUP
          SB7    X2-4 
          SA2    B7+X1
          BX7    X2 
          SA6    A7-B1
          SA7    A6-B1
          RJ     USES        CREATE USTACK ENTRY
          RJ     USER        SWITCH TO NEW BLOCK
          RJ     YFOUP       FORCE UPPER
          SA1    EXVAL       AND RESET ORIGINS FOR NEW BLOCK
          BX6    X1 
          SA6    ORGCTR 
          SA6    LOCCTR 
          SA1    FLAG 
          SA2    O.USETAB 
          SA3    P1TEMPC
          SA4    UI 
          IX2    X2+X4       BASE ADDRESS OF BLOCK GROUP
          SX5    X1 
          LX5    2
          SB7    X2-3 
          SA4    X5+B7
          MX0    1
          BX6    -X0*X1      CLEAR CONDITIONAL LOADING INDICATOR
          BX7    -X0*X4 
          BX6    X3+X6       SET INDICATOR IN USETAB ENTRY AND
          BX7    X3+X7       IN FLAG, IF *ORGC* 
          SA6    A1 
          SA7    A4 
          BX6    X3          SET/CLEAR CONDITIONAL LOAD FLAG
          SA6    CLF
          EQ     CTL70
 ORG      SPACE  4
**        ORG - ORIGIN. 
  
  
          QUAL   PASS2
 ORG      SX6    B1+B1
          SX1    21 
          RJ     SCADCON
          SA2    EFLG 
          BX1    X1+X2
          NZ     X1,ZLIST    QUIT IF ANY ERRORS 
          RJ     USER        RESET TO NEW BLOCK 
          RJ     ZFOUP       FORCE UPPER
          SA1    EXVAL
          SA2    ORGCTR                                                 S028 457
          BX6    X1 
          IX7    X1-X2                                                  S028 459
          SA6    ORGCTR      RESET COUNTERS 
          SA7    P2TEMP                                                 S028 461
          SA6    LOCCTR 
          RJ     RESORG      RESET ORIGIN ON NEW ORIGIN 
          SA1    P2TEMP                                                 S028 463
          PL     X1,ZLLA     IF NOT ORG BACKWARD                        S028 464
          RJ     DBSSZ       DUMP BSSZ CODE                             S028 465
          RJ     DLAST       DUMP LINK AND FILL TABLES                  S028 466
          EQ     ZLLA 
 ORGC     SPACE  4
***       ORGC - CONDITIONAL ORIGIN.
* 
* 
*         ORGC   REXP 
*         RESET ORIGIN AND LOCATION COUNTERS.  SYMBOLS IN (REXP)
*         MUST BE DEFINED PREVIOUSLY.  IN AN ABSOLUTE ASSEMBLY, OR
*         IF (REXP) IS NOT RELATIVE TO A COMMON BLOCK, (ORGC) IS
*         TREATED AS (ORG).  OTHERWISE, SUBSEQUENT INSTRUCTION/DATA 
*         WORDS WILL BE SKIPPED BY THE LOADER IF THE COMMON BLOCK 
*         WAS FIRST DECLARED BY AN EARLIER SUBPROGRAM.
  
  
          QUAL   PASS1
 ORGC     SA1    ABSFG
          SX6    2
          NZ     X1,ORG      IF ABSOLUTE ASSEMBLY 
          SX1    21 
          RJ     SCADCON     EVALUATE ADDRESS FIELD 
          SA2    EXREL
          SA3    UI+1 
          MX7    0
          ZR     X2,ORG2     IF ABSOLUTE
          SB7    B1+B1
          SA4    O.USETAB 
          SA5    UI 
          IX4    X4+X5       BASE ADDRESS OF BLOCK GROUP
          LX5    X2,B7
          AX2    8           CHECK FOR NEGATIVE RELOCATION
          BX1    X1+X2
          NZ     X1,ERA 
          IX5    X4+X5
          SA4    X5-2 
          ZR     X4,ORG1     IF NOT A COMMON BLOCK
          MX7    1           SET CONDITIONAL LOAD FLAG
          EQ     ORG2 
 ORGC     SPACE  4
**        ORGC - CONDITIONAL ORIGIN.
  
  
          QUAL   PASS2
 ORGC     EQU    ORG
 PERIPH   SPACE  4
***       PERIPH - PP ASSEMBLY. 
* 
* 
*         PERIPH CHAR 
*         PERIPH DECLARES THE PROGRAM TO BE A PP PROGRAM AND ABSOLUTE.
*         THE RULES STATED UNDER ABS APPLY. 
*         IF (CHAR) IS (J), ASSEMBLE LOW CORE PP JUMPS AS (TAG - *).
*         IF (CHAR) IS BLANK, ASSEMBLE LOW CORE PP JUMPS AS JUMP
*         TO TAG. 
  
  
          QUAL   PASS1
 PERIPH   SA1    CHAR 
          SX1    X1-1RJ 
          SX6    B0 
          NZ     X1,PER1     IF NOT J 
          SX6    B1 
 PER1     SA6    PPJUMP 
          SX6    B1          SET FLAGS FOR PP ASSEMBLY
          SX7    12 
          SA6    MACHINE     SET FLAG FOR MACHINE TYPE
          SA7    LWORD       SET WORD LENGTH TO 12
          SA7    POSCTR      REVISE POSITION COUNTER TO 12
          SX6    4
          SA6    PPBYT
          SX6    B1+B1
          SA6    NCHARS      SET NUMBER OF CHARACTERS TO 2
          LX7    24          RESET BLOCK COUNTERS 
          SA1    O.USETAB 
          SA2    L.USETAB 
 PERIPH1  SA7    X1+B1
          SX2    X2-4 
          SX1    X1+4 
          NZ     X2,PERIPH1 
          SA1    MTYPE
          SA2    PPTYPE 
          NZ     X1,ABS      IF *MACHINE* ALREADY SPECIFIED 
          SX6    X2+B1
          SX7    X2+1R6 
          SA6    A1          SET MTYPE = 1 (PERIPH) OR 2 (PPU)
          LX7    6
          SA7    VALID       SET VALID = 6 (PERIPH) OR 7 (PPU)
          SA1    PSIM 
          SX3    6000B
          ZR     X2,PER2     IF MACHINE = 6 
          BX6    -X3*X1      EXCLUDE 60B,61B INSTRUCTIONS 
          SA6    A1 
          EQ     ABS
 PER2     BX6    X1+X3       INCLUDE 60B,61B CODES IN MASK
          SA6    A1 
          EQ     ABS
 PERIPH   SPACE  4
**        PERIPH - PP ASSEMBLY. 
  
  
          QUAL   PASS2
 PERIPH   EQU    ZLIST
 PPU      SPACE  4
***       PPU - 7600 PP ASSEMBLY. 
  
  
          QUAL   PASS1
 PPU      SX6    B1          SET FLAG FOR 7600 PP ASSEMBLY
          SA6    PPTYPE 
          EQ     PERIPH 
 PPU      SPACE  4
**        PPU - 7600 PP ASSEMBLY. 
  
  
          QUAL   PASS2
 PPU      EQU    ZLIST
 POS      SPACE  4
***       POS - POSITION COUNTER. 
* 
* 
*         POS    AEXP 
*         SET POSITION COUNTER OF (AEXP).  (AEXP) MUST BE BETWEEN 0 
*         AND 60 IN VALUE AND PREVIOUSLY DEFINED. 
  
  
          QUAL   PASS1
 POS      SX6    3
          SX1    6
          RJ     SMC
          SA4    EXVAL
          NZ     X1,CTL70    IF ERROR IN EXPRESSION 
          SA1    LWORD
          IX6    X1-X4
          BX6    X4+X6
          PL     X6,POS1     IF 0 @ POSITION @ LWORD
          SX6    B1          SET ERROR FLAG 
          SA6    EFLG 
          SA6    AERR 
          EQ     CTL70
 POS1     BX6    X4 
          SA6    POSCTR 
          EQ     CTL70
 POS      SPACE  4
**        POS - POSITION COUNTER. 
  
  
          QUAL   PASS2
 POS      SX6    3
          SX1    6
          RJ     SMC
          SA1    EXVAL
          SA4    EFLG 
          NZ     X4,ZLIST    IF ERRORS
          BX6    X1 
          SA6    POSCTR 
          SX2    36          OUTPUT OCTAL POSITION
          SX3    2
          RJ     PACKO
          EQ     ZLIST
 PPOP     SPACE  4
***       PPOP - DEFINE PP OPERATION CODE.
* 
* 
*NAME     PPOP   CTL,VAL,TYP
*         (NAME) = MNEMONIC NAME. 
*         (CTL) = 1 - 24-BIT WITH 12-BIT ADDRESS AND NO INDEXING. 
*                 2 - 12-BIT WITH SIGNED RELATIVE ADDRESS 
*                     OR ABSOLUTE ADDRESS (UJN).
*                 3 - 24-BIT WITH 18-BIT ADDRESS (LDC). 
*                 4 - 12-BIT WITH 6-BIT ADDRESS (LDN).
*                 5 - 24-BIT WITH 12-BIT ADDRESS AND OPTIONAL 
*                     INDEXING (LDM). 
*                 6 - 12-BIT WITH SIGNED RELATIVE ADDRESS (SHN).
*                 7 - 24-BIT WITH 12-BIT ADDRESS AND REQUIRED 
*                     SECOND FIELD (FNC). 
*         (VAL) = 12-BIT OPERATION CODE VALUE.
*         (TYP) = 6 OR 7 TO RESTRICT INSTRUCTION TO 6000 OR 7000. 
  
  
          QUAL   PASS1
 PPOP     SX7    100040B     SET PP AND OPSYN 
 PPOP1    SX6    3           READ CTL 
          LX7    42 
          SX1    X6 
          SA7    P1TEMP 
          RJ     SCADCON
          SA1    EXVAL
          SA2    P1TEMP 
          BX7    X1 
          SX1    12          READ VAL 
          LX2    3
          SA7    P1TEMPA
 +        PL     X2,*+1      IF PPOP
          SX1    16 
          SX6    3
          RJ     SCADCON
          SA1    EXVAL
          SX6    3           READ TYP 
          BX7    X1 
          SX1    3
          SA7    P1TEMPB
          RJ     SCADCON
          SA2    P1TEMP 
          LX2    3
          SX4    B0 
          NG     X2,PPOP2    IF BCU 
          SA1    EXVAL       GET TYP
          SB7    X1-6 
          MI     B7,PPOP2    IF NOT 6 OR 7, ASSUME 0
          GT     B7,B1,PPOP2
          SX4    B7+B1
          LX4    3
 PPOP2    SA1    BADLOC 
          SX6    B1 
          ZR     X1,PPOP3    IF NO LOCATION ERROR 
          SA6    LERR 
          SA6    EFLG 
 PPOP3    SA1    P1TEMPA
          SA2    A1+B1
          SA3    EFLG 
          MX0    -3 
          BX1    -X0*X1 
          SA5    P1TEMP 
          LX5    3
 +        NG     X5,*+1      IF BCOP
          ZR     X1,ERA      IF CTL = 0 
          BX1    X4+X1
          SA4    A1-B1
          LX1    27 
          IX6    X1+X4
          LX4    3
 +        MX0    -12
          PL     X4,*+1      IF PPOP
          MX0    -16
          BX2    -X0*X2 
          IX2    X6+X2
          SA1    LOCSYM 
          NZ     X3,CTL70    IF ERROR 
          RJ     ENTOP
          EQ     CTL300      RETURN 
 PPOP     SPACE  4
**        PPOP - DEFINE PP OPERATION CODE.
  
  
          QUAL   PASS2
 PPOP     EQU    ZLIST
 PURGDEF  SPACE  4
***       PURGDEF - PURGE CPU OPCODE. 
* 
* 
*         PURGDEF SYNTAX
*         (SYNTAX) IS THE SYNTAX OF A CPU OPCODE. 
*         THE SPECIFIED OPCODE IS PURGED FROM THE OP-CODE TABLE 
*         FOR THE REMAINDER OF THE CURRENT ASSEMBLY.
  
  
          QUAL   PASS1
 PURGDEF  SA2    COLUMN      ASSEMBLE SYNTAX
          SA1    X2+CARD-1
          RJ     SOS
          ZR     X6,CTL400   IF SYNTAX ERROR
          SA1    P1TEMP      PURGE OPCODE 
          RJ     PGO
          EQ     CTL400 
 PURGDEF  SPACE  4
**        PURGDEF - PURGE CPU OPCODE. 
  
  
          QUAL   PASS2
 PURGDEF  EQU    ZLIST
 PURGMAC  SPACE  4
***       PURGMAC - PURGE MACRO.
* 
* 
*         PURGMAC NAME1,NAME2,...,NAMEN 
*         PURGMAC NAME
*         (NAMEI) IS THE MACRO, PSEUDO, OR PP INSTRUCTION NAME. 
*         THE SPECIFIED OPERATION IS PURGED FROM THE OP-CODE
*         TABLE FOR THE REMAINDER OF THE CURRENT ASSEMBLY.
  
  
          QUAL   PASS1
PURGMAC   RJ     SCLIST      SCAN ITEM
          SA6    P1TEMP 
          BX1    X6          PURGE OPCODE 
          RJ     PGO
          SA1    CHAR 
          SB7    X1-1R
          ZR     B7,CTL400   IF END OF LIST 
          EQ     PURGMAC
 PURGMAC  SPACE  4
**        PURGMAC - PURGE MACRO.
  
  
          QUAL   PASS2
 PURGMAC  EQU    ZLIST
 QUAL     SPACE  4
***       QUAL - SET SYMBOL QUALIFIER.
* 
* 
*MNAME    QUAL   NAME 
*MNAME    QUAL   *
*         (NAME) IS THE SYMBOL QUALIFIER NAME.  ALL SYMBOLS DEFINED 
*         AFTER THE OCCURRENCE OF A (QUAL) MUST BE REFERENCED FROM
*         OUTSIDE THE QUAL BLOCK AS (/NAME/SYMBOL).  IF (NAME) IS 
*         BLANK, THE FOLLOWING SYMBOLS ARE GLOBAL.  QUALIFIED SYMBOL
*         NAMES MAY BE THE SAME AS OTHER QUALIFIED OR GLOBAL SYMBOLS. 
*         WHEN A SYMBOL IS REFERENCED, A CHECK IS MADE FIRST FOR THE
*         QUALIFIED SYMBOL, THEN THE GLOBAL SYMBOL. 
*         AN ASTERISK CAUSES RETURN TO THE PREVIOUS QUALIFIER.
*         IF (MNAME) IS PRESENT, SAVE THE CURRENT QUALIFIER NAME IN 
*         THE MICRO MNAME.
  
  
          QUAL   PASS1
 QUAL     SA2    LOCSYM 
          ZR     X2,QUAL1    IF NO MICRO NAME 
          SA1    QUALMIC
          SX6    B1 
          BX7    X1 
 +        ZR     X1,*+1      IF CURRENT QUALIFIER IS BLANK
          SX6    B1+B1
 +        SA7    RELVEC 
          RJ     EMT         ENTER MICRO TABLE
 QUAL1    RJ     SCITEM 
          SB7    X6-1R* 
          BX1    X6 
          ZR     B7,QUAL4    IF QUAL *
          RJ     SQV
          SA2    QVAL+1      GET OLD QUALIFIER AND
          SA1    QUALSTK     PUSH DOWN QUAL STACK 
          LX2    12 
          BX6    X2 
          RJ     PUSH 
          SA2    QVAL        GET NEW CURRENT QUALIFIER
          BX6    X2 
 QUAL2    LX6    12 
          SA1    O.QVTAB
          MX7    0
          ZR     X6,QUAL3    IF NULL QUALIFIER
          SB7    X6-1 
          SA3    X1+B7
          MX0    12          LEFT JUSTIFY QUAL NAME 
          BX3    -X0*X3      ANDS OFF THE NOREF BIT 
          SX7    10 
 +        BX2    X0*X3
          LX3    6
          SX7    X7-1        COUNT CHARACTERS 
          ZR     X2,*-1 
          BX7    X3+X7
 QUAL3    SA7    QUALMIC     STORE CURRENT QUAL MICRO 
          EQ     CTL70       RETURN 
  
*         PROCESS QUAL *. 
  
 QUAL4    SA1    QUALSTK     PUSH UP QUAL STACK 
          RJ     PULL 
          LX6    -12
          SA6    QVAL 
          EQ     QUAL2
 QUAL     SPACE  4
**        QUAL - SET SYMBOL QUALIFIER.
  
  
          QUAL   PASS2
 QUAL     RJ     SCITEM 
          SX7    X6-1R* 
          ZR     X7,QAL1     IF QUAL *
          LX1    X6 
          RJ     SQV
          SA2    QVAL+1 
          SA1    QUALSTK     PUSH DOWN QUAL STACK 
          LX2    12 
          BX6    X2 
          RJ     PUSH 
          EQ     QAL2 
  
*         PROCESS QUAL *. 
  
 QAL1     SA1    QUALSTK     PUSH UP QUAL STACK 
          RJ     PULL 
          LX6    -12
          SA6    QVAL 
 QAL2     SA2    O.QVTAB
          SA1    QVAL 
          ZR     X1,QAL3     IF BLANK QUAL
          LX1    12 
          IX2    X2+X1
          SA1    X2-1 
          MX6    -48
          BX1    -X6*X1 
 QAL3     RJ     LJUST
          SA6    QNAME       STORE IN SUBTITLE LINE                     S028 468
          EQ     ZLIST       RETURN 
 REP      SPACE  4
***       REP - DATA GENERATION.
* 
* 
*         REP    P1/EXP,P2/EXP,,,P5/EXP 
*         GENERATE REPLICATION TABLES FOR THE RELOCATABLE LOADER. 
*         EACH SUB-FIELD CONTAINS A LETTER, A / AND AN EXPRESSION.
*             (S/REXP) SOURCE ADDRESS.
*             (D/REXP) DESTINATION ADDRESS. 
*             (C/AEXP) REPLICATION COUNT. 
*             (B/AEXP) CODE BLOCK SIZE. 
*             (I/AEXP) INCREMENT. 
  
  
          SEG    PSEUDO-OP PROCESSING (R-Z).
          QUAL   PASS1
 REP      SA1    ABSFG
          NZ     X1,CTL80    COMPLAIN IF NOT RELOCATABLE
          EQ     CTL70       PERFORM MOST PROCESSING IN PASS 2
 REP      SPACE  4
**        REP - DATA GENERATION.
  
  
          QUAL   PASS2
 REP      MX7    0
 ZREP     SA7    P2TEMP      SET REP TYPE 
          MX6    0
          SA5    ABSFG
          NZ     X5,ZLIST    QUIT IF REP IS ILLEGAL HERE
          SA6    OPADS       CLEAR ACCUMULATION CELLS 
          SA6    A6+B1
          SA6    A6+B1
          SA6    A6+B1
          SA6    A6+B1
 ZREP1    SA1    CHAR 
          SB7    X1-1R
          ZR     B7,ZREP10   IF DONE WITH ADDRESS FIELD 
          RJ     SCITEM      GET IDENTIFICATION CHARACTER 
          SB7    X1-1R/      CHECK FOR SLASH SEPARATOR
          SB6    X6-1RB 
          SB5    X6-1RD 
          SB4    X6-1RI 
          SB3    X6-1RS 
          NZ     B7,ZREPER   SLASH NOT TERMINATOR 
          RJ     GETCH       THROW AWAY THE SLASH 
          SX1    15 
          ZR     B6,ZREPB    B = BLOCK SIZE 
          SX1    18 
          EQ     B6,B1,ZREPC C = COUNT
          ZR     B4,ZREPI    I = INCREMENT
          SX1    21 
          ZR     B5,ZREPD    D = DESTINATION
          ZR     B3,ZREPS    S = SOURCE 
 ZREPER   SX6    B1 
          SA6    AERR 
          SA6    EFLG 
          EQ     ZLIST
 ZREPB    SX6    3
          RJ     SMC
          SB7    B0 
 ZREPXX   NZ     X1,ZREPER   COMPLAIN IF ANY ERRORS 
          SA2    EXVAL
          SA3    A2+B1       CONVERT RELOCATION 
          SB6    X3-401B
          SB5    X3-2 
          NG     B5,ZREPXX1 
          SX3    X3+B1
          NG     B6,ZREPXX1 
          SX3    2
          NZ     B6,ZREPER
 ZREPXX1  LX3    24 
          BX6    X2+X3
          SA6    OPADS+B7 
          EQ     ZREP1
  
*         PROCESS COUNT.
  
 ZREPC    SX6    3
          RJ     SMC
          SB7    1
          EQ     ZREPXX 
  
*         PROCESS DESTINATION.
  
 ZREPD    SX6    2
          RJ     SCADCON
          SB7    2
          EQ     ZREPXX 
  
*         PROCESS INCREMENT.
  
 ZREPI    SX6    3
          RJ     SMC
          SB7    3
          EQ     ZREPXX 
  
*         PROCESS SOURCE. 
  
 ZREPS    SX6    2
          RJ     SCADCON
          SB7    4
          EQ     ZREPXX 
  
 ZREP10   SA1    P2TEMP 
          ZR     X1,ZREP13   IF DEFERRED (REP)
          PL     X1,ZREP12   IF INSTANT UNCONDITIONAL (REPI)
          SA2    OPADS+2
 +        NZ     X2,*+1      IF DESTINATION ADDRESS NON-ZERO
          SA2    OPADS+4
          SX6    B1 
          AX2    24          GET DESTINATION RELOCATION 
          IX4    X2-X6
          AX3    X4,B1
          ZR     X3,ZREP11   IF NOT A COMMON BLOCK, CHANGE TO REPI
          SA3    LLB
          LX4    24 
          BX5    X4-X3
          LX2    12 
          ZR     X5,ZREP11   IF LCM LOCAL BLOCK 
          BX6    X6+X2
 ZREP11   SA6    A1 
 ZREP12   RJ     DBSSZ       DUMP BSSZ CODING IF REPC OR REPI 
 ZREP13   SA1    OPADS+2     CHECK SOURCE AND DESTINATION ADDRESS RANGES
          SA2    OPADS+4
          MX0    17-24
          BX5    X1+X2
          SA3    P2TEMP      HEADER WORD
          AX5    17 
          BX7    -X0*X5 
          SX4    2
          SX5    4300B       REPL TABLE IDENTIFIER
          LX4    36 
          BX3    X4+X3
          ZR     X7,ZREP14   IF BOTH ADDRESSES LESS THAN 2**17
  
          SX5    4700B       XREPL TABLE IDENTIFIER 
          LX5    48 
          BX6    X5+X3
          SA6    A3          STORE HEADER WORD
          SA4    A1-B1       COUNT
          SA3    A1+B1       INCREMENT
          SA5    A4-B1       BLOCK SIZE 
          LX4    12 
          LX3    33 
          BX7    X4+X5
          IX6    X3+X2       FIRST WORD - INCREMENT AND SOURCE
          LX7    33 
          BX7    X7+X1       SECOND WORD - COUNT, BLOCK SIZE, DEST
          EQ     ZREP15 
  
 ZREP14   LX5    48          REPL TABLE 
          BX6    X5+X3
          SA6    A3          STORE HEADER WORD
          SA4    A1-B1       COUNT
          SA3    A1+B1       INCREMENT
          SA5    A4-B1       BLOCK SIZE 
          SX7    X1                                                     S028 470
          SX6    X2                                                     S028 471
          AX1    24 
          AX2    24 
          LX4    15 
          LX3    9
          BX3    X3+X2
          IX4    X4+X5
          LX3    18 
          BX6    X3+X6       FIRST WORD - INCREMENT AND SOURCE
          LX4    9
          BX5    X4+X1
          LX5    18 
          BX7    X5+X7       SECOND WORD - COUNT, BLOCK SIZE, DEST
  
 ZREP15   SA6    A6+B1
          SA7    A6+B1
  
 RM       IFEQ   CP#RM,0
          WRITEW B,A6-B1,3   WRITE REPL TABLE 
 RM       ELSE
          SA2    B
          ZR     X2,ZLIST    IF NO BINARY FILE
          SA1    B-1
          NZ     X1,ZREP20   IF NOT *W* RECORDS 
          PUT    B,P2TEMP,30
          EQ     ZLIST
 ZREP20   PUTP   B,P2TEMP,30
 RM       ENDIF 
  
          EQ     ZLIST
 REPC     SPACE  4
***       REPC - DATA GENERATION. 
* 
* 
*         REPC   P1/EXP,P2/EXP,,,P5/EXP 
*         GENERATE CONDITIONAL REPLICATION TABLES FOR THE RELOCATING
*         LOADER.  EACH SUB-FIELD CONTAINS A LETTER, A / AND AN 
*         EXPRESSION. 
*              (S/REXP) SOURCE ADDRESS. 
*              (D/REXP) DESTINATION ADDRESS.
*              (C/AEXP) REPLICATION COUNT.
*              (B/AEXP) CODE BLOCK SIZE.
*              (I/AEXP) INCREMENT.
  
  
          QUAL   PASS1
 REPC     EQU    REP
 REPC     SPACE  4
**        REPC - DATA GENERATION. 
  
  
          QUAL   PASS2
 REPC     SX7    -B1
          EQ     ZREP 
 REPI     SPACE  4
***       REPI - DATA GENERATION. 
* 
* 
*         REPI   P1/EXP,P2/EXP,,,P5/EXP 
*         GENERATE INSTANT REPLICATION TABLES FOR THE RELOCATABLE 
*         LOADER EACH SUB-FIELD CONTAINS A LETTER, A / AND AN 
*         EXPRESSION. 
*             (S/REXP) SOURCE ADDRESS.
*             (D/REXP) DESTINATION ADDRESS. 
*             (C/AEXP) REPLICATION COUNT. 
*             (B/AEXP) CODE BLOCK SIZE. 
*             (I/AEXP) INCREMENT. 
  
  
          QUAL   PASS1
 REPI     EQU    REP
 REPI     SPACE  4
**        REPI - DATA GENERATION. 
  
  
          QUAL   PASS2
 REPI     SX7    B1 
          EQ     ZREP 
 RMT      SPACE  4
***       RMT - SAVE CODE.
* 
* 
*NAME     RMT 
*         INSTRUCTIONS UP TO THE NEXT (RMT) PSEUDO INSTRUCTION
*         ARE SAVED FOR LATER ASSEMBLY. 
*         (NAME) = NAME OF LABELED REMOTE GROUP.
  
  
          QUAL   PASS1
 RMT      SX6    B1          SET TEXT DEFINITION FLAG 
          MX7    0           CLEAR PUSHUP FLAG
          SA6    TXTFLG 
          SA7    PUSHUP 
          SA1    BADLOC 
          SX6    B1 
          SX7    RMTAB
          ZR     X1,RMT1     IF NO LOCATION ERROR 
          SA6    LERR 
          SA6    EFLG 
 RMT1     SA1    LOCSYM 
          SA7    P1TEMP 
          ZR     X1,RMT2     IF UNLABELED RMT 
          SX7    LRMTAB 
          SA7    A7 
          ADDWORD X7
 RMT2     RJ     CWI         WRITE RMT CARD 
          RJ     INPUT1      READ DEFINITION CARD 
          NZ     X1,RMT4     IF PUSHUP OCCURRED 
          RJ     SETUP
          SA1    STYPE       CHECK CARD TYPE
          SA2    IOP
          SB7    X1-1R* 
          ZR     B7,RMT2     IF COMMENT CARD
          SX3    3RRMT
          SX4    3REND
          IX6    X2-X3
          BX7    X2-X4
          ZR     X7,END      JUMP IF END CARD 
          ZR     X6,RMT3     IF TERMINATING RMT CARD
          SA1    P1TEMP      PACK CARD INTO RMT TABLE 
          PCARD  X1 
          EQ     RMT2        LOOP 
 RMT3     RJ     CWI         WRITE TERMINATING RMT CARD 
          MX6    0
          SA6    TXTFLG      CLEAR TEXT FLAG
          EQ     CTL100 
  
*         ENTRY OF ILLEGAL NESTING OF RMT.
  
 RMT4     SX6    B1          SET *E* ERROR
          SA6    EFLG 
          SA6    EERR 
          EQ     RMT3 
 RMT      SPACE  4
**        RMT - SAVE CODE.
  
  
          QUAL   PASS2
 RMT      EQU    ZLIST
 R=       SPACE  4
***       R= - CONDITIONAL SET INSTRUCTION. 
* 
* 
*SYM      R=     REG,EXP
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER.
*         IF (REG) AND (EXP) ARE IDENTICAL, NO CODE IS GENERATED. 
*         IF (EXP) HAS A VALUE OF ZERO, A SET (REG) TO B0 IS GENERATED. 
*         IF (B1=1) OR (B7=1) PSEUDO HAS BEEN CALLED, A 15-BIT SET
*         (REG) INSTRUCTION WILL BE GENERATED IF (EXP) = -1, 0, 1,
*         OR 2.  OTHERWISE, A SET (REG) TO (EXP) IS GENERATED.
*         THIS PSEUDO IS USED INSIDE A MACRO DEFINITION TO SPEED UP 
*         THE GENERATION OF MORE OPTIMUM CODE.
  
  
          QUAL   PASS1
 R=       SA1    COLUMN 
          SA1    X1+CARD-1
          SX6    1R 
          LX1    12 
          SA2    A1+B1
          LX2    6
          BX1    X1+X6
          SA3    A2+B1
          SA4    A3+B1
          BX1    X1+X2
          LX4    12 
          SA5    A4+B1
          SA2    A5+B1
          LX5    6
          BX4    X4+X5
          SX3    X3-1R, 
          BX4    X4+X2
          NZ     X3,REQ4     IF NOT *,* SEPARATOR 
          BX6    X4-X1
          ZR     X6,REQ.2    IF FIELDS EQUAL
          SA3    REQC 
          SX6    3RB1 
          ZR     X3,REQ.1    IF B1=1 NOT DEFINED
          SX7    X3-REQA+1
          ZR     X7,REQ.3    IF B1=1 DEFINED
          SX6    3RB7        B7=1 DEFINED 
 REQ.3    BX3    X1-X6
          NZ     X3,REQ.1    IF B1 OR B7 NOT FIRST SUBFIELD 
          SX7    2R1
          AX4    6
          IX3    X7-X4
          NZ     X3,REQ.1    IF 1 NOT SECOND SUBFIELD 
 REQ.2    SA1    LOCSYM 
          ZR     X1,CTL300   IF NO LOCATION SYMBOL
          SA1    LWORD
          RJ     YPRLOC 
          EQ     CTL70
 REQ.1    SX6    B1          WRITE AS A MICRO 
          SA6    MICFLG 
          RJ     CWI
          SX6    B0 
          SA6    MICFLG 
          SA6    SQLGN
          SA3    COL         CHANGE PSEUDO TO SET INSTRUCTION 
          SX7    1RS
          SA7    X3+CARD
          SA1    CHAR 
          BX7    X1 
          SA7    A7+B1
          RJ     GETCH
          BX7    X1 
          SA7    A7+B1
          RJ     GETCH
          SX7    1R 
          RJ     GETCH
          SA1    COLUMN 
          BX6    X1 
          SA6    P1TEMP 
          SA7    X1+CARD-2
          SA1    COL
          SX3    X1+CARD+3
 REQ.4    SA7    A7-B1       STORE BLANKS TO OP CODE FIELD
          SX2    A7 
          IX6    X2-X3
          NZ     X6,REQ.4 
          SX1    18          CHECK SECOND SUBFIELD
          SX6    3
          RJ     SCADCON
          SX6    B0 
          SA6    AERR 
          SA6    UERR 
          NZ     X1,CTL110   IF NOT CONSTANT
          SA2    EXVAL
          SA1    P1TEMP 
          SX7    1R 
          SA7    X1+CARD-2
          SA4    REQC        CHECK ADDRESS FIELD
 +        SA3    REQB-1 
          MX0    42 
          ZR     X4,REQ1     IF B1=1 NOT DEFINED
          SA3    X4 
 REQ1     SA3    A3+B1
          BX6    X2-X3
          ZR     X3,CTL110   IF NOT SPECIAL TYPE
          BX6    -X0*X6 
          NZ     X6,REQ1     LOOP FOR SPECIAL FORMAT
          MX0    54 
 REQ2     LX3    6
          BX7    -X0*X3 
          ZR     X7,REQ3     IF END OF SPECIAL TYPE 
          SA7    A7+B1
          EQ     REQ2        LOOP 
 REQ3     SX6    A7-CARD+1   SET LAST COLUMN
          SA1    LASTCOL
          IX7    X6-X1
          NG     X7,CTL110   IF LAST COLUMN NOT GREATER 
          SA6    A1 
          MX7    0
          SX6    X6-2 
 +        SX6    X6-71       RECALCULATE CARD COUNT 
          SX7    X7+B1
          PL     X6,*-1 
          SA7    CCT
          EQ     CTL110      CONTINUE 
  
*         ADDRESS ERROR FOUND.
  
 REQ4     SX6    B1 
          SA6    AERR 
          SA6    EFLG 
          EQ     CTL70
  
 REQA     VFD    42/4L-B1 ,18/-1
          VFD    42/3LB1 ,18/1
          VFD    42/6LB1+B1 ,18/2 
 REQB     VFD    42/3LB0 ,18/ 
          DATA   0
  
 REQD     VFD    42/4L-B7 ,18/-1
          VFD    42/3LB7 ,18/1
          VFD    42/6LB7+B7 ,18/2 
          VFD    42/3LB0 ,18/ 
          DATA   0
 R=       SPACE  4
**        R= - CONDITIONAL SET INSTRUCTION. 
  
  
          QUAL   PASS2
 R=       SA2    LOCSYM 
          SA1    LWORD
          ZR     X2,ZLIST    IF NO LOCATION SYMBOL
          RJ     ZPRLOC 
          EQ     ZLIST
 SEG      SPACE  4
***       SEG - OUTPUT BINARY SEGMENT.
* 
* 
*         SEG 
*         SEG IS USED IN ABSOLUTE CP CODE TO OUTPUT A PARTIAL BINARY
*         OF A PROGRAM.  THIS ALLOWS A PROGRAM TO ASSEMBLE IN LESS
*         CORE THAN IF THE ENTIRE BINARY IS OUTPUT AT THE END OF
*         THE ASSEMBLY. 
  
  
          QUAL   PASS1
 SEG      SA1    ABSFG       CHECK FOR ABSOLUTE CP CODE 
          SA2    MACHINE
          BX6    -X2*X1 
          NZ     X6,SEG1     IF ABSOLUTE CP CODE
          SX6    B1 
          SA6    OERR 
          SA6    EFLG 
          EQ     CTL70
 SEG1     RJ     YFUALL      FORCE ALL BLOCKS UPPER 
          RJ     RSL         RECORD SEGMENT LENGTH
          RJ     RSS         RECORD SEGMENT START 
          EQ     CTL70
 SEG      SPACE  4
**        SEG - OUTPUT BINARY SEGMENT.
  
  
          QUAL   PASS2
 SEG      SA1    ABSFG       CHECK FOR ABSOLUTE CP CODE 
          SA2    MACHINE
          BX6    -X2*X1 
          ZR     X6,ZLIST    IF NOT ABSOLUTE CP 
          RJ     ZFUALL      FORCE ALL BLOCKS UPPER 
          RJ     DBSSZ       DUMP BSSZ CODE 
          RJ     DDUMP
          SA1    ORGCTR 
          BX6    X1 
          SA6    ORGBASE
          RJ     SBL         SET BINARY LENGTH
          RJ     DLT         DUMP LITERAL TABLE 
          JP     ZLIST       RETURN 
 SEGMENT  SPACE  4
***       SEGMENT - OUTPUT BINARY SEGMENT.
* 
* 
* NAME    SEGMENT ORIGIN,ENTRY,L1,L2
*         SEGMENT TERMINATES ONE SEGMENT OF CODE.  THE ACCUMULATED
*         BINARY IS WRITTEN OUT AND A NEW BINARY IS STARTED.
*         (NAME) IS THE NAME OF THE OVERLAY GENERATED.
*         (ORIGIN) IS USED TO SPECIFY THE ORIGIN OF THE ROUTINE.
*         FOR A CENTRAL PROCESSOR ABSOLUTE PROGRAM, (ENTRY) SPECIFIES 
*         THE ENTRY POINT, AND (L1) AND (L2) ARE THE OVERLAY LEVEL
*         NUMBERS - IF OMITTED, LEVEL (1,0) IS ASSUMED. 
  
  
          QUAL   PASS1
 SEGMENT  RJ     YFUALL      FORCE ALL BLOCKS UPPER 
          SA1    ABSFG
          ZR     X1,CTL70    IF RELOCATABLE CP CODE 
          RJ     RSL         RECORD SEGMENT LENGTH
          RJ     RSS         RECORD SEGMENT START 
          SA1    LOCSYM      VERIFY SEGMENT NAME
          BX6    X1 
          RJ     VFYLINK
          ZR     X7,SEG2     IF NO ERROR                                S002  51
          SX6    B1 
          SA6    EFLG 
          SA6    LERR 
 SEG2     RJ     DIM         DISPLAY IDENT MESSAGE                      S002  53
          EQ     CTL70
 SEGMENT  SPACE  4
**        SEGMENT - OUTPUT BINARY SEGMENT.
  
  
          QUAL   PASS2
 SEGMENT  RJ     ZFUALL      FORCE ALL BLOCKS UPPER 
          RJ     DBSSZ       DUMP BSSZ CODE 
          RJ     DLAST       DUMP COMMON, EXT, REP CODE 
          SA1    ABSFG
          ZR     X1,ZLIST    EXIT IF RELOCATABLE CP CODE
          RJ     DDUMP
          SA1    B
          ZR     X1,SEG0     IF NO BINARY FILE
          WEOR   B           TERMINATE BINARY I/O 
 SEG0     SA1    LOCSYM      DUMP PRELIMINARY STUFF                     S002  55
          BX6    X1                                                     S002  56
          RJ     VFYLINK     VERIFY SEGMENT NAME                        S002  57
          SA6    P2TEMP                                                 S002  58
          SX6    0100B       SET DEFAULT (1,0) OVERLAY                  S002  59
          SX1    B1                                                     S002  60
          RJ     SIC         SCAN IDENT CARD                            S002  61
          SA1    P2TEMP                                                 S002  62
          SA2    A1+B1       DUMP IDENT TABLE                           S002  63
          RJ     DFIRST 
          SA1    DKNAM       DISPLAY IDENT MESSAGE                      S002  65
          RJ     DIM                                                    S002  66
          RJ     DLT         DUMP LITERAL TABLE 
          EQ     ZLIST       AND QUIT 
 SET      SPACE  4
***       SET 
* 
* 
*SYM      SET    EXP
*         (SYM) IS REDEFINED TO THE VALUE OF THE ADDRESS EXPRESSION.
  
  
          QUAL   PASS1
 SET      SA1    LIBFLG 
          LX6    X1,B1
          SX6    X6+B1
 EQU1     SA6    P1TEMP      SAVE SET FLAG
          SA1    LOCSYM 
          NZ     X1,EQU3     IF LOCATION FIELD PRESENT
          SX7    B1 
          SA7    EFLG 
          SA7    W6ERR
          EQ     CTL70
 EQU3     SX6    B1          EVALUATE ADDRESS FIELD 
          SX1    21 
          RJ     SCADCON
          SA1    EXSTOP 
          ZR     X1,EQU4     IF NO EXTRA FIELDS 
          SX6    B1 
          SA6    W8ERR
          SA6    EFLG 
 EQU4     SA2    EXVAL
          SA3    EXREL
          SA4    EXEXT       GET PROPERTIES OF EXPRESSION 
          SA1    AERR 
          SA5    UERR 
          BX6    X1+X5
          SA5    P1TEMP 
          NZ     X6,EQU2     IF ERRORS IN ADDRESS 
          RJ     YDEFLOC
          EQ     CTL70
 EQU2     SX6    B1          POST SET/EQU ERROR 
          SA6    W2ERR
          SX6    B0          CLEAR OUT FATAL ERROR FLAGS
          SA6    A1 
          SA6    UERR 
          EQ     CTL70
 SET      SPACE  4
**        SET - SYMBOL REDEFINITION.
  
  
          QUAL   PASS2
 SET      SX6    B1          SET REDEFINITION BIT 
  
*         MAIN PROCESSOR FOR SET AND EQU. 
  
 SETEQU   SA6    P2TEMP 
          SA1    LOCSYM 
          ZR     X1,ZLIST    QUIT IF NO LOCSYM
          SA2    W2ERR       CHECK FOR ANY PASS 1 ERRORS
          SA3    DERR 
          SX6    B1 
          BX2    X2+X3
          NZ     X2,ZLIST    IF ERRORS
          SX1    21 
          RJ     SCADCON     EVALUATE ADDRESS FIELD 
          SA5    P2TEMP      REDEFINITION BIT 
          SA2    EXVAL
          SA3    A2+B1       EXREL
          SA4    A3+B1       EXEXT
          SA1    LOCSYM 
          RJ     ZDEFSYM
          EQ     ZLIST
 SKIP     SPACE  4
***       SKIP - UNCONDITIONALLY SKIP CODE. 
* 
* 
*NAME     SKIP   LNCT 
*         OPTIONAL (LNCT) IS NUMBER OF LINES TO SKIP.  (NAME) IS
*         INSTRUCTION BRACKET NAME. 
  
  
          QUAL   PASS1
 SKIP     EQU    IFXXNO 
 SKIP     SPACE  4
**        SKIP - UNCONDITIONALLY SKIP CODE. 
  
  
          QUAL   PASS2
 SKIP     EQU    ZLIST
 SPACE    SPACE  4
***       SPACE - SKIP LINE.
* 
* 
*NAME     SPACE  AEXP1,AEXP2
*         SKIP NUMBER OF LINES INDICATED BY (AEXP1).  GUARANTEE 
*         (AEXP1 + AEXP2) LINES ON THIS PAGE.  (NAME) IS THE
*         NEW SUB-SUBTITLE, PRINTED AT THE BEGINNING OF THE NEXT PAGE.
  
  
          QUAL   PASS1
 SPACE    EQU    CTL300 
 SPACE    SPACE  4
**        SPACE - SKIP LINE.
  
  
          QUAL   PASS2
 SPACE    RJ     ZTLIST      CHECK FOR LISTINGS 
          SX1    18 
          SX6    3
          RJ     SMC
          SA2    EXVAL
          BX6    X2 
          SA6    P2TEMP 
          SX1    18 
          SX6    3
          RJ     SMC
          SA2    EXVAL
          SA4    P2TEMP 
          SA3    LPCNT
          IX2    X2+X4
          IX6    X2+X3
          SA2    CP.PS       PAGE SIZE                                   F4810A 
          IX3    X6-X2                                                   F4810A 
          SX6    B1 
          SA6    CTYPE
          PL     X3,SPC1     IF BIG SPACE MAKE EJECT                     F4810A 
          RJ     LISTER 
          SA1    P2TEMP 
          BX0    X1 
          RJ     LBL         LIST BLANK LINES 
          EQ     Z100        RETURN 
 SPC1     SX7    X2+5        FORCE EJECT                                 F4810A 
          SA7    LPCNT       CAUSE EJECT
          EQ     ZLIST
 SST      SPACE  4
***       SST - SYSTEM SYMBOL TABLE.
* 
* 
*         SST    SYM1,SYM2,,,SYMN 
*         DEFINES SYSTEM SYMBOLS FROM THE SYSTEM FILE AS IF THEY
*         HAD BEEN DEFINED BY THE ROUTINE.  (SYMI) DENOTES SYMBOLS
*         THAT SHOULD NOT BE DEFINED. 
  
  
          QUAL   PASS1
 SST      SA1    LCMSYM 
          ZR     X1,SST0     IF SYSTEM SYMBOLS NOT IN LCM 
          AX1    30 
          MANAGE SSYMS,X1    ALLOCATE TABLE IN SCM
          SA1    LCMSYM 
          RJ     RLC         COPY TABLE TO SCM
 SST0     SX6    B0 
          SA1    QVAL 
          SA6    P1TEMP 
          SA6    A6+B1       P1TEMPA
          SA6    A6+B1       P1TEMPB
          BX7    X1 
          SA6    A1          SET BLANK QUALIFIER
          SA7    A1+B1
 SST1     SA1    CHAR 
          SB7    X1-1R
          ZR     B7,SST7     IF END OF LIST 
          RJ     SCLIST      FETCH NEXT ITEM
          ZR     X6,SST1     IGNORE EMPTY FIELD 
          SA1    P1TEMP 
          SA6    X1+RELVEC   STORE SYMBOL NAME
          SX7    X1+B1
          SA7    A1 
          EQ     SST1        LOOP 
 SST3     SA2    O.SSYMS
          IX1    X1+X2
          SA1    X1          NEXT SYSTEM SYMBOL 
          SA2    P1TEMP 
          SA6    A2+B1
 SST4     ZR     X2,SST5     IF END OF IGNORE TABLE 
          SA4    X2+RELVEC-1
          SX2    X2-1 
          BX6    X1-X4
          NZ     X6,SST4     IF NOT IGNORED 
          EQ     SST6 
 SST5     SA2    A1+B1
          MX3    0
          BX4    X4-X4
          MX5    1           SET SST BIT
          BX6    X2 
          AX6    36-3        POSITION SYSTEXT ORDINAL 
          BX5    X5+X6
          RJ     YDEFSYM
          NZ     X6,SST6     IF BAD SYMBOL
          SA1    SSTCNT 
          SX6    X1+B1       BUMP DEFINED SYSTEM SYMBOL COUNT 
          SA6    A1 
          EQ     SST7 
 SST6     SA1    O.SSYMS     CLOSE UP SYSTEM SYMBOL TABLE SO
          SA2    P1TEMPA     IT CONTAINS ONLY IGNORED ENTRIES 
          SA3    A2+B1
          SB7    X1-2 
          SA1    X2+B7
          SA2    A1+B1
          SX4    X3+2 
          NO
          BX6    X1 
          LX7    X2 
          SA6    X4+B7
          SA7    A6+B1
          BX6    X4 
          SA6    A3 
 SST7     SA1    P1TEMPA
          SA2    L.SSYMS
          SX6    X1+2 
          IX2    X1-X2
          NZ     X2,SST3     LOOP TO END OF SYSTEM SYMBOL TABLE 
          RJ     ASU         ACCUMULATE STORAGE USED
          SA1    P1TEMPB
          SA2    LCMSYM 
          SA3    QVAL+1      STORE NEW L.SSYMS AND
          BX6    X1          RESTORE QUALIFIER
          LX7    X3 
          SA6    L.SSYMS
          SA7    A3-B1
          ZR     X2,CTL300   IF SYSTEM SYMBOLS NOT IN LCM 
          MX6    0
          SA6    A6          CLEAR SCM TABLE
          SA6    SSTCNT 
          EQ     CTL300      RETURN 
 SST      SPACE  4
**        SST -SYSTEM SYMBOL TABLE. 
  
  
          QUAL   PASS2
 SST      EQU    ZLIST
 STEXT    SPACE  4
***       STEXT - GENERATE A SYSTEXT RECORD.
* 
* 
*RNAME    STEXT 
*         GENERATE A SYSTEMS TEXT RECORD FOR THIS PROGRAM.  ALL SYMBOLS 
*         AND ALL PROGRAM MACROS ARE WRITTEN IN AN OVERLAY FORMAT AT
*         THE END OF PASS1.  THIS RECORD CAN BE LOADED BY COMPASS.
*         IF (RNAME) IS NON-BLANK, THE SYSTEXT RECORD IS WRITTEN
*         WITH NAME (RNAME) AND THE NORMAL BINARY FROM THE PROGRAM
*         IS GENERATED. 
  
  
          QUAL   PASS1
 STEXT    SA1    LOCSYM 
          SA2    BADLOC 
          ZR     X2,STX1     IF LOCATION NOT BAD
          SX6    B1 
          SA6    LERR 
          SA6    EFLG 
 STX1     NZ     X1,STX2     IF ALTERNATE RECORD OUTPUT 
          SA1    IDNAM
 STX2     RJ     LJUST
          SA7    SYNAME 
          EQ     CTL70
 STEXT    SPACE  4
**        STEXT - GENERATE A SYSTEXT RECORD.
  
  
          QUAL   PASS2
 STEXT    SA1    LOCSYM 
          ZR     X1,ZLIST    IF NO ALTERNATE NAME 
          MX6    0
          SA6    SYNAME 
          EQ     ZLIST       RETURN 
 STOPDUP  SPACE  4
***       STOPDUP - STOP DUPLICATION. 
* 
* 
*         STOPDUP 
*         STOPS DUPLICATION AT END OF CURRENT ITERATION.
  
  
          QUAL   PASS1
 STOPDUP  SA1    ECHFLG 
          SA2    O.STACK
          ZR     X1,CTL300   IGNORE IF NOT DUPLICATING
          SA3    L.STACK     SEARCH FOR TOP-MOST DUPLICATION
 STOPDUP1 SX3    X3-4 
          SB7    X2+B1
          SA4    B7+X3       FETCH SECOND STACK WORD
          AX4    56 
          SB6    X4-5 
          ZR     B6,STOPDUP2 IF ECHO
          SB6    X4-2 
          NZ     B6,STOPDUP1 NOT FOUND
 STOPDUP2 SA1    A4+B1
          MX6    1
          BX6    X6+X1
          SA6    A1 
          EQ     CTL300      RETURN 
 STOPDUP  SPACE  4
**        STOPDUP - STOP DUPLICATION. 
  
  
          QUAL   PASS2
 STOPDUP  EQU    ZLIST
 TITLE    SPACE  4
***       TITLE - TITLING.
* 
* 
*NAME     TITLE  STRING 
*         FIRST TITLE STRING IN SUBPROGRAM IS LISTED ON EVERY PAGE
*         SUBSEQUENT (TITLE)S ARE SUBTITLES WHICH CAUSE AN EJECT BEFORE 
*         LISTING.  THE TITLE STRING BEGINS IMMEDIATELY AFTER THE 
*         PSEUDO OPERATION CODE AND CONTINUES FOR 62 COLUMNS OR TO THE
*         END-OF-STATEMENT.  (NAME) IS THE SUB-SUBTITLE PRINTED AT
*         THE BEGINNING OF THE NEW PAGE.
  
  
          QUAL   PASS1
 TITLE    SA5    TITFG       CHECK IF THIS IS FIRST TITLE 
          SA4    LIBFLG      NOT WITHIN XTEXT                           P036  34
          BX6    X4+X5                                                  P036  35
          SX7    B1                                                     P036  36
          NZ     X6,CTL70    IF NOT MAIN TITLE                          P036  37
          SA7    A5          SET TITLE FLAG                             P036  38
          SA1    TITBUF      SET NEW TITLE
          RJ     SNT
          EQ     CTL70
 TITLE    SPACE  4
**        TITLE - TITLING.
  
  
          QUAL   PASS2
 TITLE    SA3    TITFG
          SA4    LIBFLG                                                 P036  40
          BX6    X3+X4                                                  P036  41
          SX7    B1                                                     P036  42
          NZ     X6,TIT1     IF NOT MAIN TITLE                          P036  43
          SA7    A3                                                     P036  44
          SA7    CTYPE                                                  P036  45
          EQ     ZLIST                                                  P036  46
 TIT1     SA1    SUBTIT      SET NEW SUBTITLE                           P036  47
          RJ     SNT                                                    P036  48
          NZ     X6,Z100     IF IN XTEXT AND LIST X IS OFF              P036  49
          RJ     TLIST       TEST FOR LISTING 
          SA1    LPCNT       CAUSE PAGE EJECT 
          SA2    NEJF        *N* CONTROLLED PAGE SIZE 
          IX7    X1+X2
          SA7    A1 
          NZ     X2,ZLIST    IF EJECT 
          SX0    4           LIST 4 LINES 
          RJ     LBL
          EQ     ZLIST       RETURN 
 TTL      SPACE  4
***       TTL - MAIN TITLE. 
* 
* 
*NAME     TTL    STRING 
*         RESETS MAIN TITLE TO (STRING).  SUBTITLE IS CLEARED.
*         (NAME) IS THE NEW SUB-SUBTITLE. 
  
  
          QUAL   PASS1
 TTL      EQU    CTL70
 TTL      SPACE  4
**        TTL - MAIN TITLE. 
  
  
          QUAL   PASS2
 TTL      SA1    TITBUF 
          RJ     SNT         SET NEW TITLE
          NZ     X6,Z100     IF IN XTEXT AND LIST X IS OFF              P036  52
          SX6    B1          SET MASTER TITLE FLAG
          SA6    TITFG
          SA1    =1H         CLEAR SUB-TITLE BUFFER 
          SX2    SUBTIT 
          SX3    SUBTIT+SUBTITL+1 
          RJ     PRESET 
          RJ     TLIST       TEST LISTING 
          EQ     ZLIST
 USE      SPACE  4
***       USE - BLOCK ASSIGNMENT. 
* 
* 
*         USE    NAME 
*         ASSEMBLE FOLLOWING INSTRUCTIONS IN BLOCK (NAME).
* 
*           BLOCKNAME        TYPE 
* 
*              0             NORMAL SUBPROGRAM
*              BLANK         NORMAL SUBPROGRAM
*              *             BLOCK PRIOR TO LATEST USE/USELCM/ORG/ORGC
*              //            BLANK COMMON 
*              /NAME/        LABELED COMMON 
*              NAME          NAMED LOCAL
  
  
          QUAL   PASS1
 USE      MX6    0
          SA6    P1TEMP      CLEAR LCM FLAG 
 USEL     SB2    B0          COMMONALITY INDICATOR
          SB3    B0          BLOCK NUMBER COUNTER 
          SA1    CHAR 
          SB7    X1-1R/      CHECK FOR COMMON DECLARATION 
          NZ     B7,*+2 
          SB2    B1          SET COMMON FLAG
          RJ     GETCH       AND THROW AWAY THE SLASH 
          RJ     SCLIST      SCAN OFF NAME
          SB7    X6-1R0 
          ZR     X6,USE8     CHANGE EMPTY OR 0 NAME TO BLANK
          NZ     B7,USE9
 USE8     SA1    P1TEMP      ERROR IF USELCM 0 OR BLANK 
          SX6    1R 
          MI     X1,USEA
 USE9     ZR     B2,USE6     IF NOT COMMON
          MX0    -6 
          BX1    -X0*X6 
          SX1    X1-1R/ 
          ZR     X1,USE7     IF TRAILING SLASH
 USEA     SX7    B1 
          SA7    EFLG 
          SA7    AERR 
          EQ     USE6 
 USE7     AX6    6
 USE6     SB7    X6-1R*      CHECK FOR USE *
          ZR     B7,USEPR 
          SA1    P1TEMP 
          BX6    X6-X1       COMPLEMENT NAME IF LCM 
          SX7    B2 
          SA6    A1          SAVE BLOCK NAME
          SA7    A6+B1       AND COMMONALITY
          SA2    O.USETAB    SEARCH FOR BLOCK NAME
          SA3    L.USETAB 
          SA1    UI 
          IX2    X2+X1
          IX3    X3-X1
          SB6    -4 
          SA2    X2 
          SB7    X3+B6
 USE3     BX4    X2-X6       TEST BLOCK 
          SA2    A2-B6
          SB7    B7+B6
          SB3    B3+B1
          NZ     X4,USE4
          PL     X4,USE5     IF NAME FOUND IN TABLE 
 USE4     PL     B7,USE3     KEEP LOOKING 
          SB4    B1+B1
          AX7    B4,X1       NUMBER OF BLOCKS PRIOR TO PRESENT GROUP. 
          SA1    UI+1        PRESENT BLOCK NUMBER.
          SX6    X1+B3       NEW BLOCK NUMBER.
          SA6    P1TEMPB     SAVE NEW BLOCK NUMBER. 
          SB4    X6-256 
          PL     B4,USEF     IF 256TH BLOCK IN PRESENT BLOCK GROUP. 
          SA6    A1+B1
  
          MANAGE USETAB,-B6  AUGMENT USETAB FOR NEW BLOCK 
          SB7    X3-4 
          SA3    P1TEMP      RECLAIM BLOCK NAME 
          SA4    A3+B1       AND COMMONALITY
          BX6    X3 
          LX7    X4 
          SA6    X2+B7
          SA3    LWORD
          BX6    X3 
          LX6    24 
          SA6    A6+B1
          SA7    A6+B1       BLOCK COUNTER AND COMMONALITY
          MX6    0
          SA6    A7+B1
          MANAGE RVTAB,1*1   AUGMENT RVTAB FOR NEW BLOCK
          SB7    X3-1*1      PRESET NEW ENTRY TO ZERO 
          MX6    0
          SA6    X2+B7
          EQ     USE1 
 USE5     SA3    A2-2        FETCH COMMONALITY OF USETAB ENTRY
          SA1    P1TEMP+1    FETCH COMMON FLAG
          BX4    X3-X1       CHECK IF COMMON FLAG SET 
          LX4    59 
          PL     X4,USEOLD   USE OLD BLOCK
          EQ     USE4 
  
*         ENTRY ON USE FOR OLD BLOCK NAME.
  
 USEOLD   SB4    B3-B1
          NE     B4,B1,USEOLD1 IF NOT 0 BLOCK 
          SA4    ABSFG
          ZR     X4,USEOLD1 
          SA2    A2-B6
          SB3    B3-B1
 USEOLD1  SA2    A2-2        FETCH COMMONALITY
          SA1    UI+1 
          SB3    B3-B1
          SX6    X1+B3
          SX7    B2 
          BX7    X7+X2
          SA6    P1TEMPB
          SA7    A6-B1
  
*         ALL USE-S EXCEPT USE *. 
  
 USE1     RJ     USES        CREATE USTACK ENTRY
  
*         USE * REJOINS HERE. 
  
 USE2     RJ     USER        SWITCH TO NEW BLOCK
          EQ     CTL70
  
*         ENTRY ON USE *. 
  
 USEPR    SA1    USESTK      PUSH UP USE STACK
          RJ     PULL 
          NZ     X6,USEPR1   IF STACK WAS NOT EMPTY 
          SA4    ABSFG       SUPPLY BLOCK 2-ABSFG 
          SA5    UI+1 
          SX5    X5+B1
          IX6    X5-X4
 USEPR1   SA6    P1TEMPB     STORE NEW BLOCK NUMBER 
          LX6    2
          SA2    O.USETAB 
          SA4    UI 
          IX2    X2+X4       BASE ADDRESS OF BLOCK GROUP
          SB7    X6-2        COMMONALITY
          SA4    X2+B7
          SX6    B2 
          BX7    X6+X4
          SA7    A6-B1
          EQ     USE2 
 USELCM   SPACE  4
***       USELCM - BLOCK ASSIGNMENT.
* 
* 
*         USELCM NAME 
*         ASSEMBLE FOLLOWING INSTRUCTIONS INTO LCM BLOCK (NAME).
* 
*           BLOCKNAME        TYPE 
* 
*              0             ERROR
*              BLANK         ERROR
*              *             BLOCK PRIOR TO LATEST USE/USELCM/ORG/ORGC
*              //            LCM BLANK COMMON 
*              /NAME/        LCM LABELED COMMON 
*              NAME          LCM NAMED LOCAL
  
  
          QUAL   PASS1
 USELCM   SA1    MACHINE
          NZ     X1,CTL80    *O* ERROR IF PP
          MX6    60 
          SA6    P1TEMP      SET LCM FLAG 
          EQ     USEL 
 USE      SPACE  4
**        USE - BLOCK ASSIGNMENT. 
  
  
          QUAL   PASS2
 USE      RJ     USER 
          EQ     ZLIST
 USELCM   SPACE  4
**        USELCM - BLOCK ASSIGNMENT.
  
  
          QUAL   PASS2
 USELCM   SA1    AERR 
          NZ     X1,ZLIST    IF ERROR IN PASS 1 
          EQ     USE
 USES     SPACE  4
**        USES - CREATE PUSHDOWN STACK ENTRY FOR USE AND ORG PSEUDOS. 
  
  
          QUAL   PASS1
 USES     PS                 RETURN EXIT
          SA2    ORGCTR+1 
          SA1    USESTK 
 +        NZ     X2,*+1      IF NOT ABSOLUTE
          SA2    UI+1 
 +        BX6    X2 
          RJ     PUSH        PUSH DOWN USE STACK
          EQ     USES 
 USER     SPACE  4
**        USER - SWITCH TO NEW BLOCK FOR USE/ORG. 
*         ENTRY  OLD BLOCK INFORMATION IN ACTIVE CELLS NOTED BELOW. 
*                (P1TEMPB) = NEW BLOCK NUMBER.
*                (P1TEMPA) = NEW BLOCKS COMMONALITY.
*         CELLS WHICH ARE RECORDED AND RE-SET ARE...
*         ORGCTR                   ORGCTR+1 
*         LOCCTR                   LOCCTR+1   (NOT RECORDED, JUST SET)
*         NFOUP                    POSCTR 
*         ALSO CREATES FLAG FOR COMMUNICATION WITH ZUSER IN PASS 2. 
*         FLAG (59)    = CONDITIONAL LOAD FLAG. 
*         FLAG (58-24) = OLD BLOCK NUMBER.
*         FLAG (23-00) = NEW BLOCK NUMBER.
  
  
          QUAL   PASS1
 USER     PS                 RETURN EXIT
          SA1    ORGCTR+1    OLD BLOCK NUMBER 
          SA2    O.USETAB 
          NZ     X1,*+1      CHANGE ABSOLUTE ORIGIN TO 1
          SA1    UI+1 
 +        SA3    P1TEMPB     NEW BLOCK NUMBER 
          SA4    UI 
          IX2    X2+X4       BASE ADDRESS OF BLOCK GROUP
          LX1    24 
          BX6    X1+X3
          SA6    FLAG 
          AX1    24-2 
          SB6    X1          INDEX+4 OF OLD USETAB ENTRY
          SX2    X2-3 
          LX3    2
          SB5    X3          INDEX+4 OF NEW USETAB ENTRY
          SA4    NFOUP
          SA5    POSCTR 
          SA1    ORGCTR      ORIGIN COUNTER VALUE 
          LX4    3+20 
          BX6    X4+X1
          SA4    CLF         CONDITIONAL LOAD FLAG
          BX0    X5 
          LX5    24 
          BX6    X6+X4
          IX7    X5+X6
          SA7    X2+B6       STORE OLD COUNTERS 
          SA5    A7+2        FETCH OLD MAXIMUM BLOCK SIZE 
          SA4    LWORD
          AX3    2
          IX6    X0-X4
 +        SX4    B1 
          ZR     X6,*+1      IF POSITION COUNTER = LWGRD
          IX1    X1+X4       INCREMENT ORGCTR 
          IX7    X5-X1
          BX6    X1 
 +        SX1    B1 
          PL     X7,*+1 
          SA6    A5          STORE NEW MAXIMUM BLOCK SIZE 
 +        SA2    X2+B5       PICK UP NEW COUNTERS 
          SA5    UI+1 
 +        IX7    X3-X5
          NZ     X7,*+1 
          SX3    B0          CHANGE BLOCK 1 TO ABSOLUTE ORIGIN
          SA4    FLAG 
          MX0    1
          BX7    X0*X2
          IX6    X7+X4
          SA7    CLF         NEW CONDITIONAL LOAD FLAG
          SA6    A4 
          BX7    X3 
          MX0    39 
          BX6    -X0*X2 
          SA7    A1+B1       NEW ORGCTR RELOCATION
          SA6    A1          NEW ORGCTR VALUE 
          AX2    23 
          SA7    LOCCTR+1 
          SA6    A7-B1
          AX3    X2,B1
          BX7    X2*X1
          SX6    X3 
          SA7    NFOUP       NEW NFOUP
          SA6    POSCTR      NEW POSCTR 
          EQ     USER 
  
*         ENTRY ON USETAB OVERFLOW. 
  
 USEF     SX6    B1          NOTE ERROR 
          SA6    EFLG 
          SA6    FERR 
          SA1    ORGCTR      AND CREATE NULL USE
          BX6    X1 
          SA2    A1+B1
          LX7    X2 
          SA6    LOCCTR 
          SA7    A6+B1
          LX2    24 
          BX6    X2+X7
          SA6    FLAG 
          EQ     CTL70
 USER     SPACE  4
**        USER - SWITCH TO NEW BLOCK FOR USE/ORG/END. 
*         ENTRY  INFORMATION ASSUMED IN FLAG. 
*         USER SWAPS THE FOLLOWING INFORMATION FOR THE TWO BLOCKS.
* 
*                ORGCTR            ORGCTR+1 
*                LOCCTR            LOCCTR+1  (NOT SAVED)
*                POSCTR            NFOUP
*                BINWORD           BINREL 
*                MINORG     CLF    MAXORG  (SET, NOT SAVED) 
*         ALSO FORCES MAXORG = 0 IF GOING TO COMMON BLOCK (NAME = 0). 
*                IN RELOCATABLE ASSEMBLY TO CATCH BLANK COMMON
*         RESETS BINARY ORIGIN (RESORG).
  
  
          QUAL   PASS2
 USER     PS                 RETURN EXIT
          SA1    FLAG        STORE CURRENT INFORMATION IN USETAB
          SA2    O.USETAB 
          SA3    UI 
          IX2    X2+X3       BASE ADDRESS OF BLOCK GROUP
          LX1    -24+2
          SB7    X1-3 
          MX0    -21
          SA3    BINREL      FORM SECOND WORD OF USETAB ENTRY - 
          SA4    POSCTR      BINREL, POSCTR, NFOUP, AND ORGCTR
          SA5    NFOUP
          LX3    18 
          BX7    X3+X4
          SA4    ORGCTR 
          LX7    1
          BX6    X7+X5
          BX7    -X0*X4 
          LX6    23 
          SA4    BINWORD     FOURTH WORD OF USETAB ENTRY - BINWORD
          BX6    X6+X7
          SA5    ABSFG
          BX7    X4 
          SA6    X2+B7
          SA7    A6+2 
          LX1    24-2 
          NZ     X5,USER1    IF ABSOLUTE ASSEMBLY 
          SA3    A3+B1
          SA4    A3+B1
          SA5    O.RELTAB    SAVE PARTIAL BINARY RELOCATION 
          SX7    B7-B1       IN RELTAB ENTRY
          AX7    1
          SB7    X7 
          BX6    X3 
          LX7    X4 
          SA6    X5+B7
          SA7    A6+B1
          SB7    X1-1        GET NEW PARTIAL BINARY RELOCATION
          SB7    B7+B7
          SA5    X5+B7
          SA4    A5+B1
          BX6    X5 
          LX7    X4 
          SA6    A3 
          SA7    A3+B1
 USER1    SX3    X1-1        GET NEW BLOCK INFORMATION FROM USETAB
          LX3    2
          SB7    X3+B1
          SA1    X2+B7       SECOND WORD OF USETAB ENTRY -
          BX6    -X0*X1      BINREL, POSCTR, NFOUP, ORGCTR
          AX1    23 
          SA6    ORGCTR 
          MX4    -1 
          SA6    LOCCTR 
          BX7    -X4*X1 
          AX1    1
          SA7    NFOUP
          SX6    X1 
          AX1    18 
          SX7    X1 
          SA6    POSCTR 
          SA7    BINREL 
          SA1    A1+B1       THIRD WORD OF USETAB ENTRY 
          SA2    A1+B1       FOURTH WORD OF USETAB ENTRY - BINWORD
          MX4    -8 
          BX6    -X0*X1 
          LX7    X2 
          SA6    MINORG 
          SA7    BINWORD
          AX1    24 
          BX6    -X4*X1 
          AX1    9
          BX7    X1 
          SA6    ORGCTR+1 
          SA7    MAXORG 
          SA6    LOCCTR+1 
          SA2    A1-2        FIRST WORD OF USETAB ENTRY - BLOCK NAME
          MX6    0
          SA1    ABSFG
          PL     X2,ZUSR1    IF NOT LCM 
          BX2    -X2
          NZ     X1,ZUSR1A   IF ABSOLUTE                                 CPSA070
          NZ     X2,ZUSR3    IF NOT BLANK COMMON                         CPSA070
          SX2    2R//                                                    CPSA070
          SA6    A7+         SET MAXORG = 0                              CPSA070
          EQ     ZUSR3                                                   CPSA070
                                                                         CPSA070
 ZUSR1A   SA6    A7+         SET MAXORG = 0                              CPSA070
 ZUSR1    NZ     X2,ZUSR2    IF NOT BLANK COMMON
          SX2    2R// 
          NZ     X1,ZUSR3    IF ABSOLUTE
          SA6    A7          SET MAXORG = 0 
 ZUSR2    SA4    O.USETAB 
          SA3    UI 
          IX4    X4+X3       BASE ADDRESS OF BLOCK GROUP
          SB7    X4+3*4 
          SX5    A2-B7
          IX6    X5-X3
          PL     X6,ZUSR3    IF NOT PROGRAM* OR ABSOLUTE* 
          MX2    0
 ZUSR3    BX1    X2          SET BLOCK NAME IN SUB-SUBTITLE 
          RJ     LJUST
          SA6    UNAME
          RJ     DBSSZ
          SA1    FLAG        RESET CONDITIONAL LOAD FLAG
          MX4    1
          BX6    X4*X1
          SA6    CLF
          EQ     USER 
 VFD      SPACE  4
***       VFD - FIELD DEFINITION. 
* 
* 
*SYM      VFD    ITEM1/EXP1,ITEM2/EXP2,,,,ITEMN/EXPN
*         (SYM) IN THE LOCATION FIELD ASSIGNS THE SUBFIELDS BEGINNING 
*         IN A NEW WORD.  A *-* IN THE LOCATION FIELD POSITIONS 
*         THE COUNTER AT THE NEXT QUARTER WORD BOUNDARY IN A CP 
*         ASSEMBLY.  (ITEM) IS A SINGLE FIELD BIT COUNT, PREVIOUSLY 
*         DEFINED AND ABSOLUTE, MAXIMUM VALUE OF 60.  IF (EXP) IS 
*         NOT ABSOLUTE, THE FIELD MUST BE AT LEAST 18 BITS LONG, ENDING 
*         AT BIT NUMBER 0, 15, OR 30. 
  
  
          QUAL   PASS1
 VFD      SA1    LWORD       SET FIELD SIZE FOR GENERATED DATA
          SA2    VWORD        = LWORD FOR ALL ASSEMBLIES EXCEPT FOR 
          IX6    X1-X2          180 PPU ASSEMBLIES WITH *S* OPTION
          SA6    WWORD
 VFD.0    SA2    LOCSYM      COMMON CODE FOR *VFD* AND *VFDL* 
          SA3    NFOUP
          BX2    X3+X2
          ZR     X2,VFD1
          MX1    0
          RJ     YPRLOC 
 VFD1     SX6    B0 
          SX7    B1 
          SA6    FLAG        CUMULANT FIELD COUNT 
          SA7    P1TEMP      ERROR FLAG 
 VFD2     SA1    CHAR 
          SB7    X1-1R
          ZR     B7,VFD3     QUIT ON BLANK
          MX6    0
          SA6    EXERR
          SA1    MBASE       SET NUMBER BASE
          BX6    X1 
          SA1    NBASE       SAVE NUMBER BASE 
          SA6    A1 
          BX6    X1 
          SA6    VFDA 
          SX1    15 
          RJ     YEVITEM     EVALUATE BIT COUNT 
          SA2    VFDA        RESTORE NUMBER BASE
          BX6    X2 
          SA6    NBASE
          SA2    ELREL
          SA3    A2+B1       ELEXT  GUARANTEE ABSOLUTE RESULT 
          IX2    X2+X3
          SA4    A3+B1       ELREG
          BX2    X2+X4
          SX6    B1 
 +        ZR     X2,*+1 
          SA6    EXERR       COMPLAIN IF NOT ABSOLUTE 
          SA2    ELVAL
          SX3    61 
          SB6    X1-1R/      CHECK FOR SLASH
          IX4    X2-X3       CHECK FOR EXCESSIVELY LONG 
 +        ZR     X2,*+1      OR NEGATIVE
          MI     X2,*+2 
 +        PL     X4,*+1      VFD BIT COUNT
          ZR     B6,*+2 
          SA6    EXERR
 +        SA5    P1TEMP 
          SA3    EXERR
          LX6    X5          ERROR FLAG 
 +        ZR     X3,*+1 
          SX6    B0          SET ERROR FLAG 
          SA6    A5 
          SA5    FLAG 
          IX7    X5+X6       UP FIELD COUNT 
          SA7    A5 
          LX6    59 
          AX6    59 
          BX1    X6*X2
          MX0    59 
          SA5    POSCTR      (X2) = MIN(POSCTR,WWORD) 
          SA4    WWORD
          IX2    X4-X5
          BX5    X5-X4
          AX2    59 
          BX5    -X2*X5 
          BX2    X5-X4
          IX6    X2-X1       REDUCE POSITION COUNTER BY FIELD WIDTH 
          SA6    A5 
          SA3    WWORD       WORD LENGTH TO USE FOR VFD 
 VFD2A    PL     X6,VFD2B    IF STILL IN THIS WORD
          SA4    ORGCTR      ADVANCE ORIGIN AND LOCATION COUNTERS 
          SA5    LOCCTR 
          IX6    X6+X3
          IX7    X4-X0
          SA7    A4 
          IX7    X5-X0
          SA7    A5 
          SA6    A6 
          EQ     VFD2A       LOOP UNTIL *POSCTR* POSITIVE 
  
 VFD2B    RJ     GETCH       THROW AWAY SLASH 
          SA1    ELVAL
          RJ     SCAD        SKIP OVER ADDRESS FIELD
          SA1    POSCTR 
          NZ     X1,VFD2     IF NOT END OF WORD 
          RJ     YFOUP
          EQ     VFD2 
 VFD3     SA2    P1TEMP 
          SX6    B1 
          NZ     X2,CTL65 
          SA6    VERR        STORE V ERROR
          SA6    EFLG 
          EQ     CTL65
  
 VFDA     DATA   0
 VFD      SPACE  4
**        VFD - FIELD DEFINITION. 
  
  
          QUAL   PASS2
 VFD      SA1    LWORD       SET *LWORD* TO FIELD SIZE TO USE FOR VFD 
          SA2    VWORD        = ACTUAL WORD SIZE FOR ALL ASSEMBLIES 
          IX7    X1-X2          EXCEPT 180 PPUS WITH *S* OPTION 
          BX6    X1          SAVE ACTUAL WORD SIZE IN *WWORD* 
          SA6    WWORD
          SA7    A1 
          SA5    POSCTR      SET POSCTR = MIN(POSCTR,LWORD) 
          IX3    X7-X5
          BX5    X5-X7
          AX3    59 
          BX5    -X3*X5 
          BX7    X5-X7
          SA7    A5 
 VFD.0    SA1    NFOUP       CHECK IF LOCATION TERM NEEDS PROCESSING
          SA2    LOCSYM 
          SA3    POSCTR 
          SA4    LWORD
          BX1    X2+X1
          IX3    X4-X3
          MX6    0
          SX7    B1 
          SA6    P2TEMP      FIELD COUNT
          SA7    A6+B1       LISTING FLAG 
 +        ZR     X3,*+1 
          ZR     X1,*+1+1 
          MX1    0
          RJ     ZPRLOC 
 ZVFD1    MX6    0           NEW EXPRESSION 
          SA2    POSCTR 
          BX7    X2 
          SA6    OPVAL       CLEAR WORD VALUE 
          SA7    P2TEMPB     SAVE STARTING BIT NUMBER 
 ZVFD2    SA1    CHAR        CHECK FOR END OF VFD 
          SB7    X1-1R
          ZR     B7,ZVFD7 
          SA1    MBASE       SET NUMBER BASE
          BX6    X1 
          SA1    NBASE       SAVE NUMBER BASE 
          SA6    A1 
          BX6    X1 
          SA6    ZVFDA
          SX1    15 
          RJ     ZEVITEM     EVALUATE BIT COUNT 
          SA2    ZVFDA       RESTORE NUMBER BASE
          BX6    X2 
          SA6    NBASE
          SA2    P2TEMP      INCREMENT FIELD COUNT
          SX6    X2+B1
          SX7    B1 
          SA6    A2 
          SA7    A2+B1       SET LIST FLAG
          SA3    FLAG        CHECK IF STILL VALID FIELD 
          IX4    X3-X6
          MX7    0
 +        PL     X4,*+1 
          SA7    ELVAL       CLEAR OUT FIELD WIDTH
          RJ     GETCH       THROW AWAY SLASH 
          SA1    ELVAL
          BX6    X1          SAVE FIELD WIDTH 
          SA6    P2TEMPC
          RJ     SCAD        SCAN ADDRESS FIELD 
          SA5    EXREG       CHECK FOR A REGISTER 
          SX6    B1 
          ZR     X5,ZVFD3A
          SA6    AERR        *** REGISTER IN VFD FIELD
          SA6    EFLG 
 ZVFD3A   SA3    P2TEMPC     MASK OUT EXPRESSION
          SA4    EXVAL
          SB6    59 
          SB7    X3 
          GT     B7,B6,ZVFD3 IF 60-BIT FIELD
          MX0    1
          SB6    B6-B7
          AX0    X0,B6
          BX6    -X0*X4 
          SA6    A4          ADDRESS FIELD VALUE
 ZVFD3    SA2    POSCTR 
          IX7    X2-X3
          PL     X7,ZVFD4    IF FIELD WILL FIT INTO THIS WORD 
          BX7    -X7         PROCESS HIGH-ORDER BITS
          SA4    A4+B1       EXREL
          SA5    A4+B1       EXEXT
          BX6    X4+X5
          ZR     X6,ZVFD3B   IF ABSOLUTE FIELD
          SX6    B1 
          SA6    AERR        REL/EXT FIELD MAY NOT CROSS WORD BOUNDARY
          SA6    EFLG 
 ZVFD3B   SB7    X7 
          SA7    A3          STORE REDUCED FIELD WIDTH
          SA4    EXVAL
          SA5    OPVAL
          AX1    X4,B7
          MX0    1           CLEAR POSSIBLE OVERFLOW
          SB6    B7-B1
          AX0    X0,B6
          BX1    -X0*X1 
          BX6    X5+X1
          SA6    A5 
          MX7    0
          BX1    X6 
          SA7    A2 
          SX2    36 
          SA3    PPTYPE 
 +        SX5    B1+B1
          PL     X3,ZVFD3C   IF NOT HEX LISTING 
          SX6    X3+2 
          MI     X6,ZVFD3C   IF NOT HEX LISTING.
          SX5    X5+B1
          SX3    X3+B1
          LX3    1
          IX2    X2+X3
 ZVFD3C   SA3    P2TEMPB
          SB5    X3 
          SX4    X5+B1
          IX3    X3+X5       ROUND UP 
          IX3    X3/X4
          SA4    MACHINE
          ZR     X4,ZVFD3D   IF CPU 
          SX2    X2-11       ADJUST COLUMN FOR PP LISTINGS
          SA4    LWORD
          SA5    WWORD
          IX5    X4-X5
          ZR     X5,ZVFD3D   IF NOT USING ONLY LOWER 12 BITS IN WORD
          SB5    B5-12
          NZ     B5,ZVFD3D   IF LINE NOT BEGUN AT TOP OF WORD 
          SX3    X3+2        SET TO SHOW TWO LEADING ZEROS
 ZVFD3D   RJ     PACKO       CALL PACKO (OPVAL, 36-11*MACH, NBIT/3) 
          SA1    OPVAL
          SA2    P2TEMPB
          SX3    B0 
          BX4    X3 
          RJ     BINOUT 
          SX6    B0          CLEAR DETAIL FLAG
          SA6    DETFLG 
          RJ     LISTERG     LIST THE LINE
          MX6    0
          SA6    LOCSYM 
          SA6    OPVAL
          BX1    X6 
          RJ     ZPRLOC 
          SA1    POSCTR 
          BX6    X1 
          SA6    P2TEMPB     RESET POSITION ORIGIN
          EQ     ZVFD3A      RETURN FOR LOW ORDER PART
  
 ZVFD4    SA7    A2          ROOM LEFT IN WORD FOR THIS SUBFIELD
          SB7    X7          SHIFT LEFT INTO POSITION 
          SA2    EXVAL
          SA3    OPVAL
          LX4    X2,B7
          BX6    X4+X3       OR INTO VALUE
          SA6    A3 
          SA2    EXREL       CHECK FOR RELOCATABLE FIELDS 
          SA3    A2+B1
          BX4    X2+X3
          NZ     X4,ZVFD6    IF NOT ABSOLUTE FIELD
          SA2    POSCTR      CHECK FOR BOTTOM OF WORD 
          NZ     X2,ZVFD2 
 ZVFD6    SA1    POSCTR      OUTPUT VALUES AT BOTTOM OF WORD OR 
          MX0    58          AT RELOCATABLE FIELD 
          SB2    X1 
          IX2    X1/X0
          SA3    MACHINE
          SA4    PPTYPE 
 +        ZR     X3,*+1 
          SX2    X2-11
          SA3    P2TEMPB
          SB5    X3 
          SA5    OPVAL
          SA1    A1 
          IX3    X3-X1
          SX2    X2+36
 +        SX1    B1+B1
          PL     X4,ZVFD6B   IF NOT HEX LISTING 
          SX6    X4+2 
          MI     X6,ZVFD6B   IF NOT HEX LISTING.
          SX1    X1+B1
          SX4    X4+B1
          LX4    1
          IX2    X2+X4
 ZVFD6B   IX3    X3+X1       ROUND UP 
          SX4    X1+B1       NUMBER OF BITS PER DIGIT 
          SX0    3           PREPARE VALUE FOR LISTING.                  CPSA094
          SX1    B2          NUMBER OF BITS LEFT AFTER THIS EXPRESSION.  CPSA094
          IX1    X1/X0       NUMBER OF EMPTY COLUMNS LEFT.               CPSA094
          SX0    3           DETERMINE NO. OF BITS TO SHIFT RIGHT.       CPSA094
          IX1    X1*X0       NUMBER OF BITS TO SHIFT RIGHT TO PREPARE    CPSA094
          SB7    X1           FOR ENTRY OF VALUE INTO *OCTAL* AREA.      CPSA094
          AX1    X5,B7       SHIFT INTO POSITION FOR LISTING.            CPSA094
          IX3    X3/X4       SET NUMBER OF DIGITS 
          SA4    LWORD
          SA5    WWORD
          IX5    X4-X5
          ZR     X5,ZVFD6C   IF NOT USING ONLY LOWER 12 BITS IN WORD
          SB5    B5-12
          NZ     B5,ZVFD6C   IF LINE NOT BEGUN AT TOP OF WORD 
          SX3    X3+2        SET TO SHOW TWO LEADING ZEROS
 ZVFD6C   RJ     PACKOR      PACK OCTAL DIGITS AND RELOCATION INDICATOR 
          SA1    POSCTR      OUTPUT BINARY VALUES 
          SA2    P2TEMPB
          SA3    EXREL
          SA4    A3+B1
          SB7    X1 
          SA5    OPVAL
          BX7    X3+X4
          IX2    X2-X1
          ZR     X7,ZVFD6A   IF ABSOLUTE FIELD
          SA1    A2+B1
          IX6    X2-X1
          ZR     X6,ZVFD6A   IF NO PRECEDING ABSOLUTE FIELD 
          SA4    POSCTR 
          AX5    B7 
          BX2    X6 
          SB7    X1 
          IX6    X4+X1
          SX3    B0 
          BX4    X4-X4
          AX1    X5,B7
          SA6    A4 
          RJ     BINOUT      OUTPUT ABSOLUTE FIELD
          SA1    POSCTR 
          SA2    P2TEMPC
          SA3    EXREL
          SA4    A3+B1
          IX7    X1-X2
          SA5    OPVAL
          SB7    X7 
          SA7    A1 
 ZVFD6A   BX6    X6-X6
          AX1    X5,B7
          SA6    P2TEMPA
          RJ     BINOUT 
          SX6    B0          CLEAR DETAIL FLAG
          SA6    DETFLG 
          RJ     LISTERG
          SA1    POSCTR 
          NZ     X1,ZVFD1 
          RJ     ZPRLOC      PROCESS LOCATION AT TOP OF WORD
          EQ     ZVFD1
  
 ZVFD7    SA2    P2TEMPA     FINISH OFF VFD PROCESSING
          NZ     X2,ZVFD8    IF NOT END OF STATEMENT
          SX1    1R          CLEAR OCTAL ADDRESS
          SX2    OCTAL+8
          SX3    OCTAL+14 
          RJ     PRESET 
          SA3    VWORD
          ZR     X3,Z100     IF NOT CIPPU  ,S 
          SA4    WWORD       RESTORE *LWORD* TO ACTUAL WORD SIZE
          BX7    X4 
          SA7    LWORD
          SA7    POSCTR      RESET POSITION COUNTER TO UPPER
          EQ     Z100 
 ZVFD8    SA1    POSCTR 
          SA4    PPTYPE 
 +        SB5    B1+B1
          SX2    36 
          PL     X4,ZVFD8A   IF NOT HEX ASSEMBLY
          SB7    X4+2 
          MI     B7,ZVFD8A   IF NOT HEX ASSEMBLY. 
          SX4    X4+B1
          LX4    1
          IX2    X2+X4
          SB5    B5+B1
 ZVFD8A   SX7    B5+B1
          IX0    X1/X7
          SA5    OPVAL
          SX7    B5+B1
          DX3    X0*X7
          UX0    X0 
          SB6    X3 
          AX1    X5,B6       POSITION VALUE 
          SA3    MACHINE
 +        ZR     X3,*+1 
          SX2    X2-11
          IX2    X2-X0
          SA3    P2TEMPB
          SB3    X3 
          SX4    X3+B5
          SX7    B5+B1
          IX3    X4/X7
          IX3    X3-X0
          SA4    LWORD
          SA5    WWORD
          IX5    X4-X5
          ZR     X5,ZVFD8B   IF NOT USING ONLY LOWER 12 BITS IN WORD
          SB3    B3-12
          NZ     B3,ZVFD8B   IF LINE NOT BEGUN AT TOP OF WORD 
          SX3    X3+2        SET TO SHOW TWO LEADING ZEROS
 ZVFD8B   RJ     PACKO       PACK OCTAL DIGITS
          SA1    POSCTR 
          SB7    X1 
          SA4    OPVAL
          SA3    P2TEMPB
          IX2    X3-X1
          AX1    X4,B7
          MX3    0
          BX4    X3 
          RJ     BINOUT 
          SX6    B0          CLEAR DETAIL FLAG
          SA6    DETFLG 
          SA4    WWORD       RESTORE *LWORD* TO ACTUAL WORD SIZE
          BX7    X4 
          SA7    LWORD
          EQ     ZLISTG 
  
 ZVFDA    DATA   0
 VFDL     SPACE  4,10 
***       VFDL - FIELD DEFINITION.
* 
* 
*SYM      VFDL   ITEM1/EXP1,ITEM2/EXP2,...,ITEMN/EXPN 
*         LEGAL ONLY FOR 180 PPU ASSEMBLIES.  SAME AS VFD, EXCEPT IT
*         OVERRIDES THE 12-BIT FIELD SIZE SPECIFIED FOR 180 PPU 
*         ASSEMBLIES BY (CIPPU  ,S).
  
          QUAL   PASS1
 VFDL     SA1    PPTYPE 
          SX1    X1+3 
          ZR     X1,VFDL1    IF 180 PPU ASSEMBLY
          SX6    B1          *VFDL* ILLEGAL, POST O-ERROR 
          SA6    EFLG 
          SA6    OERR 
 VFDL1    SA1    LWORD       SET WORD SIZE ALWAYS USE FULL WORD 
          BX6    X1 
          SA6    WWORD
          EQ     VFD.0       GO TO COMMON *VFD* PROCESSING
          SPACE  4,10 
**        VFDL - FIELD DEFINITION.
  
  
          QUAL   PASS2
 VFDL     SA1    LWORD       SET WORD SIZE TO ALWAYS USE FULL WORD
          BX6    X1 
          SA6    WWORD
          EQ     VFD.0       GO TO COMMON *VFD* PROCESSING
 XREF     SPACE  4
***       XREF - SET TYPE OF CROSS REFERENCE DESIRED. 
* 
* 
*         XREF   CHAR 
*         (CHAR) = P SET PAGE/LINE CROSS REFERENCE. 
*                  A SET ADDRESS CROSS REFERENCE. 
*                  B SET BOTH PAGE/LINE AND ADDRESS.
  
  
          QUAL   PASS1
 XREF     SA1    CHAR 
          SB3    X1-1RA 
          NZ     B3,XREF1    IF NOT ADDRESS 
          SX6    B0          SET ADDRESS
          EQ     XREF3
 XREF1    SB3    X1-1RB 
          NZ     B3,XREF2    IF NOT BOTH
          SX6    B1          SET BOTH 
          EQ     XREF3
 XREF2    SX6    -B1         SET PAGE/LINE
 XREF3    SA6    XR 
          EQ     CTL300 
 XREF     SPACE  4
**        XREF - SET TYPE OF CROSS REFERENCE DESIRED. 
  
  
          QUAL   PASS2
 XREF     EQU    ZLIST
 XTEXT    SPACE  4
***       XTEXT - EXTERNAL INPUT. 
* 
* 
*FILE     XTEXT  RNAME
*         ASSEMBLES SOURCE STATEMENTS FROM RECORD (RNAME) OF (FILE).
*         IF (FILE) IS BLANK, THE FILE SPECIFIED BY THE (X) PARAMETER 
*         ON THE COMPASS CONTROL CARD IS USED.  IF (RNAME) IS BLANK,
*         THE FIRST RECORD IN THE FILE IS READ.  OTHERWISE, (FILE)
*         MUST BE A RANDOM FILE, WITH A NAME INDEX, ON A MASS STORAGE 
*         DEVICE.  THE CARD IMAGES IN THE RECORD MAY BE COMPRESSED OR 
*         NOT.  (FILE) MAY BE AN UPDATE OR MODIFY PROGRAM LIBRARY 
*         FILE, IN WHICH CASE (RNAME) MUST BE A COMMON DECK.  IN ALL
*         CASES, READING STOPS, AND INPUT FROM THE PREVIOUS SOURCE IS 
*         RESUMED, AT END OF SCOPE LOGICAL RECORD OR A COMPASS (END)
*         STATEMENT, WHICHEVER COMES FIRST.  THE (END) STATEMENT DOES 
*         NOT TERMINATE THE ASSEMBLY, BUT ONLY STOPS (XTEXT) READING. 
  
  
          QUAL   PASS1
 XTEXT    BSS    0
  
 RM       IFEQ   CP#RM,0
          RECALL B
          RECALL X
 RM       ENDIF 
  
          RJ     CRL         CHECK RECURSION LIMIT                      S004  17
          SA2    BADLOC 
          SA3    LOCSYM 
          NZ     X2,XTX2     IF BAD LOCATION SYMBOL 
          NZ     X3,XTX1     IF FILE NAME 
          SA3    CP.XNAME    USE DEFAULT FILE NAME
          MX0    6
 +        LX3    6           RIGHT JUSTIFY FILE NAME
          BX6    X0*X3
          NZ     X6,*        LOOP 
 XTX1     MX0    18 
          BX4    X3*X0
          NZ     X4,XTX2     IF GREATER THAN 7 CHARACTERS 
          MX0    12          LEFT JUSTIFY FILE NAME 
          BX6    X3          SAVE FILE NAME FOR SEQUENCE FIELDS 
          SA6    P1TEMPA
 +        BX6    X0*X3
          LX3    6
          ZR     X6,*        LOOP 
          SX1    B1 
          BX6    X1+X3
          SA6    XTF
  
          IFNE   CP#RM,0,2
          LX7    X3 
          SA7    XDUM 
  
          PL     X6,XTX3     IF FILE NAME NON-NUMERIC 
 XTX2     SX6    B1 
          SA6    EFLG 
          SA6    LERR        POST BAD LOCATION SYMBOL 
          EQ     CTL70
  
 RM       IFEQ   CP#RM,0
 XTX3     REWIND X
 RM       ELSE
 XTX3     SX1    LXDUM       INITIALIZE FILE INFORMATION TABLE
          SX2    XDUM 
          SX3    X
          RJ     MOVE 
 RM       ENDIF 
  
          SA1    CP.IFORM    SAVE AND CLEAR INPUT FORMAT
          SA2    EOFINP      AND END OF INPUT FLAG
          BX6    X1 
          LX7    X2 
          SA6    P1TEMPD
          SA7    A6+B1
          MX6    0
          SA6    A1 
          SA6    A2 
          RJ     SCITEM      GET RECORD NAME
          ZR     X6,XTX13A   IF NO NAME 
          MX0    12          LEFT JUSTIFY NAME
 +        BX3    X0*X6
          LX6    6
          ZR     X3,*        LOOP 
          SA6    P1TEMPB
  
*         READ RANDOM INDEX AND SEARCH FOR RECORD.
  
 DM       IFNE   CP#RM,7                                                S028 475
  
          RJ     MTD         MAKE ROOM FOR INDEX
          SA2    O.MEMORY 
          SA3    O.ENDTAB 
          IX3    X3-X2       NUMBER OF WORDS
          SB7    X3-10000B
          NG     B7,XTX4     IF LESS THAN 10000 WORDS 
          SX3    10000B 
 XTX4     SX3    X3-1 
          MX7    0           CLEAR INDEX AREA 
          SB7    X3 
          LX3    18 
          SA7    X2 
          BX6    X3+X2
 +        SB7    B7-B1
          SA7    A7+B1
          NZ     B7,*        LOOP 
          SA6    X+7         STORE INDEX AREA POINTERS IN FET 
          OPEN   X,READ,R    READ INDEX 
          SA0    VALUES      (A0) = VALUES
          SA1    X2+B1       RESET RANDOM BIT IN FET
          SX2    B1 
          LX2    47 
          BX6    X1+X2
          SA6    A1 
          SA5    XTF+7       (X5) = INDEX POINTERS
          SA3    X5 
          LX1    59-47
          BX4    X1*X3
          AX3    48 
          PL     X4,XTX8     IF NOT NAME INDEX OR NOT RANDOM FILE 
          SX3    X3-777000B 
          SA4    P1TEMPB
          ZR     X3,XTX6     IF UPDATE PROGRAM LIBRARY
  
*         SEARCH SCOPE RANDOM FILE INDEX. 
  
          AX5    18 
          SA3    A3+B1
          SB2    B1+B1
          SB3    X5 
 XTX5     SB3    B3-B2       SEARCH INDEX 
          BX2    X3-X4
          NO
          SA3    A3+B2
          NG     B3,XTEXTU   IF NAME NOT IN INDEX 
          NZ     X2,XTX5     LOOP 
          SA3    A3-B1       SET RECORD ADDRESS IN FET
          BX6    X3 
          SA6    X+6
          EQ     XTX14
  
 DM       ELSE
  
          OPENM  X,INPUT,E
          FETCH  X,RT,X1
          FETCH  X,BT,X2
          SX3    X1-#WT#
          BX4    X2+X3
          NZ     X4,XTEXTU   IF BLOCKED, OR RECORD TYPE NOT *W* 
          SKIPBL X,1
          GETP   X,VALUES,50 READ SCOPE2 HEADER AND RANDOM INDEX
          FETCH  X,FP,X4
          SX0    EOD
          SA1    =7LDIRECT$ 
          SA2    VALUES 
          BX3    X0*X4
          SX5    VALUES+2 
          BX4    X1-X2
          BX6    X3+X4
          NZ     X6,XTX8     IF NOT UPDATE PROGRAM LIBRARY
  
 DM       ENDIF 
  
*         SEARCH UPDATE PROGRAM LIBRARY DECK LIST.
  
 RM       IFEQ   CP#RM,0
  
 XTX6     SA3    X5          DECK LIST RECORD ADDRESS AND LENGTH
          LX1    47-59
          SX6    X1          SET IN = OUT = FIRST 
          BX7    X3 
          SA6    A1+B1
          SA7    A5-B1       STORE RANDOM ADDRESS IN FET
          SA6    A6+B1
          SA3    A3+2        MASTER CONTROL CHARACTER 
          SA1    =0LCOMDECK 
          MX0    -6          (P1TEMPC) = *COMDECK 
          BX3    -X0*X3      WHERE * IS MASTER
          BX6    X1+X3       CONTROL CHARACTER
          LX6    -6 
          SA6    P1TEMPC
          BX0    X4          (X0) = RECORD NAME 
          READ   X
          READW  X2,A0,2     IGNORE FIRST ENTRY 
          NZ     X1,XTEXTU   IF EOR 
          MX5    54          (X5) = NINE-CHARACTER MASK 
 XTX7     READW  X2,A0,2
          SA3    A0 
          NZ     X1,XTEXTU   IF EOR 
          BX6    X3-X0
          BX6    X5*X6
          NZ     X6,XTX7     LOOP 
          SX6    -B1         CP.IFORM = -1 (UPDATE COMMON DECK) 
          SA6    CP.IFORM    SET INPUT FORMAT 
          EQ     XTX13
  
 RM       ELSE
  
 XTX6     SA3    X5+2        MASTER CONTROL CHARACTER 
          SA1    =0LCOMDECK 
          MX0    -6          (P1TEMPC) = *COMDECK 
          BX3    -X0*X3      WHERE * IS MASTER
          BX6    X1+X3       CONTROL CHARACTER
          LX6    -6 
          SA6    P1TEMPC
          SA3    X5          DECK LIST RECORD ADDRESS AND LENGTH
          MX0    -30
          BX6    -X0*X3 
          POSITION X,X6 
          GETP   X,VALUES,20 IGNORE FIRST ENTRY 
          FETCH  X,FP,X4
          SX5    EOD
          BX3    X4*X5
          NZ     X3,XTEXTU   IF END OF DATA 
 XTX7     GETP   X,VALUES,20
          FETCH  X,FP,X4
          SX5    EOD
          BX2    X4*X5
          NZ     X2,XTEXTU   IF END OF DATA 
          MX5    54 
          SA3    VALUES 
          SA1    P1TEMPB     RECORD NAME
          BX6    X3-X1
          BX6    X5*X6
          NZ     X6,XTX7     LOOP 
          SX6    -B1         CP.IFORM = -1 (UPDATE COMMON DECK) 
          SA6    CP.IFORM    SET INPUT FORMAT 
          MX0    -30
          SA1    A3+B1
          BX1    -X0*X1 
          POSITION X,X1 
          EQ     XTX14
  
*         RECORD INDEXED FILE OR MODIFY PROGRAM LIBRARY.
  
 XTX8     REWINDM X 
          GET    X,VALUES,10 READ RECORD INDEX POINTER
          SA2    VALUES 
          MX0    6
          BX4    X0*X2
          LX4    6
          SX5    X4-70B 
          MI     X5,XTEXTU   IF NOT RECORD INDEXED
          MX0    -33
          BX3    -X0*X2      WORD ADDRESS OF INDEX
          MX0    -24
          LX2    -33
          BX7    -X0*X2 
          MX4    -1 
          IX6    X7+X4
          SA6    VALUES      LENGTH OF INDEX
          NG     X6,XTEXTU   IF ZERO LENGTH INDEX 
          POSITION X,X3 
          FETCH  X,FP,X3
          SX3    X3-#EOI# 
          ZR     X3,XTEXTU   IF EMPTY FILE
          GETP   X,VALUES+1,10     READ HEADER WORD 
          SA1    VALUES+1 
          PL     X1,XTEXTU   IF NOT NAME INDEX
 XTX8A    SA2    VALUES 
          SX4    B1+B1
          IX6    X2-X4
          SA6    A2 
          NG     X2,XTEXTU   IF END OF INDEX
          GETP   X,VALUES+1,20
          SA3    P1TEMPB     RECORD NAME
          SA4    VALUES+1 
          BX2    X3-X4
          NZ     X2,XTX8A    LOOP 
          SA3    A4+B1
          MX0    -33
          BX6    -X0*X3      WORD ADDRESS OF REQUEST RECORD 
          POSITION X,X6 
          EQ     XTX14
  
 RM       ENDIF 
  
*         CHECK FOR MODIFY INDEX. 
  
 RM       IFEQ   CP#RM,0
  
 XTX8     SKIPEI X           READ INDEX 
          SKIPB  X2,2 
          READ   X2 
          SX6    -2          CP.IFORM = -2 (MODIFY COMMON DECK) 
          SA6    CP.IFORM    SET INPUT FORMAT 
 XTX9     READW  X2,A0,1
          NZ     X1,XTEXTU   IF EOR READ
 XTX10    SA1    A0          CHECK FOR 7700 TABLE 
          LX1    18 
          SX7    X1-770000B 
          MX5    0
          NZ     X7,XTX11    IF NOT 7700 TABLE
          LX1    6           SKIP 7700 TABLE
          READW  X2,A0,X1 
          NZ     X1,XTEXTU   IF EOR READ
          EQ     XTX9        READ NEXT TABLE
 XTX11    SX7    X1-700000B 
          NZ     X7,XTEXTU   IF NOT OPLD
          SA4    P1TEMPB
          BX0    X4 
 XTX12    READW  X2,A0,2     CHECK RECORD NAME
          NZ     X1,XTEXTU   IF RECORD NOT FOUND
          SA1    A0 
          BX6    X1-X0
          ZR     X6,XTX13    IF RECORD FOUND
          MX4    -3 
          BX6    -X4-X6 
          NZ     X6,XTX12    IF RECORD NOT FOUND
  
*         SET RANDOM ADDRESS. 
  
 XTX13    RECALL X
          SA2    A0+B1
          BX6    X2 
          SA6    X+6
 XTX13A   BSS    0
  
 RM       ELSE
  
  
 XTX13A   OPENM  X,INPUT,R   OPEN FOR SEQUENTIAL
  
 RM       ENDIF 
  
*         READ RECORD.
  
 XTX14    MX6    0
          SA6    VALUES+9 
          SA2    L.LASTAB 
          BX6    X2 
          SA6    P1TEMP 
          SA1    XTF+1       SET IN = OUT = FIRST 
          SX6    X1 
          SA6    A1+B1
          SA6    A6+B1
          SX2    X
          SA0    VALUES 
  
          IFEQ   CP#RM,0,1
          READ   X2          READ HEADER
  
          SA1    CP.IFORM 
  
 RM       IFNE   CP#RM,7                                                S028 493
          PL     X1,XTX15    IF NOT A PROGRAM LIBRARY FILE
          LX1    59 
          PL     X1,XTX19    IF UPDATE
          EQ     XTX16       MODIFY 
 RM       ELSE
          MI     X1,XTX19    IF UPDATE PROGRAM LIBRARY
 RM       ENDIF 
  
*         READ FROM A NON-PROGRAM-LIBRARY FILE. 
  
 XTX15    RJ     CIF         CHECK INPUT FORMAT 
          SA1    EOFINP 
          SA3    CP.IFORM 
          NZ     X1,XTX22    IF NO DATA 
          ZR     X3,XTX20    IF NOT COMPRESSED SOURCE INPUT 
          EQ     XTX21
  
*         READ MODIFY COMMON DECK.
  
 RM       IFEQ   CP#RM,0
  
 XTX16    READC  X2,A0,9     READ HEADER
          NZ     X1,XTEXTU   IF EMPTY RECORD
          SA1    A0          CHECK IF OPLC
          LX1    18 
          SX6    X1-770000B 
          NZ     X6,XTEXTU   IF NOT 7700 HEADER 
          LX1    6
          READW  X2,A0,X1    SKIP 7700 TABLE
          SA1    B6-B1
          SB7    X1-64B      CHECK LAST WORD OF 7700 TABLE
          NZ     B7,XTX16A   IF NOT 64 CHARACTER SET
          SX7    -4          CP.IFORM = -4 (MODIFY COMDECK, 64 CHAR SET)
          SA7    CP.IFORM    SET INPUT FORMAT 
 XTX16A   MX6    0
          SA6    VALUES+9 
          READW  X2,A0,1
          NZ     X1,XTEXTF   IF NO DATA 
          SA1    A0 
          SX5    X1 
          LX1    18 
          SX6    X1-700200B 
          NZ     X6,XTEXTF   IF FUNNY DATA
          ZR     X5,XTX18    IF NO CORRECTION IDENT TABLE 
 XTX17    READW  X2,A0,1     SKIP CORRECTION IDENT TABLE
          NZ     X1,XTEXTF   IF EOR 
          SX5    X5-1 
          NZ     X5,XTX17    LOOP 
 XTX18    RJ     RNC         READ FIRST ACTIVE CARD 
          EQ     XTX21
  
 RM       ENDIF 
  
*         READ UPDATE COMMON DECK.
  
 XTX19    RJ     RNC         READ FIRST ACTIVE CARD 
          SA1    EOFINP 
          SA5    X0 
          MX3    8*6
          NZ     X1,XTEXTU   IF NO ACTIVE CARDS 
          SA4    P1TEMPC     =8L*COMDECK WHERE * IS 
          BX1    -X3*X5      MASTER CONTROL CHARACTER 
          BX5    X3*X5
          BX5    X4-X5
          NZ     X5,XTEXTU   IF NOT *COMDECK
          AX1    6
          SX5    X1-1R       TEST NINTH CHARACTER 
          AX5    6
          BX1    X1*X5
          NZ     X1,XTEXTU   IF NOT 00B NOR 55B-77B 
          RJ     RNC         SKIP *COMDECK CARD 
          EQ     XTX21
  
*         READ TEXT.
  
 XTX20    BSS    0
  
 RM       IFEQ   CP#RM,0
          MX0    -18
          SA1    A0 
          BX6    -X0*X1 
          NZ     X6,XTX21    IF NOT TEXT FORMAT 
          READC  X2,A0,9     READ FIRST LINE
          NZ     X1,XTX22    IF EOR 
 RM       ENDIF 
  
 XTX21    SA1    CP.IFORM    RESTORE INPUT FORMAT 
          SA2    P1TEMPD
          BX6    X1 
          LX7    X2          SAVE NEW FORMAT
          SA6    A2 
          SA7    A1 
          RJ     CWI         WRITE *XTEXT* TO INTERMEDIATE
          SA1    P1TEMPD
          SA2    CP.IFORM 
          BX6    X1          SET NEW INPUT FORMAT 
          LX7    X2 
          SA6    A2 
          SA7    A1 
 XTX21A   SX2    X
          SA0    VALUES 
          RJ     RNS         READ NEXT STATEMENT
          RJ     SETUP
          SA2    IOP
          SX3    3REND
          BX6    X2-X3
          ZR     X6,XTX22A   IF *END* STATEMENT 
          PCARD  LASTAB 
          EQ     XTX21A      LOOP 
  
*         PROCESS END OF TEXT.
  
 XTX22    SA1    P1TEMPD     EMPTY RECORD - RESTORE INPUT FORMAT
          BX6    X1 
          SA6    CP.IFORM 
          RJ     CWI         WRITE *XTEXT* TO INTERMEDIATE
 XTX22A   SX1    1RT
          LX1    54 
          ADDWORD LASTAB
          SA1    P1TEMPD     RESTORE INPUT FORMAT AND END OF INPUT FLAG 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    CP.IFORM 
          SA7    EOFINP 
          SA1    P1TEMP 
          SX2    4
          SA4    P1TEMPA     XTEXT FILE NAME
          MX5    0
          BX3    X1 
          RJ     PUSHDOWN 
          SA1    XLEV        INCREMENT XTEXT LEVEL                      P036  54
          SX6    B1 
          SX7    X1+B1                                                  P036  56
          SA6    LIBFLG 
          SA7    A1                                                     P036  58
  
          IFNE   CP#RM,0,1
          CLOSEM X,R
  
          EQ     CTL100 
  
*         POST *F* ERROR. 
  
 XTEXTF   SX6    B1 
          SA6    FERR        FUNNY DATA 
          EQ     XTEXTQ 
  
*         POST *U* ERROR. 
  
 XTEXTU   SX6    B1 
          SA6    UERR        UNFOUND RECORD 
  
*         CLOSE THE FILE. 
  
 XTEXTQ   SA6    EFLG 
  
          IFEQ   CP#RM,0,2
          REWIND X
          ELSE   1
          CLOSEM X,R
  
          SA1    P1TEMPD     RESTORE INPUT FORMAT AND END OF INPUT FLAG 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    CP.IFORM 
          SA7    EOFINP 
          EQ     CTL70
 XTEXT    SPACE  4
 RM       IFNE   CP#RM,0
  
**        DUMMY FIT FOR RE-INITIALIZING XTEXT FIT.
  
  
 XDUM     FILE   FO=SQ,BT=,RT=W,MRL=5120,CM=NO,WSA=VALUES,PD=INPUT
 LXDUM    EQU    *-XDUM 
  
  
 RM       ENDIF 
 XTEXT    SPACE  4
**        XTEXT - EXTERNAL INPUT. 
  
  
          QUAL   PASS2
 XTEXT    EQU    ZLLA 
 BLANK    SPACE  4
***       BLANK OPERATION CODE. 
* 
* 
*SYM
*         (SYM) IS ASSIGNED THE VALUE OF THE LOCATION COUNTER,
*         AND ONE WORD IS ZEROED AND RESERVED.
*         IF (SYM) IS MISSING, THIS CARD IS IGNORED.
  
  
          QUAL   PASS1
 BLNKOP   SA2    LOCSYM 
          NZ     X2,BLNKOP1 
          PL     X2,CTL300
 BLNKOP1  SB7    X2-1R+ 
          ZR     B7,CTL70 
          EQ     B7,B1,CTL70
          SX6    B1          SET FIRST CARD GROUP FLAG
          SA6    IFCDGP 
          SA1    LWORD
          RJ     YPRLOC 
          SA1    LWORD
          RJ     UPPOS
          EQ     CTL70
 BLANK    SPACE  4
**        BLANK OPERATION CODE. 
  
  
          QUAL   PASS2
 BLNKOP   SA2    LOCSYM 
          ZR     X2,ZLIST    EXIT IF NO LOCATION FIELD ENTRY
          SA1    LWORD
          SB2    X2-1R+ 
          ZR     B2,ZLIST    EXIT IF SINGLE + OR - (WARNING 
          EQ     B1,B2,ZLIST FLAG SET IN PASS 1)
          RJ     ZPRLOC 
          SA4    MACHINE
          SX2    36 
 +        SX3    20 
          ZR     X4,*+2 
          SX2    25 
          SA3    PPBYT
          SX1    B0          CALL PACKO WITH 0, 36-11*MACHINE,
          RJ     PACKO       21-16*MACHINE
          SX6    B1 
          BX5    X6 
          SA6    FLAG        SAVE FOR PASS 2
          SA6    EXVAL
          SA6    IFCDGP      SET FIRST CARD GROUP FLAG
          EQ     BSSZ5       GO PRETEND ITS BSSZ 1
 =        SPACE  4
***       = - SYMBOL DEFINITION.
* 
*SYM      =      EXP
*         (SYM) IS ASSIGNED THE VALUE OF THE ADDRESS EXPRESSION.
  
  
          QUAL   PASS1
* =       EQU    EQU
 AUT      TITLE  PASS 1 SUBROUTINES.
**        AUT - ALLOCATE USE TABLE. 
*         ALLOCATES THE FIRST THREE USE BLOCKS.  THESE
*         BLOCKS ARE /ABSOLUTE*/, / /, AND /LITERALS*/. 
*         COUNTERS SET ARE -
*                (UI) = USE TABLE INDEX.
*                (UI+1) = FIRST BLOCK NUMBER. 
*                (LI) = LITERAL BLOCK INDEX.
*                (DI) = DEFAULT SYMBOL INDEX. 
  
  
          USE    SUBS 
          SEG    PASS 1 SUBROUTINES (A-P).
          QUAL   PASS1
 AUT      PS                 RETURN EXIT
          SA1    L.USETAB    SET NEW USE INDEX
          SA2    L.LITAB     SET NEW LITERAL INDEX
          SA3    L.SLITS     SET NEW DEFAULT SYMBOL INDEX 
          BX6    X1 
          LX7    X2 
          SA6    UI 
          SA7    LI 
          BX6    X3 
          SA6    DI 
          SX7    B1          SET NEW USE NUMBER 
          SX6    X7+2 
          SA7    UI+1 
          SA6    A7+B1
          MANAGE USETAB,3*4  ALLOCATE 3 BLOCKS
          SB5    4           PRESET FIRST 3 BLOCKS - ABS, 0, LIT
          SA1    LWORD       SET POSITION COUNTER 
          IX2    X2+X3
          SB7    X2-3*4      BASE ADDRESS 
          BX6    X1 
          LX6    24 
          SX7    B0 
          SA6    B7+B1
          SA6    A6+B5
          SA6    A6+B5
          MX6    0           STORE TYPE = 0 
          SA7    B7+2 
          SA6    A7+B1       CLEAR MAXIMUM BLOCK SIZE 
          SA7    A7+B5
          SA6    A7+B1
          SA7    A7+B5
          SA6    A7+B1
          SA1    =9RLITERALS* 
          SA2    =9RABSOLUTE* 
          BX6    X2 
          SX7    1R 
          SA6    B7 
          SA7    A6+B5
          BX6    X1 
          SA6    A7+B5
          SA1    USESTK      CLEAR USE STACK
          SX2    MSTACK 
          MX0    30 
          BX3    X0*X1
          IX6    X3+X2
          SA6    A1 
          MANAGE RVTAB,3*1   ALLOCATE 1ST 3 RVTAB ENTRIES 
          SB7    X3-3*1      PRESET THEM TO ZERO
          MX6    0
          SA6    X2+B7
          SA6    A6+B1
          SA6    A6+B1
          EQ     AUT         RETURN 
 AVO      SPACE  4
**        AVO - ADVANCE OVERLAY.
  
  
 AVO      PS                 RETURN EXIT
          SA1    L.USETAB    SET NEW USE INDEX
          SA2    L.EPTAB     SET NEW EPTAB INDEX
          SA3    L.LITAB     SET NEW LITAB INDEX
          SA4    L.SLITS     SET NEW SLITS INDEX
          BX6    X1 
          LX7    X2 
          SA6    UI 
          SA7    EI 
          BX6    X3 
          LX7    X4 
          SA6    LI 
          SA7    DI 
          SX7    B1          SET NEW USE NUMBER 
          SA7    UI+1 
          EQ     AVO         RETURN 
 COB      SPACE  4
**        COB - CLOSE OUT BLOCKS. 
  
  
 COB      PS                 RETURN EXIT
          RJ     YFOUP       CLOSE OUT ALL BLOCKS 
          RJ     RSL         RECORD SEGMENT LENGTH
          SA1    ORGCTR+1 
          NZ     X1,COB1     CORRECT FOR ZERO BLOCK NUMBER
          SA1    UI+1 
          BX6    X1 
          SA6    ORGCTR+1 
 COB1     LX1    2
          SB6    X1-3 
          SA2    O.USETAB 
          SA1    UI 
          IX2    X1+X2       BASE ADDRESS OF BLOCK GROUP
          SA1    ORGCTR 
          MX0    -21
          SA3    LWORD
          BX6    -X0*X1 
          LX3    24 
          IX7    X6+X3
          SA7    X2+B6       NOTE LENGTH AND POSITION 
          RJ     YFUALL 
          SA1    O.USETAB    CORRECT BLOCK LENGTHS FOR MAXIMUM
          SA2    L.USETAB 
          SA3    UI 
          IX1    X1+X3
          IX2    X2-X3
          SB6    4
          SB7    X2-4 
          SA0    X1+2 
          MX0    39 
 COB2     SA1    A0-B1       LAST ORGCTR VALUE
          SA2    A0+B1       MAXIMUM ORGCTR VALUE 
          BX3    -X0*X1 
          IX4    X2-X3
          BX6    X1 
          NG     X4,COB3
          IX6    X4+X6
 COB3     SB7    B7-B6
          SA0    A0+B6
          SA6    A1 
          PL     B7,COB2     LOOP 
          EQ     COB         RETURN 
 CRL      SPACE  4                                                      S004  19
**        CRL - CHECK RECURSION LIMIT.                                  S004  20
*         IF LIMIT IS ABOUT TO BE EXCEEDED, POST *F* ERROR              S004  21
*         AND SET (CRLF) = 1.                                           S004  22
                                                                        S004  23
                                                                        S004  24
 CRL      PS                 RETURN EXIT                                S004  25
          SA1    L.STACK                                                S004  26
          SB7    X1-4*"LIMRECUR"                                        S004  27
          MI     B7,CRL      IF NOT EXCEEDED                            S004  28
          SX6    B1                                                     S004  29
          SA6    CRLF        SET FLAG FOR /PASS2/CRL                    S004  30
          SA6    EFLG                                                   S004  31
          SA6    FERR        POST *F* ERROR                             S004  32
          JP     CRL                                                    S004  33
 CWI      SPACE  4
**        CWI - CONDITIONAL WRITE INTERMEDIATE. 
*         WRITE INTERMEDIATE ONLY IF LINE WILL LIST IN PASS 2.
  
  
 CWI      PS                 RETURN EXIT
          SA1    /PASS2/RISA
          SA3    EFLG 
          NZ     X3,CWI2     IF ERROR FLAG SET
          SB7    30 
 CWI1     AX2    X1,B7
          SA3    X1 
          SA4    X2 
          BX0    -X3*X4 
          SA1    A1+B1
          ZR     X0,CWI1     IF LIST TEST DOESNT FAIL 
          SX6    A1-/PASS2/RISA-/PASS2/RISAL
          NZ     X6,CWI      IF LINE WILL NOT LIST
 CWI2     RJ     WINTER      WRITE INTERMEDIATE 
          EQ     CWI         RETURN 
 DSL      SPACE  4
**        DSL - DEFINE SYMBOL LITERALS. 
*         USES   P1TEMP, P1TEMPA, P1TEMPB, P1TEMPC. 
  
  
 DSL7     SA1    QVAL+1      RESTORE QUALIFIER
          BX6    X1 
          SA6    A1-B1
  
 DSL      PS                 RETURN EXIT
          SA2    QVAL 
          SA3    LOCSYM 
          SA1    L.SLITS
          BX7    X2 
          SA7    A2+B1
          BX6    X2+X3       SAVE POSSIBLY QUALIFIED END CARD SYMBOL
          SA6    P1TEMPB
 DSL1     SA2    DI 
          SX6    X1-1 
          IX2    X2-X1
          ZR     X2,DSL7     IF SYMBOL LITERALS COMPLETE
          SA6    P1TEMP      SAVE INDEXING COUNT
          SA2    O.SLITS     FETCH NEXT LITERAL 
          SB7    X6 
          SA2    X2+B7
          NG     X2,DSL3     IF DEFINED 
          MX0    12 
          BX1    -X0*X2 
          MX0    9           SET QUALIFIER
          LX0    -3 
          BX7    X0*X2
          AX2    57 
          SA7    QVAL 
          BX6    X2 
          SA6    A6+B1       STORE TYPE FLAG
          SA4    P1TEMPB     CHECK IF THIS IS END CARD SYMBOL 
          BX5    X1-X4
          BX5    X5-X7
          ZR     X5,DSL3
          RJ     TLUSYMT     LOOK UP SYMBOL 
          SA4    P1TEMPA
          LX2    59-30
          NG     X2,DSL3     IF SYMBOL IS ALREADY DEFINED 
          SB7    X4          TYPE FLAG
          SX0    B1 
          JP     DSL2+B7     JUMP ACCORDING TO TYPE OF LITERAL
  
  
 DSL2     BSS    0
  
 +        MX6    1           =Y LITERAL (WEAK EXTERNAL) 
          EQ     DSL6 
  
 +        SA2    O.USETAB    =S LITERAL 
          EQ     DSL4 
  
 +        MX6    0           =X LITERAL (STRONG EXTERNAL) 
          EQ     DSL6 
  
 DSL2A    SX6    B1 
          SA6    EFLG 
          SA6    FERR 
  
  
*         MULTIPLE OR ALREADY DEFINED.
  
 DSL3     SA1    P1TEMP      MULTIPLE OR ALREADY DEFINED
          EQ     DSL1 
  
*         =S SYMBOL LITERAL.
  
 DSL4     SA3    UI 
          SA4    A3+B1
          IX2    X2+X3
          SX3    X4+B1       RELOCATION = 0 BLOCK 
          SA2    X2+4+1      FETCH LENGTH OF 0 BLOCK
          MX4    0
          BX5    X5-X5
          IX6    X2+X0       AUGMENT LENGTH 
          SA6    A2 
          RJ     YDEFSYM     DEFINE SYMBOL
 DSL5     SA1    P1TEMP      MARK SYMBOL AS DEFINED BY COMPASS
          SA2    O.SLITS
          SB7    X1 
          SA2    X2+B7
          MX0    1
          BX6    X2+X0
          SA6    A2 
          EQ     DSL1        LOOP 
  
*         =X SYMBOL LITERAL.
  
 DSL6     SA2    L.EXTAB
          SA6    P1TEMPC
          SA4    ABSFG       COMPLAIN IF
          NZ     X4,DSL3     ABSOLUTE PROGRAM 
          BX6    X1 
          RJ     VFYLINK
          NZ     X7,DSL3     IF INAPPROPRIATE AS A LINKAGE SYMBOL 
          SA3    L.EXTAB
          SX3    X3-777B
          PL     X3,DSL2A    IF EXCEEDS 511 EXTERNALS 
          SX4    X2+B1
          BX2    X2-X2
          MX3    0
          SX5    B0 
          MX7    0
          SA7    QVAL        SET QUALIFIER
          RJ     YDEFSYM     DEFINE AS EXTERNAL SYMBOL
          SA2    P1TEMPC     RECLAIM WEAK-EXT BIT 
          BX1    X1+X2
          ADDWORD EXTAB      ADD ENTRY TO EXTERNAL TABLE
          EQ     DSL5 
 EDIT     SPACE  4
**        EDIT - EDIT STATEMENT TO REMOVE MICROS/CONCATENATION. 
*         EDIT IS A NULL FUNCTION IF (EDITFG) IS POSITIVE, OR IF CARD 
*         IS A COMMENT.  OTHERWISE, EDIT WILL SCAN THE CARD CHECKING
*         FOR *_* AND *"* MARKS.  THE CARD IS WRITTEN ON THE
*         INTERMEDIATE (MICFLG = 1) AND A NEW CARD IS CREATED.
*         EXIT   (CCT) = CARD COUNT.
*                (LASTCOL) = INDEX OF LAST CHARACTER. 
  
  
 EDIT     PS                 RETURN EXIT
          SA2    EDITFG 
          PL     X2,EDIT     IF NO EDITING
          SA1    CARD 
          SB7    X1-1R* 
          ZR     B7,EDIT     IF COMMENT CARD
          SA4    LASTCOL     CHECK FOR CONCATENATION AND MICRO MARKS
          SX2    B1 
          SB7    X1 
          LX4    -1 
          BX6    X6-X6
          SA5    A1+B1
          SB3    X4 
          PL     X4,EDT1     IF (LASTCOL) IS EVEN 
          SA1    A1+B1
          SA5    A5+B1
          LX3    X2,B7
          BX6    X6+X3
          SB7    X1 
 EDT1     SA1    A5+B1
          LX3    X2,B7
          SB3    B3-B1
          BX6    X6+X3
          SB7    X5 
          LX3    X2,B7
          SA5    A1+B1
          BX6    X6+X3
          SB7    X1 
          GE     B3,B1,EDT1  IF NOT END OF CARD 
          LX6    59-MICMARK 
          NG     X6,EDT6     IF MICRO MARK
          LX6    60+MICMARK-CONCAT
          PL     X6,EDIT     IF NO CONCATENATION MARK 
  
*         REMOVE CONCATENATION MARK ONLY. 
  
          SX6    B1          WRITE CARD ON INTERMEDIATE 
          SA6    MICFLG 
          RJ     CWI
          SA4    LASTCOL
          SA1    STYPE
          SB2    -CONCAT
          SB3    X4+CARD-1   (B3) = LWA OF STATEMENT
          SB4    X4 
          BX6    X1 
          SA6    STYPE
 EDT2     SA1    A1+B1       REMOVE CONCATENATION 
          SB4    B4-B1
          SX7    X1+B2
          BX6    X1 
          ZR     X7,EDT2     IF CONCATENATION 
          SA6    A6+B1
          GE     B4,B1,EDT2  LOOP TO END OF CARD
  
*         PROCESS END OF CARD.
  
 EDT3     SB5    A6 
          SB6    A6 
          SX7    A6-CARD+1
 +        NZ     X7,*+1      IF NOT ALL BLANKS
          SX7    B1 
          SA7    LASTCOL
          SX6    1R 
          GE     B6,B3,EDT4  IF NEW (LASTCOL) \ OLD (LASTCOL) 
          SB7    B3 
 +        SB6    B6+B1       CLEAR TO END OF CARD 
          SA6    A6+B1
          LT     B6,B3,*
 EDT4     MX6    0
          SA6    SQLGN
          SA6    MICFLG 
          SX7    B0          COUNT NUMBER OF CARDS
          SB6    71 
          SB5    B5-CARD
 EDT5     SB5    B5-B6
          SX7    X7+B1
          GT     B5,EDT5     LOOP 
          SA7    CCT
          SX5    X7-1 
          ZR     X5,EDIT     RETURN 
          SA1    SEQ         COPY SEQUENCE FIELDS 
          SA2    CP.IFORM 
          LX2    59-0 
          PL     X2,EDT5.2   IF NOT MODIFY FORMAT 
          BX6    X1 
          SA6    A1 
 EDT5.1   SA6    A6+1        COPY ONE WORD MODIFY SEQUENCE NUMBERS
          SX5    X5-1 
          NZ     X5,EDT5.1   LOOP 
          EQ     EDIT        RETURN 
  
 EDT5.2   BSS    0           COPY TWO WORD UPDATE SEQUENCE FIELDS 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA7    A2 
 +        SA6    A7+B1
          SA7    A6+B1
          SX5    X5-1 
          NZ     X5,*-1      LOOP 
          EQ     EDIT        RETURN 
  
*         REMOVE CONCATENATION AND REPLACE MICROS.
  
 EDT6     SX6    B1          WRITE CARD ON INTERMEDIATE 
          SA6    MICFLG 
          RJ     CWI
  
*         PACK CARD REMOVING CONCATENATION. 
  
          SB7    60 
          SA1    STYPE
          SA4    LASTCOL
          SB2    CONCAT 
          SB5    X4+B1
          SB6    6
          BX6    X6-X6
          PX0    X6,B7
          SB4    B5 
          SA6    SQIMAGE
  
 EDT7     LX6    6           PACK CHARACTER 
          SB7    B7-B6
          BX6    X6+X1
          SA1    A1+B1
 EDT8     NZ     B7,EDT9     IF WORD NOT FULL 
          SA6    A6+B1
          UX6,B7 X0 
 EDT9     SB5    B5-B1
          SB3    X1 
          ZR     B5,EDT10    IF END OF CARD 
          NE     B3,B2,EDT7  IF NOT CONCATENATION 
          SB4    B4-B1
          SA1    A1+B1
          EQ     EDT9        LOOP 
 EDT10    LX6    X6,B7
          SA6    A6+B1
  
*         UNPACK CARD AND REPLACE MICROS. 
  
          SA0    10 
          SB3    X4+CARD-1   (B3) = LWA OF STATEMENT
          SA1    SQIMAGE+1
          MX0    54 
          LX1    6
          SB2    -MICMARK 
          BX6    -X0*X1 
          SB7    A0-B1
          SA6    STYPE
          SB5    71*NCARDS
          EQ     EDT12
 EDT11    NG     B5,EDT12    IF PAST END OF CARD AREA 
          SB5    B5-B1
          SA6    A6+B1
 EDT12    LX1    6
          SB7    B7-B1
          BX6    -X0*X1 
          SB4    B4-B1
 +        NZ     B7,*+1      IF NOT END OF WORD 
          SA1    A1+B1
          SB7    A0 
 +        SX7    X6+B2
          ZR     B4,EDT3     IF END OF CARD 
          NZ     X7,EDT11    IF NOT MICRO MARK
  
*         COMPILE MICRO NAME. 
  
          SA4    A6 
 EDT13    NG     B5,EDT14    IF PAST END OF CARD AREA 
          SB5    B5-B1
          SA6    A6+B1
 EDT14    SB7    B7-B1
          LX1    6
          BX6    -X0*X1 
          SB4    B4-B1
          NZ     B7,EDT15    IF NOT END OF WORD 
          SA1    A1+B1
          SB7    A0 
 EDT15    ZR     B4,EDT3     IF END OF CARD 
          LX7    6
          SB6    X6+B2
          BX7    X7+X6
          NZ     B6,EDT13    IF NOT MICRO MARK
  
*         SEARCH FOR MICRO. 
  
          AX7    6
          SX3    B4          SAVE (B4)
          MX2    12 
          BX5    X2*X7
          SB4    B1 
          NZ     X5,EDT17    IF NAME > 8 CHARACTERS 
          ZR     X7,EDT18    IF EMPTY MICRO NAME
          RJ     TLUMIC      LOOK UP MICRO
          MX0    -6          SET UP MASK
          NZ     B4,EDT18    IF FOUND 
  
*         POST MICRO ERROR. 
  
 EDT17    SX7    B1 
          SB4    X3 
          SX6    -B2
          SA7    W9ERR
          SA7    EFLG 
          EQ     EDT11
  
*         REPLACE MICRO NAME. 
  
 EDT18    SX7    A6-B3
          NG     X7,EDT19    IF NOT PAST LAST COLUMN
          SB3    A6 
 EDT19    LX6    X4 
          SB5    A4-CARD+1-71*NCARDS
          SB6    B4-B1       NUMBER OF VALUE WORDS
          SA6    A4 
          SB5    -B5
          SA2    A2+B1       FIRST VALUE WORD 
          SB4    A0 
          ZR     B6,EDT23    IF VALUE IS NULL 
          GT     B6,B1,EDT22 IF MORE THAN ONE VALUE WORD
 EDT20    BX6    -X0*X2 
          SB4    X6+B1
          EQ     EDT22
 EDT21    NG     B5,EDT22    IF PAST END OF CARD AREA 
          SB5    B5-B1
          SA6    A6+B1
 EDT22    LX2    6
          SB4    B4-B1
          NO
          BX6    -X0*X2 
          NZ     B4,EDT21    IF NOT END OF WORD 
          EQ     B6,B1,EDT23 IF END OF LAST WORD
          SB6    B6-B1
          SB4    A0 
          SA2    A2+B1
          GT     B6,B1,EDT21 IF NOT LAST WORD 
          NG     B5,EDT20    IF PAST END OF CARD AREA 
          SB5    B5-B1
          SA6    A6+B1
          EQ     EDT20
 EDT23    SB4    X3 
          EQ     EDT12
  
  
 EDITM    BSS    0
          POS    60-MICMARK 
          VFD    1/1
          POS    60-CONCAT
          VFD    1/1
          POS    0
 EMT      SPACE  4
**        EMT - ENTER MICRO TABLE.
*         ENTRY  (X6) = NUMBER OF WORDS IN MICRO. 
*                (RELVEC) = MICRO.
  
  
 EMT      PS                 RETURN EXIT
          SA6    P1TEMP 
          SA5    LOCSYM 
          SA2    BADLOC 
          ZR     X5,EMT5     IF BAD LOCATION
          NZ     X2,EMT5
          SA2    O.MICTAB    SEARCH FOR MICRO 
          SA4    L.MICTAB 
          SB7    X6 
          SB2    X4-1 
          PX6    X5,B7
          SA6    RELVEC-1+B7 STORE NAME AND LENGTH
          SA6    X2 
 EMT1     SA3    X2+B2       SEARCH TABLE 
          UX1,B7 X3 
          BX1    X1-X5
          SB2    B2-B7
          NZ     X1,EMT1     IF NAME NOT FOUND
          MI     B2,EMT3     IF NAME NOT IN TABLE 
          IX1    X2+X4
          SX2    A3+B1
          SB7    -B7
          IX1    X1-X2
          SX7    X4+B7
          SX3    X2+B7
          SA7    P1TEMPA
          ZR     X1,EMT2
          RJ     MOVE        ELIMINATE OLD DEFINITION 
 EMT2     RJ     ASU         ACCUMULATE STORAGE USED
          SA1    P1TEMPA
          BX6    X1          REDUCE MICRO TABLE LENGTH
          SA6    L.MICTAB 
 EMT3     SA1    P1TEMP      GET ROOM FOR MICRO 
          MANAGE MICTAB,X1
          SA1    P1TEMP      STORE MICRO
          IX4    X2+X3
          SX2    RELVEC 
          IX3    X4-X1
          RJ     MOVE 
          EQ     EMT
 EMT5     SX6    B1          SET L-ERROR
          SA6    EFLG 
          SA6    LERR 
          EQ     CTL70
 GSM      SPACE  4
**        GSM - GENERATE SYSTEMS MACRO TEXT.
  
  
 GSM      PS                 RETURN EXIT
          SA1    SYNAME 
          SA2    B
          ZR     X1,GSM      IF NO SYSTEXT GENERATION 
          ZR     X2,GSM      IF NO BINARY FILE
          SA2    ERCNT
          NZ     X2,GSM15    IF ERRORS
          SA3    PRFX+6 
          MX0    30 
          BX6    X1          DECK NAME
          SA4    =1HT 
          BX3    X0*X3
          LX7    X4 
          BX4    -X0*X4 
          SA6    DPBA+1 
          SA7    A3+B1       DECK TYPE = T
          BX6    X3+X4
          SA6    A3          TARGET, VALID, *F = BLANKS 
          SB4    PRFXC
          SB5    PRFXC+7
          MX6    0
 +        SA6    B4          CLEAR PRFX COMMENT AREA
          SB4    B4+B1
          LT     B4,B5,*
          SA4    L.SEGTAB    FIND COMMENT TEXT IN IDTAB 
          SA3    O.IDTAB
          SB7    X3 
          MX0    -12
          SX5    X4-5 
          SA2    L.IDTAB
          MI     X5,*+2      IF ONLY ONE SEGMENT
 +        SA4    O.SEGTAB 
          SA2    X4+5 
 +        SB4    PRFXC
          SB6    X3+B1
          SB7    B7+X2
 +        SA1    B6          FIND END OF COMPRESSED IDENT STATEMENT 
          BX6    -X0*X1 
          SB6    B6+B1
          NZ     X6,*-1 
 +        GE     B6,B7,GSM0  IF END OF COMMENT TEXT 
          SA1    B6 
          SB6    B6+B1
          BX6    X1 
          SA6    B4 
          SB4    B4+B1
          LT     B4,B5,*-2   IF PRFX TABLE NOT FULL 
 GSM0     SA1    =50000101BS36
          BX6    X1 
          SA6    OVLHDR 
  
          IFEQ   CP#RM,0,1
          WRITEW B,PRFX,LPRFX+1 
  
          SA1    L.SYMTAB    GENERATE SYSTEM SYMBOL TABLE 
          MANAGE DUPTAB,X1+B1 
          SB7    X3-1 
          SA7    X2 
          SB6    X2 
          SA4    O.SYMTAB 
          SB4    X4+B7
          MX0    12 
          MX1    60-21
          SB2    B1+B1
          SA5    =36777BS21 
          SB5    59-30                                                  S028 504
          SB3    -2R'?
  
*         TRANSFER SYMBOLS FROM SYMTAB TO DUPTAB. 
  
 GSM1     ZR     B7,GSM2     IF END OF SYMBOL TABLE 
          SX7    B4-B7
          RX2    X7 
          SB7    B7-B2
          ZR     X2,GSM1     IF NO SYMBOL 
          SX7    X7+B1
          RX3    X7 
          BX6    X0*X2
          NZ     X6,GSM1     IF QUALIFIED SYMBOL
          BX6    X2 
          AX2    36 
          SX4    X2+B3
          SA6    A7+B1
          ZR     X4,GSM1     IF LOCAL SYMBOL
          BX4    X5*X3
          LX7    X3,B5                                                  S028 506
          NZ     X4,GSM1     IF SET, EXTERNAL, RELOCATABLE, OR XTEXT
          PL     X7,GSM1     IF NOT DEFINED                             S028 508
          BX7    -X1*X3 
          SA7    A6+B1
          EQ     GSM1        LOOP 
 GSM2     SX6    A7-B6
          SA6    B6 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,B6,X6+B1 
 RM       ELSE
          SA1    L.MICTAB 
          SX2    X6+B1       SYMBOL TABLE LENGTH
          IX3    X2+X2
          LX2    3           MULTIPLY BY TEN
          IX6    X2+X3
          SA6    T6RM1       SAVE IT
          IX2    X1+X1
          LX1    3           MULTIPLY MICRO TABLE LENGTH BY TEN 
          IX7    X1+X2
          SA7    A6+B1       SAVE IT TOO
          SX3    10*LPRFX+10 ADD LENGTH OF PRFX + OVERLAY HEADER
          IX5    X6+X7
          SA1    B-1                                                    S028 510
          IX4    X5+X3
 +        ZR     X1,*+1      IF RECORD TYPE W                           S028 512
          SX4    0                                                      S028 513
          STORE  B,RL=X4
          PUTP   B,PRFX,X3
          SA3    T6RM1
          SA2    O.DUPTAB 
          PUTP   B,X2,X3
 RM       ENDIF 
  
          RJ     ASU         ACCUMULATE STORAGE USED
          SX6    B0 
          SA6    L.DUPTAB 
  
*         WRITE MICRO TABLE.
  
          SA3    L.MICTAB 
          SA2    O.MICTAB 
          SA6    A3                                                     S028 515
          SX6    X3-1 
          SA6    X2          STORE WORD COUNT 
  
          IFEQ   CP#RM,0,2
          WRITEW B,X2,X3
          ELSE   2
          SA3    T6RM2       GET CHARACTER COUNT
          PUTP   B,X2,X3
  
*         GENERATE MACRO NAME TABLE.
  
          SA1    L.OPTAB     MAKE ROOM FOR TABLE
          MANAGE TEMTAB,X1+B1 
          RJ     ASU         ACCUMULATE STORAGE USED
          SA1    O.OPTAB
          SA2    O.TEMTAB 
          SB2    B1+B1
          SB5    X1 
          SB6    X1+NOPCT*2-2 
          SB7    X2+B1
          MX0    12 
 GSM3     GT     B5,B6,GSM9  IF LAST HASH CHAIN FINISHED
          SA1    B5          GET FIRST OPTAB ENTRY IN CHAIN 
          SA2    B5+B1
          SB5    B5+B2       BUMP CHAIN NUMBER
          BX5    X0*X1
          ZR     X1,GSM3     IF NULL CHAIN
 GSM4     BX3    X2 
          LX2    59-47
          SX4    B1 
          BX7    X3          INSPECT OPCODE TYPE
          AX3    57 
          IX6    X1-X5
          BX4    X3+X4
          LX5    13 
          ZR     X4,GSM6A    IF SYSTEM OR PROGRAM MACRO 
          MI     X2,GSM6     IF PROGRAM-DEFINED NON-MACRO 
 GSM5     ZR     X5,GSM3     IF END OF HASH CHAIN 
          SA1    B6+X5       GET NEXT ENTRY IN CHAIN
          SA2    A1+B1
          BX5    X0*X1
          EQ     GSM4 
 GSM6     SX4    B1          CLEAR PROGRAM-DEFINED FLAG 
          LX4    47 
          EQ     GSM7 
 GSM6A    SX4    B1          CLEAR PROGRAM MACRO FLAG 
          NZ     X3,GSM5     IF SYSTEM MACRO, IGNORE IT 
          LX4    57 
 GSM7     BX7    -X4*X7      STORE OPCODE ENTRY INTO TEMTAB 
          SB4    A1          SAVE ADDRESS OF CURRENT ENTRY
          SA1    B5-B2       RESCAN CHAIN TO SEARCH FOR DUPLICATES
 GSM8     SB3    A1 
          EQ     B3,B4,GSM8A IF CURRENT ENTRY 
          BX3    X0*X1
          IX2    X1-X3       REMOVE HASH LINK 
          LX3    13 
          BX2    X6-X2
          SA1    B6+X3       GET NEXT TO COMPARE WITH CURRENT 
          NZ     X2,GSM8     IF NOT DUPLICATE, LOOP 
          EQ     GSM5        DUPLICATE FOUND, IGNORE CURRENT ENTRY
 GSM8A    SA6    B7          NO DUPLICATE FOUND, STORE
          SA7    B7+B1       CURRENT ENTRY IN TEMTAB
          SB7    B7+B2
          EQ     GSM5 
 GSM9     SA1    O.TEMTAB    STORE WORD COUNT IN FIRST WORD 
          SB6    X1 
          SX6    B7-B6
          SX7    X6-1 
          SA6    L.TEMTAB    REDUCE TABLE SIZE
          SA7    X1 
  
*         GENERATE MACRO DEFINITION TABLE.
  
          SX0    B1 
          BX2    X7 
          MX1    -18                                                    S028 522
          SB7    57 
          LX0    38 
          AX6    X0,B1                                                  S028 524
          BX1    X1-X6       (X1) = MASK TO CLEAR LCM BIT AND ADDRESS   S028 525
 GSM10    SA3    X2+B6       SEARCH MACRO NAME TABLE
          ZR     X2,GSM14    IF END OF TABLE
          AX4    X3,B7
          SX5    X4+B1
          SX2    X2-2 
          BX6    X0*X3
          NZ     X5,GSM10    IF NOT A MACRO 
          ZR     X6,GSM11    IF NOT ALREADY ADJUSTED
          BX6    -X0*X3 
          SA6    A3          CLEAR FLAG BIT 
          EQ     GSM10
 GSM11    SA4    L.DUPTAB    CHECK FOR SYNONYMS 
          BX6    X1*X3                                                  S028 527
          IX7    X6+X4       ADJUST TEXT POINTER
          SX5    X2 
          SA7    A3 
          BX7    X0+X7
 GSM12    ZR     X5,GSM13    IF END OF TABLE
          SA4    X5+B6
          BX6    X3-X4
          SX5    X5-2 
          NZ     X6,GSM12    IF NOT SYNONYMOUS
          SA7    A4          SET FLAG BIT 
          EQ     GSM12
 GSM13    SX6    X2          SAVE POINTERS
          AX7    39 
          SA6    P1TEMP      P1TEMP  = TEMTAB INDEX 
          SA7    A6+B1       P1TEMPA = TEXT WORD COUNT
          BX6    -X1*X3      P1TEMPB = TEXT FWA IN MACDEF OR LCM        S028 529
          SA6    A7+B1
          MANAGE DUPTAB,X7   MAKE ROOM FOR TEXT 
          IX7    X2+X3
          SA1    P1TEMPA
          SA2    A1+B1
          LX2    59-37                                                  S028 531
          PL     X2,GSM13A   IF IN MACDEF                               S028 532
          LX2    37-59                                                  S028 533
          SX3    X1                                                     S028 534
          BX1    X2                                                     S028 535
          IX2    X7-X3                                                  S028 536
          RJ     RLC         MOVE TEXT FROM LCM TO DUPTAB               S028 537
          EQ     GSM13B                                                 S028 538
 GSM13A   LX2    37-59                                                  S028 539
          SA3    O.MACDEF 
          SX1    X1 
          IX2    X2+X3
          IX3    X7-X1
          RJ     MOVE        MOVE TEXT FROM MACDEF TO DUPTAB
 GSM13B   SA1    O.TEMTAB                                               S028 541
          SA2    P1TEMP 
          SX0    B1 
          SB7    57 
          SB6    X1 
          MX1    -18                                                    S028 543
          LX0    38 
          AX6    X0,B1                                                  S028 545
          BX1    X1-X6                                                  S028 546
          NZ     X2,GSM10    IF NOT END OF MACRO NAME TABLE 
  
*         WRITE MACRO TABLES. 
  
 RM       IFEQ   CP#RM,0
  
 GSM14    WRITEW B,L.DUPTAB,1 
          SA3    O.DUPTAB 
          SA4    L.DUPTAB 
          WRITEW X2,X3,X4    WRITE MACRO DEFINITION TABLE 
          SA3    O.TEMTAB 
          SA4    L.TEMTAB 
          WRITEW X2,X3,X4    WRITE MACRO NAME TABLE 
  
 RM       ELSE
  
 GSM14    SA5    L.DUPTAB 
          SA4    L.TEMTAB 
          SX3    X5+B1       MACRO DEFS SIZE + 1 FOR HEADER WORD
          IX2    X3+X4
          IX7    X2+X2
          LX2    3
          SA1    B-1                                                    S028 517
          IX4    X2+X7
 +        ZR     X1,*+1      IF RECORD TYPE W                           S028 519
          SX4    0                                                      S028 520
          STORE  B,RL=X4
          PUTP   B,L.DUPTAB,10
          SA5    L.DUPTAB 
          ZR     X5,GSM14A   IF NO MACRO DEFINITIONS                    S028 548
          IX7    X5+X5
          LX5    3
          IX3    X5+X7
          SA2    O.DUPTAB 
          PUTP   B,X2,X3     DUMP MACRO DEFINITION TABLE
 GSM14A   SA5    L.TEMTAB                                               S028 550
          IX7    X5+X5
          LX5    3
          IX3    X5+X7
          SA2    O.TEMTAB 
          PUTP   B,X2,X3     DUMP MACRO NAME TABLE
  
 RM       ENDIF 
  
 GSM15    WEOR   B
          RJ     ASU         ACCUMULATE STORAGE USED
          SX6    B0 
          SA6    L.DUPTAB 
          SA6    L.TEMTAB 
          EQ     GSM         RETURN 
 INPUT1   SPACE  4
**        INPUT1 - PASS 1 INPUT ROUTINE.
*         INPUT1 CREATES NEXT STATEMENT, EITHER BY UNPACKING FROM THE 
*         TABLE DICTATED BY THE TOP-MOST STACK ENTRY, OR BY CALLING 
*         RNS TO READ NEXT STATEMENT FROM THE SOURCE INPUT FILE.
*             INPUT1 ALSO CLEARS OUT... 
*                SQLGN             TO PERMIT PACKING OF STATEMENT.
*                ERFLAGS           TO CLEAR HANGING ERROR FLAGS.
*                FLAG              TO MINIMIZE INTERMEDIATE USAGE OF IT.
*                OPTYPE            TO AVOID CONFUSION IN *WINTER*.
*         INPUT1 WILL COMPLAIN IF RECURSION DEPTH IS TOO BIG. 
*         EXIT   (X1) " 0 IF PUSHUP OCCURRED. 
  
  
 INPUT1   PS                 RETURN EXIT
          SA2    L.STACK
          SA1    O.STACK
          ZR     X2,IN4      IF NORMAL INPUT                            S004  37
          SB4    X2-3 
          SA3    X1+B4       GET SECOND WORD OF STACK 
          SA1    A3-B1       GET CURRENT WORD POINTER 
          MX0    42 
          SA4    A3+2 
          SA5    =3R
          BX6    X0*X1
          LX7    X4 
          BX6    X6+X5
          SA7    SEQ         STORE MACRO NAME 
          SA6    A7+B1       STORE LEVEL NUMBER 
          AX3    56          LOOK AT TYPE 
          SB4    X3          SAVE TYPE OF STACK ENTRY 
          SX1    X1 
          JP     *+B4        JUMP ON TYPE OF STACK ENTRY
  
 +        EQ     INMAC       MACRO DEFINITION 
 +        EQ     INDUP       DUPTAB 
 +        EQ     INRMT       REMOTE TABLE INPUT 
 +        EQ     INLIB       LIBRARY TABLE INPUT
 +        EQ     INECH       ECHO TABLE INPUT 
  
*         INPUT FROM ECHTAB.
  
 INECH    SA2    O.ECHTAB 
          IX1    X1+X2
          RJ     UCARD
          SA1    O.ECHTAB 
          EQ     IN2
  
*         INPUT FROM LASTAB.
  
 INLIB    SA2    O.LASTAB 
          IX1    X2+X1
          RJ     UCARD
          SA1    O.LASTAB 
          EQ     IN2
  
*         INPUT FROM REMOTE ASSEMBLY TABLE  (RASTAB). 
  
 INRMT    SA2    O.RASTAB 
          IX1    X2+X1       CONSTRUCT ADDRESS
          RJ     UCARD       UNPACK CARD
          SA1    O.RASTAB 
 IN2      SA2    L.STACK
          SA3    O.STACK
          SB5    X2-4 
          SA2    X3+B5
          SA4    A2+B1
          IX7    X6-X1       UNBIAS FWA OF NEXT CARD
          MX6    1
          SX3    X2          STORE BACK INTO FIRST WORD OF STACK ENTRY
          IX3    X2-X3
          BX7    X3+X7
          AX4    56 
          SA6    EDITFG      SET FLAG TO CAUSE EDIT SCAN
          SA7    A2 
          MX6    0           CLEAR SQUEEZE FLAG 
          SA6    SQLGN
          SA3    STYPE
          SB4    X4-2 
          SB7    X3-1RT 
          NZ     B7,INP5     IF NOT A *T* TERMINATOR
          ZR     B4,IN3A     IF DUP ENTRY 
          SB4    B4-3 
          NZ     B4,IN3      IF NOT ECHO
          RJ     ITE         ITERATE ECHO 
          ZR     X2,INPUT1+1 IF NOT DONE, GO READ NEXT CARD 
 IN3      RJ     PUSHUP      ELSE PUSH STACK UP, RETURN FOR 
          EQ     INPUT1+1    NEXT CARD
 IN3A     SA4    A7+2        FETCH DUPLICATION CONTROL
          MX0    42 
          BX7    X0*X7
          NG     X4,IN3      IF STOPDUP IN EFFECT 
          SX5    X4          SIZE OF DUPTAB AT START OF DUP 
          SX3    B1 
          BX7    X7+X5       RESET POINTER TO FIRST CARD
          LX3    18 
          SA7    A7 
          IX6    X4-X3       DECREMENT DUP COUNT
          SA6    A4          RESTORE DECREMENTED 3RD WORD 
          AX4    19          TEST FOR END OF DUPLICATION
          ZR     X4,IN3      QUIT IF END OF DUP 
          EQ     INPUT1+1    ELSE GET NEXT CARD 
  
*         INPUT FROM MACRO. 
  
 INMAC    SA2    O.MACDEF 
          IX1    X2+X1
          RJ     UCARD
          SA1    O.MACDEF 
          EQ     IN2         GO UNBIAS NEXT ADDRESS 
  
*         INPUT FROM DUPLICATION (DUPTAB).
  
 INDUP    SA2    O.DUPTAB 
          IX1    X2+X1
          RJ     UCARD
          SA1    O.DUPTAB 
          EQ     IN2         AND GO TO UNBIAS RESULTANT ADDRESS 
  
*         IRP EXIT. 
  
 INP5     NE     B7,B1,INP1XX IF NOT IRP
          RJ     ITP         ITERATE IN PROTOTYPE 
          EQ     INPUT1+1    READ NEXT CARD 
  
*         NORMAL INPUT. 
  
 IN4      SX2    I
          SA0    CP.CARD
          RJ     RNS         READ NEXT STATEMENT
          SA1    SEQ
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    SEQMIC      STORE NEW SEQUENCE MICRO 
          SA7    A6+B1
  
*         EXIT FROM INPUT.
  
 INP1XX   SX6    B0          CLEAR ERROR FLAG 
          SA6    EXERR
          SA6    ERFLAGS
          MX7    0
          SB7    LERFLAGS-1 
          SA1    PUSHUP 
 +        SB7    B7-B1
          SA6    A6+B1
          NZ     B7,* 
          SA7    FLAG 
          SA6    MACHFLG
          SA6    OPTYPE      CLEAR OPTYPE 
          EQ     INPUT1      AND EXIT 
 ITE      SPACE  4
**        ITE - ITERATE ECHO PARAMETERS.
*         ENTRY  (A7) = STACK ADDRESS.
*         EXIT   (X2) = 1 IF END OF ECHO. 
  
  
 ITE      PS                 RETURN EXIT
          SA2    A7+B1
          SA3    A2+B1       READ SECOND STACK WORD 
          MI     X3,ITE2     IF STOPDUP IN EFFECT 
          SX6    X2 
          SA3    L.MARDIS 
          IX2    X3-X6
          SA6    ITEA 
          ZR     X2,ITE2     IF NO ARGUMENTS
 ITE1     SA4    ITEA 
          SA2    L.MARDIS 
          SX6    X4+B1
          SA6    A4 
          IX2    X2-X4
          ZR     X2,ITE      IF END OF ARGUMENTS
          RJ     SIA         SKIP ITERATIVE ARGUMENTS 
          NZ     X6,ITE1     IF NOT END OF ARGUMENT LIST
 ITE2     SX2    B1 
          EQ     ITE         RETURN 
  
 ITEA     DATA   0           ARGUMENT INDEX 
 ITP      SPACE  4
**        ITP - ITERATE IN PROTOTYPE. 
*         ENTRY  (A7) = STACK ADDRESS.
*                (X7) = UPDATED WORD 1 OF STACK ENTRY.
*                (X1) = FWA OF TEXT TABLE.
  
  
 ITP      PS                 RETURN EXIT
          SA4    A7+2        CHECK IRP PARAMETERS 
          ZR     X4,ITP1     IF START OF IRP
          RJ     SIA         SKIP ITERATIVE ARGUMENT
          NZ     X6,ITP      IF NOT END OF ITERATION
          SA6    A7+2        CLEAR IRP SWITCH 
          EQ     ITP         RETURN 
  
*         START NEW IRP.
  
 ITP1     SA3    CARD        PARAMETER NUMBER 
          SA2    A7+B1
          IX2    X3+X2
          SA5    O.MARDIS 
          SX2    X2-1 
          SB2    X5 
          SA2    B2+X2       READ ARGUMENT POINTER
          UX6,B7 X2          SETUP ITERATIVE DESCRIPTOR WORD... 
          SB7    -B7
          PX6    B7          - CHARACTER COUNT
          LX6    59-41
          PX6    B0          CHARACTER OFFSET 
          LX6    41-29
          PX6    B0          WORD OFFSET
          LX6    29-59
          ZR     B7,ITP3     IF EMPTY ARGUMENT
          SA6    A2 
          SX1    X7          PACK STACK WORD
          SX6    A2-B2
          LX1    18 
          BX6    X6+X1
          SA6    A4 
          EQ     ITP         RETURN 
  
*         EMPTY ARGUMENT, SKIP TO SECOND IRP. 
  
 ITP3     IX1    X7+X1       NEXT CARD ADDRESS
          SA1    X1 
          MX0    -12
          SX3    1LU+0001B   LOOK FOR U-CARD WITH COLON IN COLUMN 1 
          SX2    B1 
          LX3    42 
 ITP4     BX6    -X0*X1 
          IX7    X7+X2
          NO
          SA1    A1+B1
          NZ     X6,ITP4     IF NOT END OF STATEMENT
          BX6    X1-X3
          NZ     X6,ITP4     IF NOT SECOND IRP
          IX7    X7+X2
          SA7    A7          UPDATE CARD POINTER IN STACK 
          SA6    A7+2        CLEAR IRP SWITCH 
          EQ     ITP         RETURN 
 MACALL   SPACE  4
**        MACALL - PROCESS MACRO/OPDEF CALL (NOT RJ SUBROUTINE).
*         ENTRY  (MACRO) (B7) " 0.
*                (OPDEF) (B7) = 0.
*                        (X1) = OPERATION SYNTAX SCAN.
* 
*         SCRATCH CELL USAGE. 
* 
*                P1TEMP            LOCATION ARGUMENT FLAG.
*                P1TEMPA           TOTAL PARAMETER COUNT. 
*                P1TEMPB           LOCAL PARAMETER COUNT. 
*                P1TEMPC           MACRO FLAG (B7 ON ENTRY).
*                P1TEMPD           SYNTAX (X1 ON ENTRY).
  
  
 MACALL   SX7    B7          ENTRY
          SA5    OPTYPE 
          BX6    X1 
          SA7    P1TEMPC     SAVE MACRO/OPDEF FLAG                      S028 553
          SA6    A7+B1       SAVE SYNTAX                                S028 554
          LX5    59-37                                                  S028 555
          PL     X5,MCL0     IF TEXT NOT IN LCM                         S028 556
          AX5    39-60+59-37                                            S028 557
          MANAGE MACDEF,X5   MAKE ROOM IN MACDEF TABLE                  S028 558
          SA5    OPTYPE                                                 S028 559
          IX2    X2+X3                                                  S028 560
          MX0    -18                                                    S028 561
          BX1    -X0*X5      LCM ADDRESS                                S028 562
          BX6    X0*X5                                                  S028 563
          LX5    -39                                                    S028 564
          SX4    X5          WORD COUNT                                 S028 565
          SX7    1RT                                                    S028 566
          IX0    X3-X4                                                  S028 567
          LX7    42                                                     S028 568
          BX6    X6+X0       INSERT MACDEF INDEX INTO OPTYPE            S028 569
          IX7    X7+X4                                                  S028 570
          SA6    A5                                                     S028 571
          LX7    12          ADD T-CARD WITH WORD COUNT IN BITS 29-12   S028 572
          SA7    X2-1                                                   S028 573
          SX3    X5-1        WORD COUNT - 1                             S028 574
          IX2    X2-X4                                                  S028 575
          RJ     RLC         MOVE TEXT FROM LCM TO MACDEF               S028 576
 MCL0     SA5    OPTYPE                                                 S028 577
          SX2    B1                                                     S028 578
          MX0    -6                                                     S028 579
          SX1    X5 
          AX5    18 
          BX6    X2*X5
          AX5    1
          BX7    -X0*X5 
          SA6    P1TEMP 
          SA7    A6+B1
          AX5    6
          BX6    -X0*X5 
          LX5    -7 
          SA6    A7+B1
          PL     X5,MCL01    IF NOT MACROE
          IX4    X7-X6       MOVE KEYWORDS TO RELVEC+64 
          SA3    P1TEMP 
          SA2    O.MACDEF 
          SB2    X1 
          IX1    X4-X3
          SX2    X2+B2
          SB2    B2+X1
          SX3    RELVEC+64
          RJ     MOVE 
          SX1    B2 
 MCL01    SA2    L.MARGS     SAVE PARAMETERS FOR LATER PUSHDOWN CALL    S004  40
          SA3    L.MARDIS                                               S004  41
          SA4    IOP
          BX6    X1                                                     S004  43
          LX7    X2                                                     S004  44
          SA6    MCLA                                                   S004  45
          SA7    A6+B1                                                  S004  46
          BX6    X3                                                     S004  47
          LX7    X4                                                     S004  48
          SA6    A7+B1                                                  S004  49
          SA7    A6+B1                                                  S004  50
  
*         SCAN OFF PARAMETERS.
  
          SA1    P1TEMP      CHECK ON LOCATION TYPE 
          ZR     X1,MCL10 
          MANAGE MARGS,1     GET ROOM FOR LOCATION SYMBOL 
          SB7    X3-1 
          SA3    LOCSYM 
          MX0    6
          SB6    B0 
          MI     X3,MCL1A    IF LOCATION SYMBOL NON-EMPTY 
          ZR     X3,MCL1
 MCL1A    BX4    X3*X0
          LX3    6
          SB6    B6-1        COUNT CHARACTERS 
          ZR     X4,MCL1A 
          LX3    54 
          SB6    11+B6
 MCL1     BX6    X3 
          SX1    B7          SETUP ARGUMENT DESCRIPTOR WORD 
          SA6    X2+B7
          PX1    B6 
          ADDWORD MARDIS
          SA1    P1TEMPA     REDUCE PARAMETER COUNT 
          SX6    X1-1 
          SA6    A1 
          EQ     MCL15
 MCL10    SX1    B0          PROCESS LOCATION FIELD 
          SA2    LOCSYM 
 +        ZR     X2,*+1      AVOID PRLOC IF NO LOCSYM 
          RJ     YPRLOC 
          SA2    P1TEMPC     MACRO FLAG 
          ZR     X2,MCLO     IF OPDEF EXPANSION REQUIRED
 MCL15    SA1    OPTYPE 
          LX1    -32
          NG     X1,MCLE     IF MACROE EXPANSION
 MCL20    SA1    P1TEMPA     GET PARAMETER COUNT
          ZR     X1,MCL60    JUMP IF DONE 
          SA2    A1+B1
          IX0    X2-X1
          NG     X0,MCL30    JUMP IF THIS IS A NON-LOCAL PARAMETER
          SA1    INVENT      AUGMENT INVENTION NUMBER 
          SB7    B0 
          MX0    54 
          SX3    B1 
          IX1    X3+X1
 MCL21    AX4    X1,B7
          BX3    -X0*X4 
          SX4    1R9+1
          IX3    X4-X3
          NZ     X3,MCL22 
          SX3    66B         PROPOGATE OVERFLOW 
          LX4    X3,B7
          IX1    X4+X1
          SB7    B7+6 
          EQ     MCL21
 MCL22    BX6    X1 
          SA6    A1 
          LX1    12 
          ADDWORD MARGS 
          SA1    L.MARGS     SETUP ARGUMENT DESCRIPTOR WORD 
          SB7    8           FOR LOCAL SYMBOL 
          SX2    X1-1 
          PX1    X2,B7
 MCL23    ADDWORD MARDIS     STORE DESCRIPTOR WORD
          SA1    P1TEMPA
          SX6    X1-1 
          SA6    A1 
          EQ     MCL20
 MCL30    RJ     PMA         PROCESS MACRO ARGUMENTS
          EQ     MCL23
 MCLE     SPACE  4
**        MCLE - MACROE EXPANSION.
*         ENTRY  (P1TEMPA) = TOTAL PARAMETER COUNT. 
*                (P1TEMPB) = LOCAL PARAMETER COUNT. 
*         USES   (P1TEMPD) = FORMAL PARAMETER COUNT.
*                (P1TEMPE) = CURRENT KEYWORD INDEX. 
  
  
 MCLE     SA1    P1TEMPA     PRESET ALL KEYWORD ARGUMENTS TO NULLS
          SA2    A1+B1
          IX6    X1-X2
          SA6    P1TEMPD
          MANAGE MARDIS,X6
          SA1    P1TEMPD
          IX3    X2+X3
          IX2    X3-X1
          SX1    B0 
          PX1    B0 
          RJ     PRESET 
  
*         ISOLATE FORMAL PARAMETER. 
  
 MCLE3    MX6    0           ISOLATE FORMAL PARAMETER 
          SA6    P1TEMPA
 MCLE4    RJ     PMACF
          ZR     X6,MCLE9A   IF EMPTY OR INVALID OR DUPLICATE 
          SA1    COLUMN 
          SA2    X1+CARD-1-1
          SX1    X2-1R= 
          NZ     X1,MCLE9    IF SEPARATOR NOT = 
          SA2    P1TEMPD     LOOKUP IN KEYWORD LIST 
          SA1    RELVEC+64
          SB7    X2+B1
          SX7    -B7
 MCLE5    BX3    X1-X6
          SX7    X7+1 
          SA1    A1+B1
          PL     X7,MCLE9    IF KEYWORD NOT FOUND 
          NZ     X3,MCLE5    LOOP 
          SA7    P1TEMPE
          RJ     PMA         PACK MACRO ARGUMENT
          BX6    X1 
          SA1    O.MARDIS 
          SA2    L.MARDIS 
          SA3    P1TEMPE
          IX4    X1+X2
          SB7    X3 
          SA6    X4+B7       STORE POINTER TO VALUE 
          SA1    CHAR        CHECK FOR END OF FIELD 
          SB7    X1-1R
          NZ     B7,MCLE4    LOOP TO END OF CALL
 MCLE8    SA1    P1TEMPB     SET COUNT TO LOCAL PARAMETERS
          BX6    X1 
          SA6    A1-B1
          EQ     MCL20       EXIT 
  
*         BAD FORMAL PARAMETER NAME.
  
 MCLE9    SX6    B1          SET *4* ERROR
          SA6    W4ERR
          SA6    EFLG 
 MCLE9A   RJ     PMACE       SKIP VALUE 
          NZ     X7,MCLE4    IF NOT END OF CARD 
          EQ     MCLE8
 MCLO    SPACE  4 
**        MCLO - OPDEF EXPANSION. 
* 
*         ADDITIONAL TEMPORARY STORAGE USED BY OPDEF EXPANSIONS.
* 
*                OPADS+1     WORD INDEX FOR ADDRESS ACCUMULATION. 
*                OPADS+2     BIT POSITION AND CHAR COUNT FOR ADDRESS. 
*                OPADS+3     COLUMN RESET WITH OPERATOR.
*                OPADS+4     COLUMN RESET WITHOUT OPERATOR. 
  
  
 MCLO     SA1    COL         RESET TO OP-CODE REGISTER
          SA2    P1TEMPD     AND PREPARE SYNTAX WORD
          SX6    X1+B1
          BX7    X2 
          SA6    COLUMN 
          LX7    24 
          SX6    B0          CLEAR VARIABLE FIELD FLAG
          SA7    A2 
          SA6    MCLOA
          RJ     GETCH
          SB7    X1-2 
          SB6    X1-1RX 
          ZR     B6,MCLO1    IF X 
          LT     B7,B1,MCLO1 IF *A* OR *B*
          RJ     GETCH
          EQ     MCLO2
  
 MCLO1    RJ     MCLOR       PACK REGISTER
 MCLO2    SB7    X1-1R, 
          ZR     B7,MCLO2A
  
*         ENTRY ON NEW FIELD. 
  
          SA1    MCLOA
          SA2    COL+1
          NZ     X1,MCLO9    IF END OF VARIABLE FIELD 
          BX6    X2 
          SA6    A1          END OF OPCODE FIELD, RESET SCAN
          SA6    COLUMN      TO BEGINNING OF VARIABLE FIELD 
  
*         ENTRY ON NEW SUBFIELD.
  
 MCLO2A   SX6    B0          PREPARE COUNTERS FOR ADDRESSES 
          SA6    OPADS+1
          PX7    X6,B0
          SA7    A6+B1
          RJ     GETCH
 MCLO3    SA1    CHAR 
          SB7    X1-1R
          ZR     B7,MCLO8    IF END OF ADDRESS FIELD
          EQ     B7,B1,MCLO8
          SA2    COLUMN 
          BX6    X2 
          SX3    360000B     MASK FOR  +-*/&
          SB7    X1+6 
          PX3    X3 
          SA6    OPADS+3     SAVE COLUMN
          LX3    X3,B7
 +        PL     X3,*+1 
          RJ     GETCH
          SA2    COLUMN 
          BX6    X2 
          SA6    OPADS+4
          RJ     YEVITEM     EVALUATE ITEM
          SA1    ELREG
          ZR     X1,MCLO6    IF NOT REGISTER
          SA2    OPADS+4     GO BACK TO START OF REGISTER 
          SX6    X2-1 
          SA6    COLUMN 
          RJ     GETCH
          RJ     MCLOR       PACK REGISTER
          EQ     MCLO3
 MCLO6    SA2    COLUMN 
          SA3    OPADS+3     GO BACK TO OPERATOR PREC. ELEMENT
          SX6    X3-1 
          SB2    X2 
          SA6    A2 
 MCLO6A   RJ     GETCH
          SA2    COLUMN 
          SB3    X2 
          EQ     B2,B3,MCLO3 IF AT END OF ELEMENT 
          SA2    OPADS+1     ADD CHARACTER TO ADDRESS 
          SA3    A2+B1
          UX7,B7 X3 
          SA4    RELVEC-1+X2
          ZR     B7,MCLO7    IF AT END OF WORD
          SB7    B7-6 
          SX7    X3+B1       COUNT CHARACTERS 
          LX1    B7 
          PX7    B7 
          BX6    X4+X1       INSERT NEW CHARACTER 
          SA7    A3 
          SA6    A4 
          EQ     MCLO6A      LOOP 
 MCLO7    SB7    60-6 
          SX7    X2+B1       ADVANCE WORD INDEX 
          LX6    X1,B7
          SA7    A2 
          SX3    X3+B1       COUNT CHARACTERS 
          SA6    RELVEC-1+X7
          PX7    X3,B7
          SA7    A3 
          EQ     MCLO6A 
  
*         MOVE ADDRESS. 
  
 MCLO8    SA5    P1TEMPD     CHECK IF THIS SUBFIELD HAS AN ADDR 
          LX5    7
          LX6    X5,B1
          SA6    A5 
          PL     X5,MCLO8A
          SA1    L.MARGS
          SA2    OPADS+2     SETUP ARGUMENT DESCRIPTOR WORD 
          SB7    X2 
          PX1    B7 
          ADDWORD MARDIS
          SA1    OPADS+1
          MANAGE MARGS,X1 
          IX2    X3+X2
          SA1    OPADS+1
          IX3    X2-X1
          SX2    RELVEC 
          RJ     MOVE 
 MCLO8A   SA1    CHAR        TEST FOR END OF SUBFIELD ONLY
          EQ     MCLO2
  
*         END OF VARIABLE FIELD.
  
 MCLO9    SX6    B0          CLEAR OUT OPCODE ERRORS
          SA6    AERR 
          SA6    UERR 
          SA2    P1TEMPB
          BX6    X2          CHECK IF THERE ARE ANY LOCALS TO 
          SA6    A2-B1       GENERATE 
          NZ     X2,MCL20 
  
*         END OF EXPANSION. 
  
 MCL60    RJ     CRL         CHECK RECURSION LIMIT                      S004  52
          SA1    P1TEMP                                                 S004  53
          MX6    2           CREATE OPTYPE FOR INTERMEDIATE 
          LX1    57 
          BX6    X1+X6
          SA2    OPTYPE 
          BX7    X2 
          SA6    A2 
          SA7    A1 
          SA1    LOCSYM 
          ZR     X1,MCL61    IF NO LOCATION SYMBOL
          RJ     WINTER 
          EQ     MCL62
 MCL61    RJ     CWI
 MCL62    SA1    MCLA        RECALL PUSHDOWN PARAMETERS                 S004  55
          SX2    B1                                                     S004  56
          SA3    A1+B1                                                  S004  57
          SA5    A3+B1                                                  S004  58
          SA4    A5+B1                                                  S004  59
          RJ     PUSHDOWN    ADD STACK ENTRY                            S004  60
          SA2    P1TEMP 
          SX6    B1                                                     S004  62
          LX2    2
          PL     X2,MCL63    IF SYSTEM MACRO
          SA6    MACFLG 
          EQ     CTL100 
 MCL63    SA6    SYSFLG 
          EQ     CTL100      AND BACK FOR GENERAL PROCESSING
  
 MCLA     BSS    4           PUSHDOWN PARAMETERS                        S004  64
 MCLOA    DATA   0           ZERO IN OPCODE FIELD, NZ IN VARIABLE FIELD 
 MCLS     SPACE  4
**        MCLS - STORE NEXT MACRO CHARACTER.
  
  
 MCLS     PS                 RETURN EXIT
          LX7    6           ACCUMULATE CHARACTER 
          SB6    B6-B1
          SB3    B3+B1       BUMP CHARACTER COUNT 
          BX7    X1+X7
          NZ     B6,MCLS
          SA7    A7+B1
          SB6    10 
          MX7    0
          EQ     MCLS 
 MCLOR    SPACE  4
**        MCLOR - PACK REGISTER.
*         USES   P1TEMPC. 
  
  
 MCLOR    PS                 RETURN EXIT
          RJ     GETCH
          SB2    X1-1R. 
 +        NZ     B2,*+1 
          RJ     GETCH
          RJ     SCITEM 
          MX7    6
          SB3    B0 
          ZR     X6,MCLOR2
 MCLOR1   BX4    X7*X6       LEFT JUSTIFY AND COUNT CHARACTERS
          LX6    6
          SB3    B3-1 
          ZR     X4,MCLOR1
          LX6    -6 
          SB3    11+B3
 MCLOR2   SA2    L.MARGS     SETUP ARGUMENT DESCRIPTOR WORD 
          BX1    X6 
          PX6    X2,B3
          SA6    P1TEMPC
          ADDWORD MARGS 
          SA1    P1TEMPC
          ADDWORD MARDIS
          SA1    CHAR 
          EQ     MCLOR
 PCARD    SPACE  4
**        PCARD - PACK CARD INTO TABLE. 
*         ENTRY  (X1) = TABLE NAME. 
  
  
 PCARD    PS                 RETURN EXIT
          BX6    X1          SAVE TALLE ID
          SA6    PCARDT 
          RJ     SQUEEZE     SQUEEZE CARD 
          SA1    SQLGN       AUGMENT TABLE
          SA2    PCARDT      BY AMOUNT OF SQUEEZED IMAGE
          MANAGE X2,X1
          SA1    SQLGN       LENGTH OF COMPRESSED IMAGE 
          IX3    X2+X3
          IX3    X3-X1
          SX2    SQIMAGE
          RJ     MOVE        MOVE IMAGE FROM SQIMAGE TO TABLE 
          EQ     PCARD
  
 PCARDT   DATA   0           TEMPORARY STORAGE
 PDC      SPACE  4
**        PDC - PROCESS DEFINITION CARD.
*         FORMAL PARAMETER SEPARATORS ARE +-*/()$= ,."_ 
*         ENTRY  (SQIMAGE) = PACKED IMAGE OF CARD.
*                (P1TEMPA) = TOTAL PARAMETER COUNT. 
*                (RELVEC) = PARAMETER NAMES.
*         EXIT   (CARD) = STRING BUFFER WITH PARAMETER MARKS. 
  
  
 PDC      PS                 RETURN EXIT
          IFEQ   IP.CSET,IP.C64.1 
          SA3    =607776000000000001B DELIMITER MASK
          ELSE
          SA3    =707776000000000001B 
          ENDIF 
          SB6    9
          SX4    B6 
          SA1    SQIMAGE     PACKED IMAGE 
          MX0    -6 
          SB5    -71*NCARDS+3 LIMITING COLUMN COUNT 
          SA0    STYPE+71*NCARDS-3
  
*         ENTRY FOR NEW POTENTIAL SUBSTITUTABLE ARGUMENT. 
  
 PDC1     SB4    B5          RESET ADDRESS IN CASE IF ARGUMENT
          MX5    0
  
*         ENTRY FOR NEXT CHARACTER. 
  
 PDC2     LX1    6
          BX6    -X0*X1      ISOLATE NEW CHARACTER
          SB7    X6 
          AX7    X3,B7
 +        GE     B6,B1,*+1   IF STILL CHARACTERS IN WORD
          SB6    X4+B1
          SA1    A1+B1       FETCH NEW WORD 
 +        LX7    59 
          SB6    B6-B1
          NG     X7,PDC3     IF THIS IS A DELIMITER 
 +        PL     B5,*+1      IF ROOM REMAINS IN CARD
          SA6    A0+B5       STORE CHARACTER
          SB5    B5+B1       UP COLUMN COUNT
          LX5    6
          BX5    X6+X5       OR INTO POTENTIAL PARAMETER NAME 
          EQ     PDC2        AND LOOP 
  
*         DELIMITER FOUND.
  
 PDC3     SA2    P1TEMPA     TOTAL PARAMETER COUNT
          SB2    X2-1 
          ZR     X2,PDC5     IF NOT PARAMETERS
          SA2    RELVEC 
 PDC4     BX7    X2-X5
          SB2    B2-B1
          SA2    A2+B1
          ZR     X7,PDC6     IF PARAMETER FOUND 
          PL     B2,PDC4
 PDC5     ZR     B7,PDC7     PROCESS DELIMITER... IF BLANK MARK 
          PL     B5,PDC1     IF CARD EXHAUSTED
          SA6    A0+B5       STORE DELIMITER
          SB5    B5+B1
          EQ     PDC1 
  
*         PARAMETER FOUND.
  
 PDC6     BX7    -X0         GET A 77 
          SB5    B4+2        UPDATE COLUMN NO 
          PL     B5,PDC1     IF OUT OF RANGE
          SA7    A0+B4       STORE 77 (PARAMETER MARK)
          SX7    A2-RELVEC   STORE PARAMETER NUMBER 
          SA7    A7+B1
          EQ     PDC5        GO PROCESS DELIMITER 
  
*         00 CHARACTER. 
  
 PDC7     LX1    6           FETCH NEXT CHARACTER 
          BX6    -X0*X1 
          SB7    X6 
 +        GE     B6,B1,*+1
          SB6    X4+B1
          SA1    A1+B1
 +        SB6    B6-B1
          BX6    X6-X6
          ZR     B7,PDC8     IF END OF CARD 
          EQ     B7,B1,PDC5  IF 0001 (COLON), GO STORE 00 
          SX6    1R          STORE BLANKS OUT TO END OF CARD
          SA6    A0+B5
          SB2    B5+B7
          SB2    B2+B1
          PL     B2,PDC1     IF OUT OF BOUNDS 
 +        SB7    B7-B1
          SA6    A6+B1
          NZ     B7,* 
          SB5    B2 
          EQ     PDC1 
  
*         END OF CARD.
  
 PDC8     SX6    1R          BLANK OUT REMAINDER OF CARD
          SA1    LASTCOL
          SA6    A0+B5
          SX7    A6-STYPE-1 
          SB6    X1 
 +        NZ     X7,*+1      IF NOT ALL BLANKS
          SX7    B1 
          SA7    LASTCOL     UPDATE LASTCOL 
          SB7    X7 
          MX7    0
 +        SB7    B7+B1
          SA6    A6+B1
          LT     B7,B6,*
          SA7    SQLGN       PERMIT REPACKING 
          EQ     PDC         RETURN 
 PEC      SPACE  4
**        PEC - PROCESS END CARD. 
*         ENTRY  (X1) = NAME OF ENDX CARD.
*                (P1TEMPE) = BRACKET NAME.
*         EXIT   (P1TEMPD) = 1 IF ENDX CARD FOUND.
  
  
 PEC      PS                 RETURN EXIT
          BX6    X1 
          SA6    PECA 
          MX6    0
          SA6    P1TEMPD     CLEAR ENDM FLAG
 PEC1     RJ     SQUEEZE     WRITE DEFINITION CARD
          SA2    IOP
          SX0    3REND
          IX0    X2-X0
          ZR     X0,PEC5     IF *END* CARD
          RJ     CWI
          SA1    STYPE
          SB7    X1-1R* 
          ZR     B7,PEC4     IF COMMENTS CARD 
          SA2    IOP
          SA1    PECA 
          IX0    X2-X1
          SA1    LOCSYM 
          NZ     X0,PEC      IF NOT ENDX CARD 
          SA2    P1TEMPE
          BX0    X2-X1
          ZR     X1,PEC2
          NZ     X0,PEC 
 PEC2     SA1    CARD        CLEAR LOCATION FIELD 
          SX6    1R 
          SX7    B1 
          SA6    A1          CLEAR COLUMN 1 
          SA7    P1TEMPD
 PEC3     SA1    A1+B1
          BX7    X1-X6
          SA6    A6+B1
          NZ     X7,PEC3
          SA7    SQLGN       CLEAR COMPRESSION INDICATOR
          RJ     SQUEEZE     REPACK CARD WITH BLANKED LOCSYM
          EQ     PEC         RETURN 
  
*         SKIP COMMENT CARD.
  
 PEC4     RJ     INPUT1 
          RJ     SETUP
          EQ     PEC1        LOOP 
  
*         END CARD. 
  
 PEC5     SA1    IOP         *END*
          RJ     TLUOP       MAKE SURE OPTYPE IS SET CORRECTLY
          EQ     END
 PECA     DATA   0           NAME OF ENDX CARD
 PMA      SPACE  4
**        PMA - PROCESS MACRO ARGUMENTS.
*         ENTRY  (CARD) = ARGUMENTS SEPARATED BY *,*. 
*         EXIT   (MARGS) = PACKED ARGUMENT. 
*                (X1) = ARGUMENT DESCRIPTOR WORD FOR MARDIS TABLE.
*         USES   P1TEMPC. 
*         CALLS  MCLS.
  
  
 PMA      PS                 RETURN EXIT
          SB6    10 
          SA7    RELVEC+128 
          SB2    B0          PREPARE TO STORE CHARACTER STRINGS 
          SB3    B0 
          SX7    B0 
          SA1    CHAR 
          SB7    X1-1R( 
          ZR     B7,PMA5     IF OPEN PAREN
 PMA1     SB7    X1-1R
          ZR     B7,PMA7
          EQ     B7,B1,PMA6 
          RJ     MCLS        STORE CHARACTER
 PMA2     RJ     GETCH       GET NEXT ONE 
          EQ     PMA1 
 PMA3     SB7    B7+B7
          SX3    B1-B7
          SB2    B2+X3
 PMA4     NG     B2,PMA2     IF OUT OF BRACKETS 
          RJ     MCLS 
 PMA5     RJ     GETCH
          SB7    X1-1R( 
          ZR     B7,PMA3     IF OPEN PAREN
          EQ     B7,B1,PMA3  IF CLOSE PREN
          RJ     MCLS        STORE CHARACTER
          PL     X2,PMA5     IF STILL WITHIN RANGE OF CARD
 PMA6     RJ     GETCH
 PMA7     SB7    B6-10
          ZR     B7,PMA8     IF NO PARTIAL WORD 
          SB7    B6+B6
          SB6    B6+B7
          SB7    B6+B6       LEFT JUSTIFY CHARACTERS IN LAST WORD 
          LX7    B7 
          SA7    A7+B1
 PMA8     SX1    A7-RELVEC-128  WORD COUNT OF ARGUMENT
          PX6    X1,B3
          SA6    P1TEMPC
          MANAGE MARGS,X1 
          SA1    P1TEMPC     SIZE OF PARAMETER
          UX1,B3
          IX4    X3-X1
          PX6    X4,B3
          IX3    X2+X4
          SX2    RELVEC+129 
          SA6    A1 
          RJ     MOVE 
          SA1    P1TEMPC     (X1) = DESCRIPTOR WORD 
          EQ     PMA         RETURN 
 PMACE    SPACE  4
**        PMACE - SKIP ARGUMENT VALUE.
*         CALLED BY *ECHO* AND *MCLE* AFTER AN EMPTY, INVALID, OR 
*         DUPLICATE FORMAL PARAMETER NAME IS SCANNED.  SKIPS
*         TO END OF ARGUMENT VALUE. 
*         EXIT   (X7) = 0 IF END OF CARD. 
  
  
 PMACEX   SB7    X1-1R
          ZR     B7,PMACE    IF COMMA FOLLOWED BY BLANK 
  
 PMACE0   SX7    A1-CARD+1
          BX6    X1 
          SA7    COLUMN      STORE UPDATED COLUMN POINTER 
          SA6    CHAR 
  
 PMACE    PS                 RETURN EXIT
          SA4    COLUMN 
          SA1    CARD-2+X4   GET SEPARATOR FOLLOWING NAME 
          MX7    0
          SB5    -1R
          SB6    B0 
          SB7    X1-1R, 
          SA1    A1+B1
          ZR     B7,PMACEX   IF COMMA 
          SB7    X1-1R(      LOOK AT CHARACTER THAT FOLLOWS SEPARATOR 
          NZ     B7,PMACE1   IF NOT LEFT PAREN
          SA2    LASTCOL
          SA1    A1+B1
          IX2    X4-X2
          EQ     PMACE3 
  
 PMACE1   SB7    X1+B5
          SA1    A1+B1
          ZR     B7,PMACE    IF BLANK 
          NE     B7,B1,PMACE1  IF NOT COMMA 
          EQ     PMACE0      RETURN 
  
 PMACE2   SB7    B7+B7
          SX3    B1-B7
          SB6    B6+X3       UPDATE PAREN LEVEL 
          SA1    A1+B1
          MI     B6,PMACE1   IF OUT OF PARENS 
          SX2    X2+B1
 PMACE3   SB7    X1-1R( 
          ZR     B7,PMACE2   IF LEFT PAREN
          EQ     B7,B1,PMACE2  IF RIGHT PAREN 
          SX2    X2+B1
          SA1    A1+B1
          MI     X2,PMACE3   IF NOT END OF CARD 
          EQ     PMACE       RETURN 
 PMACF    SPACE  4
**        PMACF - ISOLATE FORMAL PARAMETER. 
*         THIS ROUTINE CATCHES ILLEGAL NAMES, DUPLICATED NAMES
*         AND ADDS TO THE LIST IN RELVEC. 
*         EXIT   (X6) = PARAMETER NAME. 
  
  
 PMACFER  SX6    B1          POST REJECTED FORMAL PARAMETER ERROR 
          SA6    W4ERR
          SA6    EFLG 
 PMACFN   MX6    0
  
 PMACF    PS                 RETURN EXIT
          SA1    COLUMN 
          MX3    49          ISOLATE THE FORMAL PARAMETER NAME
          BX2    -X3
          SA1    X1+CARD-1
          LX2    12 
          BX6    X6-X6
          SB6    X1-1R0 
          SB5    X1-1R9-1 
          EQ     PMACF1 
 PMACF1A  LX6    6
          BX6    X1+X6
          SA1    A1+B1
 PMACF1   SB7    X1 
          LX3    X2,B7
          PL     X3,PMACF1A 
          SB7    B7-1R
 +        ZR     B7,*+1 
          SA1    A1+B1       THROW AWAY NAME TERMINATOR 
          SX7    A1-CARD+1
          SA7    COLUMN 
          BX7    X1 
          SA7    CHAR 
          ZR     X6,PMACFN
 +        NG     B6,*+1 
          NG     B5,PMACFER  IF FIRST CHARACTER OF NAME IS 0-9
          SA2    P1TEMPA     FETCH PARAMETER COUNT
          SA3    RELVEC      AND COMPARE WITH EXISTING PARAMETERS 
          ZR     X2,PMACF3
          SB7    X2-1 
 PMACF2   BX4    X3-X6
          SA3    A3+B1
          SB7    B7-B1
          ZR     X4,PMACFER  IF DUPLICATED NAME 
          PL     B7,PMACF2
 PMACF3   SA4    =0RENDM
          SX0    3REND       CHECK FOR ILLEGAL NAME 
          SA3    =0RLOCAL 
          IX0    X6-X0
          BX3    X6-X3
          ZR     X0,PMACFER  IF PARAMETER NAME IS END 
          ZR     X3,PMACFER  IF PARAMETER NAME IS LOCAL 
          SX0    3RIRP
          BX4    X6-X4
          IX0    X6-X0
          MX3    12 
          BX3    X6*X3
          ZR     X0,PMACFER  IF IRP 
          ZR     X4,PMACFER  IF PARAMETER NAME IS ENDM
          NZ     X3,PMACFER  IF PARAMETER NAME IS OVER 8 CHARS LONG 
          SB7    X2-63
          PL     B7,PMACFF   IF PARAMETER COUNT WILL EXCEED 63
          SX7    X2+B1
          SA6    RELVEC+63+B7 STORE FORMAL PARAMETER NAME 
          SA7    A2 
          EQ     PMACF
  
 PMACFF   SX6    B1          POST OVERFLOW IF MORE THAN 
          SA6    FERR        63 FORMAL/LOCAL PARAMETERS 
          SA6    EFLG 
          EQ     PMACFN 
 PMACRO   SPACE  4
**        PMACRO - PROCESS MACRO DEFINITION (OPDEF ALSO). 
*         ENTRY  (X0) = 0 IF MACRO. 
*                (X0) < 0 IF OPDEF. 
*                (X0) = 20000 IF MACROE.
*         SCRATCH CELL USE EXPLAINED HERE...
* 
*         P1TEMP   MACRO NAME.
*         P1TEMPA  PARAMETER COUNT. 
*         P1TEMPB  LOCAL PARAMETER COUNT. 
*         P1TEMPC  LOCATION ARGUMENT FLAG.
*         P1TEMPD  REQUIRED PARAMETER COUNT AND FLAG. 
*         P1TEMPE  BRACKET NAME.
*         OPADS    USED BY OPDEF TO RECORD FORMAT.
  
  
 PMACRO   PS                 RETURN EXIT
          SA1    LOCSYM      SET MACRO NAME AND BRACKET NAME
          BX6    X1 
          SA6    P1TEMP 
          MX7    0
          SA7    A6+B1       P1TEMPA     CLEAR PARAMETER COUNT
          SA7    A7+B1       P1TEMPB     LOCAL PARAMETER COUNT
          SA7    A7+B1       P1TEMPC
          SA7    A7+B1       P1TEMPD
          SA6    A7+B1       BRACKET TO P1TEMPE 
          SA7    PUSHUP      CLEAR PUSHUP FLAG
          PL     X0,PMAC9    IF MACRO OR MACROE 
  
*         OPDEF DEFINITIONS.
  
          SA1    CARD        SCAN OPERATION SYNTAX
          RJ     SOS
          ZR     X6,PMACER   IF SYNTAX ERROR
          EQ     PMAC10 
  
*         MACRO DEFINITION. 
  
 PMAC9    BX6    X0          MACROE FLAG
          SA6    P1TEMPC
          MX7    59 
          SA7    P1TEMPD     FP COUNT SET TO -1 
          NZ     X1,PMAC10   IF LOCSYM IS MACRO NAME
          SX7    X0+B1
          SA7    P1TEMPC
          RJ     SCLIST      GET MACRO NAME 
          SA1    CHAR 
          SA6    P1TEMP      AND SAVE IT
          SA6    P1TEMPE
          SB7    X1-1R
          ZR     B7,PMACL    IF NO MACRO NAME OR NO FIRST PARAMETER 
 PMAC10   RJ     PMACF       GET PARAMETER
          SA1    CHAR        CHECK FOR END OF FIELD 
          SB7    X1-1R
          NZ     B7,PMAC10   KEEP GOING UNTIL END OF FIELD
 PMAC21   SA1    P1TEMP 
          SX6    B1 
          SX0    3REND       CHECK FOR INVALID MACRO NAMES
          SA2    =0RLOCAL    THOSE BEING... 
          BX0    X1-X0       (BLANK)
          BX2    X1-X2       END
          ZR     X0,PMACL    LOCAL
          SX0    3RIRP
          BX0    X1-X0
          ZR     X1,PMACL 
          ZR     X2,PMACL 
          MX2    12 
          BX2    X2*X1
          ZR     X0,PMACL    IF IRP 
          NZ     X2,PMACL    IF MORE THAN 8 CHARACTERS
          RJ     TLUOP       LOOK UP MACRO NAME IN OP CODE TABLE
          SX7    B0          CLEAR OUT POSSIBLE OP-CODE ERROR 
          SA7    OERR 
          ZR     X6,PMAC30   IF NOT IN TABLE
          SA3    IFCDGP      CHECK FOR DUPLICATE MACRO DEFINITION 
          ZR     X3,PMAC22   IF ASSEMBLY MODE NOT YET KNOWN 
          NG     X6,PMAC22   OR OLD WAS PSEUDO OPERATION
          AX6    57 
          SA3    MACHINE
          SB7    X6 
          BX6    X6-X3
          GT     B7,B1,PMAC22 AGAIN, IF OLD WAS PSEUDO-OPERATION
          NZ     X6,PMAC30   OR FOR SAME MACHINE, 
 PMAC22   SX6    B1          POST DUPLICATION WARNING FLAG
          SA6    EFLG 
          SA6    W3ERR
 PMAC30   SA1    P1TEMPA     CHECK PARAMETER COUNT IF A FIXED 
          SA2    A1+B1       NUMBER WAS REQUIRED (OPDEF ONLY) 
          IX7    X1-X2
          SA3    P1TEMPD
          IX6    X7-X3
          AX3    60 
          BX5    -X3*X6 
          NZ     X5,PMACER1  WRONG NUMBER OF PARAMETERS 
 PMAC31   SX6    B1 
          SA6    TXTFLG 
          RJ     CWI         WRITE CARD 
          RJ     INPUT1      READ NEXT ONE
          NZ     X1,PMAC202  IF PUSHUP OCCURRED 
          RJ     SETUP
          SA2    STYPE
          SB7    X2-1R* 
          SX3    3REND
          ZR     B7,PMAC31   IF COMMENT S CARD
          SA4    IOP
          BX3    X3-X4
          ZR     X3,END      IF END OP
          SX3    X4-2R
          NZ     X3,PMAC310  IF OP-CODE 
          SA3    LOCSYM 
          ZR     X3,PMAC31   IF NO LOC FIELD
 PMAC310  SA3    =0RLOCAL 
          BX4    X3-X4
          NZ     X4,PMAC100  IF NOT LOCAL OP
 PMAC35   RJ     PMACF       GET LOCAL NAME 
          SA1    CHAR 
          SA2    P1TEMPB
          ZR     X6,PMAC36
          SX6    X2+B1
          SA6    A2          UP LOCAL COUNT 
 PMAC36   SB7    X1-1R
          ZR     B7,PMAC31   IF END OF FIELD
          EQ     PMAC35 
  
*         PROCESS MACRO DEFINITION CARDS. 
  
 PMAC100  SA1    P1TEMPA     TOTAL PARAMETER COUNT
          SA2    A1+B1       LOCAL PARAMETER COUNT
          SA3    A2+B1       LOCATION ARGUMENT, MACROE FLAGS
          SA4    L.MACDEF 
          LX5    X1,B1       FORM SECOND WORD OF OPTAB
          BX6    X5+X3       ENTRY AND SAVE IN P1TEMPB
          IX7    X1-X2
          LX2    25 
          SX0    B1 
          BX5    X2+X4
          LX6    18 
          BX2    X0*X3
          IX1    X7-X2       KEYWORD COUNT
          BX5    X6+X5
          MX4    3
          SX7    B0 
          BX6    X4+X5
          SA6    A2 
          LX3    59-13
          SA7    A3          CLEAR IRP SWITCH (P1TEMPC) 
          PL     X3,PMAC120  IF NOT MACROE
          LX1    18 
          BX6    X1+X2       KEYWORD COUNT, LOC ARG FLAG
          AX1    18 
          SA6    A3+B1       P1TEMPD
          MANAGE MACDEF,X1
          SA1    P1TEMPD     STORE KEYWORD NAMES
          IX4    X2+X3
          SX2    RELVEC+X1
          AX1    18 
          IX3    X4-X1
          RJ     MOVE 
 PMAC120  SA1    =0RENDM     PROCESS END CARD 
          RJ     PEC
          RJ     PDC         PROCESS DEFINITION CARD
          SA1    IOP
          SX0    3RIRP
          BX0    X1-X0
          ZR     X0,PMAC140  IF IRP 
          PCARD  MACDEF      PACK CARD INTO MACRO DEFINITIONS 
          SA1    P1TEMPD     CHECK IF THIS WAS ENDM CARD
          ZR     X1,PMAC190  NO 
 PMAC130  SA3    P1TEMPC                                                S028 581
          SX1    1LU+0001B                                              S028 582
          ZR     X3,PMAC132  IF NOT IN RANGE OF VALID IRP               S028 583
          MI     X3,PMAC132                                             S028 584
          LX1    42          PACK TERMINAL U-CARD                       S028 585
          ADDWORD MACDEF                                                S028 586
 PMAC132  SX1    1RT         PACK T-CARD                                S028 587
          MX7    0
          LX1    54 
          SA7    TXTFLG 
          ADDWORD MACDEF     ADD TERMINATOR TO MACRO DEFINITION 
          SA3    L.MACDEF    TRY TO SAVE MACRO DEFINITION TEXT IN LCM   S028 589
          SA2    P1TEMPB
          SX1    X2                                                     S028 591
          IX1    X3-X1       WORD COUNT OF TEXT                         S028 592
          BX5    X1 
  
 RM       IFNE   CP#RM,7
          RJ     ILF         INCREASE LCM FIELD LENGTH                  S028 593
          MI     X6,PMAC135  IF NO ROOM IN LCM                          S028 594
 RM       ELSE
          SA4    LCMPGM      CHECK SPACE BETWEEN MACROS AND SYMTAB
          SA2    O.SYMTAB 
          IX4    X4+X1       NEW LWA+1 OF MACRO TEXT
          IX6    X2-X4
          PL     X6,PMAC133  IF ENOUGH ROOM 
          SX0    X4+777B
          AX0    9           ROUND UP SPACE NEEDED
          LX0    9
          IX1    X0-X2
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,ILC      IF NO ROOM IN LCM
          SA2    O.SYMTAB 
          SA1    L.SYMTAB 
          BX6    X0          SET NEW SYMBOL TABLE FWA 
          LX3    X0 
          SA6    A2 
          RJ     MVL         MOVE SYMBOL TABLE UP 
 PMAC133  BSS    0
 RM       ENDIF 
  
          SA2    P1TEMPB     CHANGE OPTAB ENTRY                         S028 595
          SX0    B1                                                     S028 596
          LX0    37          SET LCM BIT                                S028 598
          SX7    X2                                                     S028 599
          IX4    X2-X7                                                  S028 600
          SA3    O.MACDEF                                               S028 601
          BX4    X4+X0                                                  S028 602
          SA1    LCMPGM      LCM FWA OF TEXT
          IX2    X3+X7                                                  S028 604
          LX3    X5                                                     S028 605
          BX6    X4+X1                                                  S028 606
          SA6    A2                                                     S028 607
          IX6    X1+X3       UPDATE LWA+1 OF MACRO TEXT 
          SA6    A1 
          RJ     WLC         MOVE TEXT FROM MACDEF TO LCM               S028 608
          RJ     ASU         ACCUMULATE STORAGE USED                    S028 609
          SA7    L.MACDEF    DELETE TEXT FROM MACDEF                    S028 610
          BX1    X5                                                     S028 611
 PMAC135  SA2    P1TEMPB     ADD WORD COUNT TO OPTAB ENTRY              S028 612
          LX1    39                                                     S028 613
          BX2    X2+X1                                                  S028 614
          SA1    P1TEMP 
          RJ     ENTOP       ENTER OPCODE TABLE 
          SA1    PUSHUP                                                 S028 617
          NZ     X1,CTL105   IF PUSHUP OCCURRED                         S028 618
          EQ     PMACRO 
  
*         PROCESS IRP.
  
 PMAC140  SA1    P1TEMPC
          NZ     X1,PMAC146  IF SECOND IRP OF A PAIR
          PCARD  MACDEF      FIRST OF A PAIR, PACK INTO MACDEF
          RJ     SETUP
          SA1    COL+1       CHECK FOR VALID ADDRESS FIELD
          SA1    CARD+X1
          SB7    X1-77B 
          SA3    P1TEMPB
          NZ     B7,PMAC190  IF NOT A PARAMETER MARK
          AX3    25 
          SA2    A3-B1
          MX0    -6 
          BX4    -X0*X3 
          IX2    X2-X4       NUMBER OF SUBSTITUTABLE PARAMETERS 
          SA1    A1+B1
          NO
          IX2    X2-X1
          ZR     X1,PMAC142  IF PARAMETER NUMBER IS ZERO
          MI     X2,PMAC142  OR TOO LARGE 
          SA3    A1+B1
          BX6    X1 
          SB7    X3-1R
          NZ     B7,PMAC142  IF NEXT CHARACTER IS NOT BLANK 
          SX1    1RU*100B    NO ERRORS
          SA6    P1TEMPC     SET IRP SWITCH 
          BX1    X1+X6
          LX1    48          PACK U-CARD WITH PARAMETER 
          ADDWORD MACDEF     NUMBER IN COLUMN 1 
          EQ     PMAC190
 PMAC142  SX6    B1          BAD IRP CARD 
          SX7    -B1         (P1TEMPC) = -1 
          SA6    AERR        SET ADDRESS ERROR
          SA7    P1TEMPC
          SA6    EFLG 
          RJ     WINTER      WRITE CARD AGAIN 
          EQ     PMAC190
 PMAC146  SX6    B0          SECOND IRP OF A PAIR 
          SA6    A1          CLEAR IRP SWITCH 
          MI     X1,PMAC148  IF ERRORS IN FIRST IRP 
          SX1    1LU+0001B   PACK U-CARD WITH COLON IN COLUMN 1 
          LX1    42 
          ADDWORD MACDEF
 PMAC148  PCARD  MACDEF      PACK TERMINAL IRP INTO MACDEF
  
*         CONTINUE TO NEXT CARD.
  
 PMAC190  RJ     INPUT1 
          NZ     X1,PMAC200  IF PUSHUP OCCURRED 
          RJ     SETUP
          EQ     PMAC120
  
*         ENTRY ON ERRONEOUS MACRO DEFINITION.
  
 PMACL    SX6    B1          NOTE BAD MACRO NAME
          SA6    EFLG 
          SA6    LERR 
          EQ     PMACER      AND THROW DEFINITION AWAY
  
 PMACER1  SX6    B1          NOTE ARGUMENT COUNT ERROR
          SA6    EFLG 
          SA6    W5ERR
 PMACER   RJ     CWI
          SX6    B1 
          SA6    TXTFLG 
          RJ     INPUT1 
          NZ     X1,PMAC202  IF PUSHUP OCCURRED 
          RJ     SETUP
          SA1    IOP
          SA2    =0RENDM
          SX0    0REND
          SA3    LOCSYM 
          SA4    P1TEMPE
          IX0    X1-X0
          BX2    X1-X2
          ZR     X0,END 
          NZ     X2,PMACER
          IX4    X3-X4
 +        ZR     X3,*+1 
          NZ     X4,PMACER
          RJ     CWI
          MX6    0
          SA6    TXTFLG 
          EQ     PMACRO 
  
*         ENTRY ON ILLEGAL NESTING OF MACROS. 
  
 PMAC200  SX6    B1                                                     S028 621
          SA6    EERR        SET *E* ERROR                              S028 622
          SA6    EFLG                                                   S028 623
          EQ     PMAC130     GO ENTER OPCODE TABLE                      S028 624
 PMAC202  SX6    B1          SET *E* ERROR
          MX7    0
          SA6    EFLG 
          SA7    TXTFLG      CLEAR TEXT FLAG
          SA6    EERR 
          EQ     CTL105      GO PROCESS NEXT STATEMENT
 PRS      SPACE  4
**        PRS - PRESET CONSTANTS. 
  
  
 PRS      PS                 RETURN EXIT
          SX2    CLP1        CLEAR OUT PASS 1 CELLS 
          SX3    CLP1+LCLP1 
          RJ     CLS
          SA6    QUALMIC
          SA7    IFCNT
          SA6    PSIM2       RESET FOR NO PPU PREFETCH CHECKING 
          SA6    VWORD       RESET 180 PPU *CON* AND *VFD* CONTROL
          SA6    VALID       VALID = 0
          SX7    B1          SET PASS = 1 
          SA7    PASS 
          SA1    =9R
          SX7    2R 
          BX6    X1 
          SA7    TARGET      TARGET = TWO BLANKS
          SA6    HTYPE       HTYPE = NINE BLANKS
          SX6    B1+B1
          SA6    ORGCTR+1    SET RELOCATION OF * TO 2 
          SA6    LOCCTR+1 
          SX7    60 
          SX6    10 
          SA7    POSCTR      POSITION COUNTER = 60
          SA6    NCHARS      NUMBER OF CHARACTERS PER WORD
          SA7    LWORD       LENGTH OF COMPUTER WORD
          SA6    NBASE       NOMINAL NUMERIC BASE = 10
          SA6    MBASE       VFD BIT BASE = 10
          SX6    12 
          SA6    PPMEMSZ     PP MEMORY SIZE (ADDRESS FITS IN 12 BITS) 
          SX6    100B+1RD 
          LX6    -6 
          SA6    BASEMIC     SET BASE AND CODE MICROS = *D* 
          SA6    CODEMIC
          SX7    XRDV        SET XREF DEFAULT VALUE 
          SA7    XR 
          SB7    LLISTOPS/2  SET LIST OPTIONS 
          SA1    LISTOPS
 PRS2     UX6    X1 
          SB7    B7-B1
          SA6    A1+B1
          SA1    A6+B1
          NZ     B7,PRS2     LOOP 
          RJ     CPS         CLEAR PUSH-DOWN STACKS 
          SX6    BUCKET 
          SA6    MAXCORE     SET MAXCORE = BUCKET 
          SA1    LCMSYS 
          BX7    X1          RESET FWA OF PROGRAM MACRO TEXT
          SX6    X1-201B
          SA7    LCMPGM 
          SA7    LCMEND 
 +        MI     X6,*+1      IF NO SYSTEXT TABLES IN LCM
          SA7    ALCM        INITIALIZE LCM USED FOR THIS ASSEMBLY
  
 RM       IFNE   CP#RM,7
          SA1    L.SYMTAB 
          SX2    2*NSYMT
          IX1    X2-X1
          MANAGE SYMTAB,X1   ALLOCATE INITIAL SYMBOL TABLE
          IX3    X2+X3       CLEAR IT 
          RJ     CLS
 RM       ELSE
          SX6    X7+777B     ROUND UP TO LEAVE ROOM FOR MACROS
          AX6    9
          LX6    9
          SX7    2*NSYMT     SET SYMBOL TABLE POINTERS
          SA6    O.SYMTAB 
          SA7    L.SYMTAB 
          IX2    X6+X7       MAKE ROOM FOR SYMBOL TABLE 
          IX1    X2-X1
          RJ     ILF         INCREASE LCM FIELD LENGTH
          MI     X6,ILC      IF NO ROOM IN LCM
          SA2    O.SYMTAB    CLEAR INITIAL SYMBOL TABLE 
          SX3    X2+2*NSYMT 
          RJ     CLL
 RM       ENDIF 
  
          DATE   DATE 
          CLOCK  TIME 
          JDATE  P1TEMPD
          SA1    LCMOPC 
          ZR     X1,PRS2A    IF OPCODE TABLE NOT IN LCM 
          AX1    30 
          MANAGE OPTAB,X1    ALLOCATE TABLE IN SCM
          SA1    LCMOPC 
          RJ     RLC         COPY TABLE TO SCM
 PRS2A    SA1    LCMMIC                                                 S028 626
          ZR     X1,PRS2C    IF SYSTEM MICROS NOT IN LCM
          AX1    30 
          MANAGE MICTAB,X1+B1 ALLOCATE TABLE IN SCM 
          SA1    LCMMIC 
          SX2    X2+B1       ALLOW SCRATCH WORD AT START OF TABLE 
          SX3    X3-1 
          RJ     RLC         COPY TABLE TO SCM
          EQ     PRS3 
 PRS2C    SA1    L.SYSMIC    STORE SYSTEM MICROS
          MANAGE MICTAB,X1+B1 
          SX1    X3-1 
          SX3    X2+B1
          SA2    O.SYSMIC 
          ZR     X1,PRS3     IF TABLE EMPTY 
          RJ     MOVE 
 PRS3     SA1    =0RDATE     STORE DATE AND TIME MICROS 
          SA4    DATE 
          BX6    X1 
          LX7    X4 
          SA6    LOCSYM 
          SA7    RELVEC 
          MX7    0
          SA7    A7+B1
          SX6    3
          RJ     EMT
          SA1    =0RTIME
          SA4    TIME 
          BX6    X1 
          LX7    X4 
          SA6    LOCSYM 
          SA7    RELVEC 
          SX6    3
          RJ     EMT
          SA4    P1TEMPD
          SA1    =0RJDATE 
          SX5    5
          LX4    30 
          BX6    X1 
          IX7    X4+X5
          SA6    LOCSYM 
          SA7    RELVEC 
          SX6    B1+B1
          RJ     EMT
          SA1    =0RMODLEVEL
          SA2    CP.MODL
          BX6    X1 
          MX0    6
          SA6    LOCSYM 
          ZR     X2,PRS4     IF NO *ML* ARGUMENT, USE JDATE 
          SX7    0
 +        BX3    -X0*X2      COUNT CHARACTERS 
          SX7    X7+1 
          AX0    6
          NZ     X3,*-1 
          BX7    X2+X7
          SA7    RELVEC 
 PRS4     SX6    B1+B1       DEFINE *MODLEVEL* MICRO
          RJ     EMT
          SA1    CP.PCOM
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA1    A2+B1
          SA2    =0RPCOMMENT
          SA6    RELVEC 
          SA7    A6+B1
          BX6    X1 
          LX7    X2 
          SA6    A7+B1
          SA7    LOCSYM 
          MX6    0
          SA6    A6+B1
          SX6    5
          RJ     EMT
          SA1    DATE        STORE DATE AND TIME IN PREFIX TABLE
          SA2    TIME 
          MX0    54 
          LX1    6
          LX2    6
          BX3    X0*X1
          BX4    X0*X2
          IX5    X1-X3
          BX6    X2-X4
          BX6    X3+X6
          IX7    X4+X5
          SA6    DPBA+2 
          SA7    A6+B1
          SA1    =8R'?000000 INITIALIZE INVENTED SYMBOLS
          SA2    RJY         INITIALIZE SCAN JUMP 
          LX6    X2 
          BX7    X1 
          SA6    SCANEV 
          SA7    INVENT 
          SX6    COMCOL 
          SA6    CCOL 
          SA1    =1H
          SX2    TITBUF+1 
          SX3    TITBUF+TITBUFL+1 
          RJ     PRESET 
          SX1    1R          CLEAR STRING BUFFER
          SX2    CARD 
          SX3    SEQ
          RJ     PRESET 
          SX2    SEQ
          SX3    SEQ+2*NCARDS 
          RJ     CLS
          RJ     RCD         RESTORE CHARACTER DATA 
          EQ     PRS         RETURN 
 PGO      SPACE  4
**        PGO - PURGE OPCODE ENTRY. 
*         ENTRY  (X1) = ENTRY NAME. 
  
  
 PGO2     MX7    0           CLEAR OPCODE ERROR 
          SA7    OERR 
  
 PGO      PS                 RETURN EXIT
          ZR     X1,PGO      RETURN IF NO OPCODE
          RJ     TLUOP
          ZR     X6,PGO2     IF NO MACRO
          SA1    A2-B1       FETCH LINK 
          MX0    12 
          SA5    O.OPTAB
          BX4    X0*X1
          ZR     X4,PGO1     IF NO LINK 
          LX4    13 
          IX5    X5+X4
          SX4    X5+2*NOPCT-2 
          SA3    X4          FETCH LINKED ENTRY 
          SA4    A3+B1
          SA6    A4          INTERCHANGE ENTRIES
          BX7    X1 
          SA7    A3 
          BX6    X3 
          LX7    X4 
          SA6    A1 
          SA7    A2 
          EQ     PGO2        EXIT 
 PGO1     SX6    A1          SET OPCODE INDEX 
          IX6    X6-X5
          SA6    P1TEMPA
          MANAGE OPTAB,2
          SA1    P1TEMPA
          IX1    X2+X1
          IX5    X2+X3
          SA1    X1          MOVE ENTRY TO END OF TABLE 
          SA2    A1+B1
          MX6    0
          SA6    A1 
          SA6    A2 
          BX6    X1 
          LX7    X2 
          SA6    X5-2 
          SA7    A6+B1
          EQ     PGO2        EXIT 
 PUSHDOWN SPACE  4
**        PUSHDOWN - PUSH DOWN RECURSION STACK. 
*         ENTRY  (X1) = BYTE POINTER. 
*                (X2) = TYPE OF STACK ENTRY.
*                (X3) = MARGS / RASTAB / LASTAB RESET PTR, OR DUP COUNT.S004  66
*                (X4) = NAME. 
*                (X5) = MARDIS OR DUPTAB RESET POINTER.                 S004  68
*         EXIT   TO CTL100 WITH STACK, TEXT TABLES, AND TXTFLG          S004  69
*                CLEARED, IF RECURSION LIMIT EXCEEDED.                  S004  70
  
  
 PUSHDOWN PS                 RETURN EXIT
          BX6    X1          STORE ENTRY PARAMETERS 
          LX7    X2 
          SA6    PUSHDT 
          SA7    A6+B1
          BX6    X3 
          LX7    X4 
          SA6    A7+B1
          SA7    A6+B1
          BX6    X5 
          SA6    A7+B1
          SA1    L.STACK                                                S004  72
          SB7    X1-4*"LIMRECUR"                                        S004  73
          PL     B7,PUD3     IF RECURSION LIMIT EXCEEDED                S004  74
          MANAGE STACK,4     GET 4 WORDS FOR THE STACK
          SX1    X3 
          SB3    X3-4 
          AX1    2           RECURSION LEVEL = L.STACK / 4
          RJ     CONDEC      CONVERT TO DECIMAL 
          SA3    PUSHDT      RECLAIM BYTE WORD
          SB2    -B2
          SX4    1R.-1R 
          SA2    O.STACK
          AX4    X4,B2
          SB2    54+B2
          MX7    42 
          IX6    X6+X4
          LX6    X6,B2
          BX7    X7*X6
          BX6    X7+X3                                                  S004  77
          SA6    X2+B3       STORE FIRST WORD OF STACK ENTRY            S004  78
          SB6    LFLG-1      PACK AWAY MODE INDICATORS
          SA5    SYSFLG 
          MX6    0                                                      S004  80
 PUSHDN1  LX6    1
          BX6    X6+X5
          SA5    A5+B1
          SB6    B6-B1
          PL     B6,PUSHDN1 
          LX6    18 
          SA3    A3+B1       STACK ENTRY TYPE                           S004  82
          SA5    L.MARGS
          SA4    L.MARDIS 
          SB7    X3                                                     S004  84
          NE     B7,B1,PUD4  IF NOT MACRO/OPDEF CALL                    S004  85
          SA5    A3+B1                                                  S004  86
          SA4    PUSHDT+4                                               S004  87
          MX7    0                                                      S004  88
          SA7    A5                                                     S004  89
          SA7    A4                                                     S004  90
 PUD4     BX6    X5+X6                                                  S004  91
          LX6    18 
          BX6    X4+X6
          LX3    56 
          BX6    X6+X3
          SA6    A6+B1       STORE SECOND WORD                          S004  94
          SA4    A3+B1       RECLAIM DUP COUNT
          SA3    A4+B1       RECLAIM NEST NAME
          SA5    A3+B1       RECLAIM DUP RESET QUANTITY 
          LX4    18 
          IX6    X5+X4
          SA6    A6+B1       STORE DUP CONTROL
          SX1    1R 
          MX0    12 
          BX7    -X0*X3 
 PUD2     LX7    6           POSITION AND FILL NAME 
          BX3    X0*X7
          IX7    X7+X1
          ZR     X3,PUD2
          AX7    6
          SA7    A6+B1       STORE NEST NAME
          EQ     PUSHDOWN    AND QUIT 
                                                                        S004  96
*         RECURSION LIMIT EXCEEDED.                                     S004  97
                                                                        S004  98
 PUD3     RJ     ASU         ACCUMULATE STORAGE USED                    S004  99
          MX6    0                                                      S004 100
          SX7    B0                                                     S004 101
          SA6    L.STACK     CLEAR ALL SOURCE PUSHDOWN TABLES           S004 102
          SA7    L.MARDIS                                               S004 103
          SA6    L.MARGS                                                S004 104
          SA7    L.DUPTAB                                               S004 105
          SA6    L.RASTAB                                               S004 106
          SA7    L.LASTAB                                               S004 107
          SA6    L.ECHTAB                                               S004 108
          SA7    TXTFLG      CLEAR TEXT FLAG                            S004 109
          JP     CTL100      GO READ NEXT SOURCE CARD                   S004 110
  
 PUSHDT   BSS    5           TEMPORARY STORAGE
 PUSHUP   SPACE  4
**        PUSHUP - PUSH UP RECURSION STACK. 
  
  
 PUSHUP   PS                 RETURN EXIT
          RJ     ASU         ACCUMULATE STORAGE USED
          SA5    L.STACK
          SA2    O.STACK
          SX6    X5-4 
          IX3    X6+X2
          SA2    X3+B1
          MX0    59 
          SA6    A5          RESET STACK SIZE 
          AX2    36 
          SB7    LFLG-1 
 PUSHUP1  BX6    -X0*X2      STORE MODE FLAGS 
          SA6    SYSFLG+B7
          SB7    B7-B1
          AX2    1
          PL     B7,PUSHUP1 
          AX2    20-LFLG
          SB7    X2 
          JP     *+B7 
  
 +        EQ     PUSHUP2     MACRO
 +        EQ     PUSHUP3     DUPTAB 
 +        EQ     PUSHUP4     RMT
 +        EQ     PUSHUP5     XTEXT
 +        SA3    A2+1        ECHO 
          AX3    18 
          SX6    X3 
          SA6    L.ECHTAB 
 PUSHUP2  SA2    A2 
          SX6    X2 
          AX2    18 
          SX7    X2 
          SA6    L.MARDIS 
          SA7    L.MARGS
          NE     B7,B1,PUSHUP  IF NOT A MACRO                           S028 628
          SA3    X3                                                     S028 629
          SA2    L.MACDEF                                               S028 630
          SA1    O.MACDEF                                               S028 631
          SB6    X3                                                     S028 632
          SB7    X2                                                     S028 633
          NE     B6,B7,PUSHUP  IF NOT AT END OF MACDEF TABLE            S028 634
          SB7    B7-B1                                                  S028 635
          SA3    X1+B7                                                  S028 636
          AX3    12          EXTRACT TEXT WORD COUNT FROM               S028 637
          SX1    X3          BITS 29-12 OF T-CARD WORD                  S028 638
          IX6    X2-X1                                                  S028 639
          SA6    A2          DELETE TEXT FROM MACDEF TABLE              S028 640
          EQ     PUSHUP 
 PUSHUP3  SA2    A2+1 
          SX6    X2 
          SA6    L.DUPTAB 
          EQ     PUSHUP 
 PUSHUP4  SA2    A2+1 
          AX2    18 
          SX6    X2 
          SA6    L.RASTAB 
          EQ     PUSHUP 
 PUSHUP5  SA2    A2+B1
          AX2    18 
          SX6    X2 
          SA6    L.LASTAB 
          SA2    XLEV        DECREASE NESTING LEVEL                     P036  60
          SX6    X2-1                                                   P036  61
 +        NZ     X6,*+1                                                 P036  62
          SA6    LIBFLG      CLEAR XTEXT FLAG                           P036  63
 +        SA6    A2                                                     P036  64
          EQ     PUSHUP 
 RCD      SPACE  4,8
**        RCD - RESTORE CHARACTER DATA. 
  
  
 RCD      PS                 RETURN EXIT
          SB7    64          RESET CODE OTHER 
          SA1    STCA 
          MX0    -6 
          MX3    -8 
          LX3    36 
 RCD1     BX2    -X0*X1 
          BX6    X3*X1
          SA1    A1+B1
          LX2    36 
          BX6    X6+X2
          SB7    B7-1 
          SA6    A1-B1
          NZ     B7,RCD1     LOOP 
          JP     RCD         RETURN 
  
 RM       IFEQ   CP#RM,0
  
 RIV      SPACE  4,10 
**        RIV - REDEFINE INSTRUCTIONS FOR MACHINE 8.
  
  
 RIV      PS     0           ENTRY/EXIT 
          RJ     MTD         MOVE TABLES DOWN 
          SA1    =0LAIDTEXT  SET UP *LDV* PARAMETER LIST
          BX6    X1 
          SA6    RIVA        42/NAME,18/0 
 RIV1A    SA1    O.ENDTAB 
          SA2    O.MEMORY 
          LX1    18 
          SX5    0101014B 
          LX5    39 
          BX6    X1+X5
          BX6    X6+X2
          SA6    A6+B1       6/L1,6/L2,2/N,3/0,1/U,1/V,5/0,18/LWA,18/FWA
          SX6    B0 
          SA6    RA.LDR 
          LOADREQ  RIVA 
  
 RIV2     RECALL
          SA4    RA.LDR 
          ZR     X4,RIV2
  
          SA1    RIVA 
          SX6    X1-9 
          NZ     X6,RIV2A    IF LOADED, CONTINUE
          SX1    0           ELSE ATTEMPT TO GET MORE FL
          RJ     RFL
          ZR     X3,ALC17    IF ALREADY AT MAX. FL. ABORT 
          EQ     RIV1A       ELSE TRY AGAIN 
  
 RIV2A    SA1    O.MEMORY 
          SA2    L.MEMORY 
          SA3    X1+B1       SSYMS LENGTH 
          SX3    X3+2 
          IX6    X1+X3
          IX7    X2-X3
          SA3    X6          SYSMIC LENGTH
          SX3    X3+1 
          IX6    X6+X3
          IX7    X7-X3
          SA6    A1 
          SA7    A2 
          SA1    X6          MACDEF LENGTH
          SX2    X1+B1
          SX3    A1 
          IX3    X2+X3
          SA2    X3          OPCODES LENGTH 
          IX6    X1+X2
          SX6    X6+2 
          SA6    L.MEMORY    REMAINING LENGTH 
          ZR     X1,RIV3     IF NO MACROS 
          SA2    L.MACDEF 
          BX7    X2 
          SA7    RIVB        SAVE MACDEF INDEX
          MANAGE  MACDEF,X1 
          SA4    O.MEMORY 
          SA1    X4          (X1) = WORD COUNT OF MACDEF
          SX2    X4+B1       (X2) = FWA OF MACROS 
          SA3    O.MACDEF 
          SA4    RIVB        MACDEF INDEX 
          IX3    X3+X4       (X3) = DESTIMATION ADDRESS 
          RJ     MOVE        MOVE TEXT INTO MACDEF
 RIV3     SA4    O.MEMORY 
          SA5    L.MEMORY 
          SA3    X4 
          SX3    X3+2        MACDEF LENGTH + 1
          IX7    X4+X3
          IX6    X5-X3
          SA7    A4 
          SA6    A5 
          SA1    X7-1        OPCODE LENGTH
          ZR     X1,RIV7     IF NO OPCODES
 RIV4     SA1    X7          GET OPCODE ENTRY 
          SA2    A1+B1
          MX7    3
          BX3    X2*X7       EXTRACT OPCODE TYPE
          LX3    3
          SX3    X3-6 
          SA4    RIVB        MACDEF INDEX 
          ZR     X3,RIV5     IF MACRO 
          MX4    0
          SX7    B1 
          LX7    47-0 
 RIV5     BX2    X2+X7       ADD PROGRAM DEFINED FLAG 
          IX2    X2+X4       ADD MACDEF INDEX IF PRESENT
          RJ     ENTOP       ENTER INTO OPCODE TABLE
          SA4    O.MEMORY 
          SA5    L.MEMORY 
          SX7    X4+2 
          SX6    X5-2 
          SA7    A4 
          SA6    A5 
          NZ     X6,RIV4     IF MORE OPCODES
 RIV7     MX6    0
          SA6    L.MEMORY 
          EQ     RIV         RETURN 
  
 RIVA     DATA   0           *LDV* PARAMETER LIST 
          DATA   0
 RIVB     DATA   0           MACDEF INDEX 
 RM       ENDIF 
  
 RNC      SPACE  4
**        RNC - READ NEXT CARD. 
*         ENTRY  (X2) = FET/FIT ADDRESS.
*                (A0) = FWA OF CARD BUFFER. 
*         EXIT   (X0) = FWA OF CARD IMAGE.
*                (X2) = FET/FIT ADDRESS.
*                (A0) = FWA OF CARD BUFFER. 
  
  
          SEG    PASS 1 SUBROUTINES (Q-Z).
  
 RM       IFEQ   CP#RM,0
  
 RNC1     SX0    A0          READ NORMAL CARD (AMODE = 0) 
          READC  X2,A0,16 
  
 RNCX     BX6    X1 
          SA6    EOFINP 
          ZR     X1,RNC      IF NOT EOR 
          SA3    INPRES      IF NO INPUT, LEAVE 
          ZR     X3,RNC 
          BX6    X0          ENSURE THAT *END* IS IN OPTAB
          SA6    RNCA        SAVE CONTENTS OF X0
          SX6    A0 
          SA6    A6+B1       SAVE CONTENTS OF A0
          BX6    X2 
          SA6    A6+B1       SAVE CONTENTS OF X2
          SX1    3REND       NOT DESTROYED BY TLUOP 
          RJ     TLUOP       SCAN OPTAB 
          NZ     X6,RNCX1    IF END IS IN OPTAB 
          SA2    ENDLOST     ELSE 
          RJ     ENTOP       MAKE ENTRY (X1)=END,(X2)=EQUIVALENT
 RNCX1    SA2    RNCA 
          BX0    X2          RESTORE CONTENTS OF X0 
          SA2    A2+B1
          SA0    X2          RESTORE CONTENTS OF A0 
          SA2    A2+B1       RESTORE CONTENTS OF X2 
          SA1    =C* //////// END CARD MISSING.*
          SA3    A1+B1
          BX6    X1 
          LX7    X3 
          SA1    A3+B1
          SA6    X0 
          SA7    X0+B1
          BX6    X1 
          SA6    A7+B1
  
 RNC      PS                 RETURN EXIT
          SA1    CP.IFORM 
          ZR     X1,RNC1     IF NOT COMPRESSED
          PL     X1,RNC2     IF NOT COMMON DECK 
          LX1    59 
          PL     X1,RNC5     IF UPDATE
          EQ     RNC6        MODIFY 
 RNC2     LX1    59 
          MI     X1,RNC4     IF MODIFY
  
*         CP.IFORM = +2, READ UPDATE COMPRESSED TEXT. 
  
          READW  X2,A0,2     GET SEQUENCE FIELD AND WORD COUNT
          SA3    A0+B1
          MX6    0
          SX0    A0+2 
          NZ     X1,RNCX     IF EOR 
          SB7    X3 
          SA6    X0+B7
          READW  X2,X0,B7    READ CARD IMAGE
          EQ     RNCX 
  
*         CP.IFORM = +1 OR +3, READ MODIFY COMPRESSED TEXT. 
  
 RNC4     READW  X2,A0+B1,1  GET SEQUENCE FIELD 
          SX0    A0+2 
          NZ     X1,RNCX     IF EOR 
          READC  X2,X0,12    READ CARD IMAGE
          EQ     RNCX 
  
*         CP.IFORM = -1, READ UPDATE COMMON DECK. 
  
 RNC5     READW  X2,A0,1     READ FIRST CHB WORD
          SA3    A0 
          SX0    A0+2 
          NZ     X1,RNCX     IF EOR 
          MI     X3,RNC5B    IF LAST CHB WORD 
 RNC5A    READW  X2,A0+B1,1  READ NEXT CHB WORD 
          SA3    A0+B1
          NZ     X1,RNCX     IF EOR 
          PL     X3,RNC5A    IF NOT LAST CHB WORD 
          SA3    A0 
 RNC5B    AX3    36 
          SX6    B0 
          SB7    X3          WORD COUNT 
          SA6    X0+B7
          READW  X2,X0,B7    READ CARD IMAGE
          SA3    A0 
          LX3    59-58
          MI     X3,RNCX     IF CARD IS ACTIVE
          ZR     X1,RNC5     IF NOT EOR 
          EQ     RNCX 
  
*         CP.IFORM = -2 OR -4, READ MODIFY COMMON DECK. 
  
 RNC6     READW  X2,A0,1     READ FIRST MHB WORD
          SA3    A0 
          SX0    A0+2 
          MX6    -16
          NZ     X1,RNCX     IF EOR 
          BX6    -X6*X3 
          ZR     X6,RNC6B    IF LAST MHB WORD 
 RNC6A    READW  X2,A0+B1,1  READ NEXT MHB WORD 
          SA3    A0+B1
          MX6    -16
          NZ     X1,RNCX     IF EOR 
          BX6    -X6*X3 
          NZ     X6,RNC6A    IF NOT LAST MHB WORD 
 RNC6B    READC  X2,X0,12    READ CARD IMAGE
          SA3    A0 
          MI     X3,RNCX     IF CARD IS ACTIVE
          ZR     X1,RNC6     IF NOT EOR 
          EQ     RNCX 
  
 RNCA     BSSZ   3           TEMPORARY STORAGE
 ENDLOST  VFD    3/3,12/0,9/N.,18//PASS1/END,18//PASS2/END
  
 RM       ELSE
  
 RNC1     SA6    A6+B1       SAVE FWA OF CARD IMAGE IN T6RM2
          NZ     X3,RNCX     IF NO DATA TO READ                         S028 642
          GET    X2,X6,160   READ NORMAL CARD (AMODE = 0) 
          SX2    A0          RESTORE FIT POINTER
          FETCH  X2,FP,X3 
          SX4    EOD
          BX6    X4*X3
  
 RNCX     SA5    T6RM1       RESTORE RECORD AREA POINTERS 
          SA1    A5+B1
          SA0    X5 
          BX0    X1 
          SA6    EOFINP 
          SA3    INPRES      IF NO INPUT,LEAVE
          ZR     X3,RNC 
          ZR     X6,RNC      IF NOT END OF DATA 
          BX6    X0          ENSURE THAT *END* IS IN OPTAB
          SA6    RNCA        SAVE CONTENTS OF X0
          SX6    A0 
          SA6    A6+B1       SAVE CONTENTS OF A0
          BX6    X2 
          SA6    A6+B1       SAVE CONTENTS OF X2
          SX1    3REND       NOT DESTROYED BY TLUOP 
          RJ     TLUOP       SCAN OPTAB 
          NZ     X6,RNCX1    IF END IS IN OPTAB 
          SA2    ENDLOST     ELSE 
          RJ     ENTOP       MAKE ENTRY (X1)=END,(X2)=EQUIVALENT
 RNCX1    SA2    RNCA 
          BX0    X2          RESTORE CONTENTS OF X0 
          SA2    A2+B1
          SA0    X2          RESTORE CONTENTS OF A0 
          SA2    A2+B1       RESTORE CONTENTS OF X2 
          SA1    =H* //////// END CARD MISSING.*
          SA3    A1+B1
          BX6    X1 
          LX7    X3 
          SA1    A3+B1
          SA6    X0 
          SA7    X0+B1
          BX6    X1 
          MX7    0
          SA6    A7+B1
          SA7    A6+B1
          STORE  X2,RL=30 
  
 RNC      PS                 RETURN EXIT
          SA3    EOFINP 
          SA1    CP.IFORM 
          SX6    A0 
          SA0    X2          SAVE FIT ADDRESS IN A0 
          SA6    T6RM1       SAVE FWA OF CARD BUFFER IN T6RM1 
          ZR     X1,RNC1     IF NOT COMPRESSED
          SX7    X6+2 
          SA7    A6+B1       SAVE FWA OF CARD IMAGE IN T6RM2
          NZ     X3,RNCX     IF NO DATA TO READ                         S028 645
          MI     X1,RNC5     IF COMMON DECK 
  
*         CP.IFORM = +2, READ UPDATE COMPRESSED TEXT. 
  
          SA1    X6+15       MOVE HEADER WORDS FROM END                 S028 649
          SA3    A1-B1       OF CARD IMAGE BUFFER                       S028 650
          BX7    X1                                                     S028 651
          SB7    X1+2        SET WORD COUNT TO INCLUDE TWO              S028 652
          SA7    X6+B1       HEADER WORDS FOR NEXT CARD                 S028 653
          LX6    X3                                                     S028 654
          SA6    A7-B1                                                  S028 655
          SX7    B1+B1                                                  S028 656
          RJ     RNC7        READ CARD IMAGE
          EQ     RNCX 
  
  
*         CP.IFORM = -1, READ UPDATE COMMON DECK. 
  
 RNC5     GETP   X2,X6,10    GET FIRST CHB WORD 
          SA5    T6RM1
          SX2    A0 
          SA3    X5 
 RNC5A    SX1    X5+B1
          FETCH  X2,FP,X4 
          SX0    EOD
          BX6    X0*X4
          NZ     X6,RNCX     IF END OF DATA 
          MI     X3,RNC5B    IF LAST CHB WORD 
          GETP   X2,X1,10    GET NEXT CHB WORD
          SA5    T6RM1
          SX2    A0 
          SA3    X5+B1
          EQ     RNC5A       LOOP 
  
 RNC5B    SA5    T6RM1       GET WORD COUNT FROM FIRST CHB WORD 
          SA3    X5 
          AX3    36 
          SX7    B0          NO HEADER WORDS                            S028 660
          SB7    X3 
          RJ     RNC7        READ CARD IMAGE
          SA5    T6RM1
          SA3    X5 
          LX3    59-58
          MI     X3,RNCX     IF CARD IS ACTIVE
          SX6    X5 
          EQ     RNC5 
  
 ENDLOST  VFD    3/3,12/0,9/N.,18//PASS1/END,18//PASS2/END
  
  
  
*         RNC7 - READ COMPRESSED CARD IMAGE.
*         ENTRY  (A0) = FIT ADDRESS.
*                (B7) = WORD COUNT. 
*                (X7) = HEADER WORD COUNT FOR NEXT CARD.                S028 666
*                (T6RM2) = FWA CARD IMAGE.
*         EXIT TO RNCX IF PREMATURE END OF DATA.
  
  
 RNC7     PS                 RETURN EXIT
          SX6    B7                                                     S028 668
          SA7    RNCC        SAVE NEXT HEADER WORD COUNT                S028 669
          SA6    A7+B1       SAVE TOTAL WORD COUNT                      S028 670
          SX2    A0 
          FETCH  X2,FP,X4 
          SX0    EOD
          SA5    T6RM2
          BX6    X0*X4
          SX4    B7 
          NZ     X6,RNCX     IF END OF DATA 
          SX1    B7+B7
          LX4    3
          IX7    X4+X1       X7 = (B7) * 10 
 RNC7A    BX6    X5 
          SA6    RNCA 
          SA7    A6+B1
          GETP   X2,X6,X7    GET CARD IMAGE 
          SX2    A0 
          FETCH  X2,FP,X4 
          FETCH  X2,PTL,X3
          SX0    EOD
          SA5    RNCB 
          BX6    X0*X4
          IX7    X5-X3
          NZ     X6,RNC7B    IF END OF DATA                             S028 677
          ZR     X7,RNC7C    IF END OF CARD IMAGE                       S028 678
          SX0    1S20/10+1
          SA5    A5-B1
          IX3    X3*X0
          AX3    20          X3 = NUMBER OF WORDS READ
          IX5    X5+X3       UPDATE RECORD ADDRESS
          EQ     RNC7A       LOOP 
 RNC7B    SA1    RNCC                                                   S028 680
          IX3    X1+X1                                                  S028 681
          LX1    3                                                      S028 682
          IX4    X1+X3                                                  S028 683
          IX5    X7-X4                                                  S028 684
          NZ     X5,RNCX     IF END OF DATA BEFORE HEADER WORDS         S028 685
 RNC7C    SA1    RNCC                                                   S028 686
          SA3    A1+B1                                                  S028 687
          SA4    T6RM2                                                  S028 688
          IX5    X3-X1                                                  S028 689
          IX3    X4+X5                                                  S028 690
          ZR     X1,RNC7D    IF NO HEADER WORDS                         S028 691
          SA1    X3                                                     S028 692
          SA5    X3+B1                                                  S028 693
          BX6    X1          MOVE HEADER WORDS TO END                   S028 694
          LX7    X5          OF CARD IMAGE BUFFER                       S028 695
          SA6    X4+12                                                  S028 696
          SA7    A6+B1                                                  S028 697
 RNC7D    BX6    X6-X6       CLEAR WORD FOLLOWING CARD IMAGE            S028 698
          SA6    X3                                                     S028 699
          EQ     RNC7        RETURN                                     S028 700
  
 RNCA     DATA   0           TEMPORARY STORAGE
 RNCB     DATA   0
 RNCC     DATA   0                                                      S028 702
 RNCD     DATA   0                                                      S028 703
  
 RM       ENDIF 
 RNS      SPACE  4
**        RNS - READ NEXT STATEMENT.
*         ENTRY  (X2) = FET/FIT ADDRESS.
*                (A0) = FWA OF CARD BUFFER. 
*         EXIT   (CARD) = STRING BUFFER BLANK FILLED. 
*                (CCT) = CARD COUNT.
*                (EDITFG) = MICRO/CONCATENATION FLAG. 
*                (LASTCOL) = INDEX OF LAST CHARACTER. 
*                (SQLGN) = 0. 
*                (STYPE) = BLANK OR ASTERISK. 
*         A0 AND X2 ARE PRESERVED.
  
  
 RNS      PS                 RETURN EXIT
  
          IFNE   CP#RM,0,2
          FETCH  X2,RL,X1    RECORD LENGTH IN CHARACTERS
          SB5    X1 
  
          SA3    CP.IFORM 
          SA5    A0 
          MX7    0
          SB2    CARD 
          SA7    CCT         CLEAR CCT AND SQLGN
          SB7    10 
          SA7    SQLGN
          ZR     X3,RNS1     IF NOT COMPRESSED INPUT
          SA5    A0+2 
 RNS1     MX0    6
          SX6    1R 
          BX0    X0*X5       EXTRACT FIRST CHARACTER
          LX0    6
          SB6    X0-1R* 
          NZ     B6,RNS2     IF NOT ASTERISK
          SX6    1R*
 RNS2     SA1    EDITM
          SB3    10 
          MX0    -6 
          ZR     X3,RNS5     IF UNCOMPRESSED SOURCE INPUT 
          SA6    B2-B1       STORE STYPE
 RNS3     BSS    0
  
 DM       IFNE   CP#RM,7                                                S028 705
  
          LX3    -2 
          MI     X3,RNS4     IF UPDATE OR MODIFY (64) 
  
*         UNPACK MODIFY (63 CHAR SET) COMPRESSED CARD.
  
          MX3    59 
          SB4    -B1
          SB5    1R 
          EQ     RNS3C
 RNS3A    LX5    6           EXTRACT NEXT CHARACTER 
          BX3    -X0*X5 
          ZR     X3,RNS6     IF 0000 (END OF LINE)
 RNS3B    SX3    X3+B4
          SA6    A6+B1       STORE CHARACTER
          PL     X3,RNS3B    IF FILLING BLANKS, LOOP
          NZ     B7,RNS3C    IF SOURCE WORD NOT EXHAUSTED 
          SA5    A5+B1
          SB7    B3 
 RNS3C    LX5    6
          SB6    X6 
          BX6    -X0*X5      EXTRACT NEXT CHARACTER 
          LX4    X1,B6
          SB7    B7-B1
          BX7    X7+X4
          NZ     X6,RNS3B    IF NOT 00
          SB7    B7-B1
          SX6    B5 
          PL     B7,RNS3A    IF SOURCE WORD NOT EXHAUSTED 
          SA5    A5+B1
          SB7    B3-B1
          EQ     RNS3A
  
 DM       ENDIF 
  
*         UNPACK UPDATE OR MODIFY (64 CHAR SET) COMPRESSED CARD.
  
 RNS4     SB4    B0 
          SB5    1R 
          SB6    B5 
          EQ     RNS4B
 RNS4A    SB4    B4-B1       STORE CHARACTER
          SA6    A6+B1
          PL     B4,RNS4A    LOOP IF FILLING BLANKS 
 RNS4B    LX5    6
          SB7    B7-B1
          BX6    -X0*X5      EXTRACT NEXT CHARACTER 
          LX4    X1,B6
          NZ     B7,RNS4C    IF SOURCE WORD NOT EXHAUSTED 
          SB7    B3 
          SA5    A5+B1
 RNS4C    ZR     B6,RNS4D    IF 00XX CODE 
          SB6    X6 
          BX7    X7+X4
          NZ     B6,RNS4A    IF NOT 00 CHARACTER, GO STORE IT 
          EQ     RNS4B       GO GET XX
 RNS4D    SB4    X6 
          SX6    B5 
          NO
          SB6    B5 
          GT     B4,B1,RNS4A IF 0002-0077 CODE, GO STORE BLANKS 
          SB4    B4-B1
          MX6    0
          ZR     B4,RNS4A    IF 0001 CODE, GO STORE 00 CHARACTER
          EQ     RNS6        0000 CODE, END OF LINE 
  
*         UNPACK UNCOMPRESSED CARD IMAGE. 
  
 RNS5     SA3    STYPE-1     SETUP A6 AND X6
          BX4    X6 
          SB6    B0          SCOPE 2 INITIAL CARD OF STATEMENT.          CPS168 
 RNS5A    LX6    X3          CONTINUATION CARDS RE-ENTER HERE 
  
 RM       IFEQ   CP#RM,0
  
          NO
          SA6    A3 
          BX6    X4 
 RNS5B    LX5    6
          SA6    A6+B1       STORE CHARACTER
          SB6    X6 
          BX6    -X0*X5      EXTRACT NEXT CHARACTER 
          LX4    X1,B6
          SB7    B7-B1
          IX5    X5-X6       REMOVE CHARACTER FROM SOURCE WORD
          BX7    X7+X4
          NZ     B7,RNS5C    IF SOURCE WORD NOT EXHAUSTED 
          SB7    B3 
          SA5    A5+B1
 RNS5C    NZ     X6,RNS5B    IF NOT 00 CHARACTER, GO STORE IT 
          NZ     X5,RNS5B    IF 00 FOLLOWED BY ANYTHING OTHER 
          MI     X5,RNS5B    THAN 00, GO STORE THE 00 CHARACTER 
  
 RM       ELSE
  
          SA6    A3 
 +        BX6    X4 
          SA6    A6+B1
          ZR     B5,RNS6     IF EMPTY LINE
          GE     B5,B3,RNS5B IF AT LEAST TEN CHARACTERS 
          SB7    B5-B6       ALLOW FOR LEADING COMMA ON CONTINUATION.    CPS168 
          ZR     B7,RNS6
 RNS5B    LX5    6
          BX6    -X0*X5      EXTRACT NEXT CHARACTER 
          SB6    X6 
          NO
          LX4    X1,B6       TEST FOR EDITING CHARACTERS
          SB7    B7-B1
          BX7    X7+X4
          SA6    A6+B1       STORE CHARACTER
          NZ     B7,RNS5B    IF SOURCE WORD NOT EXHAUSTED 
          SB5    B5-B3
          SA5    A5+B1       GET NEXT WORD
          SB7    B3 
          GE     B5,B3,RNS5B IF AT LEAST TEN CHARACTERS REMAIN
          SB7    B5 
          GT     B5,B0,RNS5B IF NOT END OF LINE 
  
 RM       ENDIF 
  
*         FILL WITH BLANKS IF LESS THAN 90 CHARACTERS READ. 
  
 RNS6     SA7    EDITFG 
          SX7    B2+72
          SB7    B2+89
          SA7    RNSA 
          SB7    A6-B7
          SX6    1R 
 +        SB7    B7+B1
          SA6    A6+B1
          MI     B7,*        LOOP 
  
*         COLLECT SEQUENCE FIELD. 
  
          SA3    CP.IFORM 
          SA1    CCT
          ZR     X3,RNS7     IF UNCOMPRESSED INPUT
          MX0    18 
          SA4    A0+B1
          MI     X3,RNS8A    IF COMMON DECK 
          LX3    59 
          MI     X3,RNS6A    IF MODIFY COMPRESSED COMPILE FILE
  
          SA3    A0          COLUMNS 74-83
          LX4    -18
          BX7    -X0*X4      COLUMNS 84-90
          SX5    1R 
          LX3    -18
          BX6    -X0*X3      COLUMNS 74-80
          IX4    X3-X6       COLUMNS 81-83
          LX5    42 
          BX7    X4+X7       COLUMNS 81-90
          IX6    X5+X6       COLUMNS 73-80
          EQ     RNS8 
  
 RNS6A    BX6    X4          STORE IDENTIFIER AND 
          SA6    SEQ+X1      BINARY SEQUENCE NUMBER 
          EQ     RNS8A
  
 RNS7     SA3    X7          COLLECT COLUMNS 73-80
          MX6    0
          SB7    8
 RNS7B    LX6    6
          SB7    B7-B1
          BX6    X6+X3
          SA3    A3+B1
          NZ     B7,RNS7B 
          MX7    0           COLLECT COLUMNS 81-90
          SB7    B3 
 RNS7C    LX7    6
          SB7    B7-B1
          BX7    X7+X3
          SA3    A3+B1
          NZ     B7,RNS7C 
  
 RNS8     LX0    X1,B1       STORE SEQUENCE FIELD 
          SA6    SEQ+X0 
          SA7    A6+B1
 RNS8A    SX6    X1+B1       INCREMENT CCT
          SA6    A1 
  
*         READ NEXT CARD AND LOOP IF CONTINUATION CARD. 
  
          RJ     RNC         READ NEXT CARD 
  
          IFNE   CP#RM,0,2
          FETCH  X2,RL,X3 
          SB5    X3 
  
          SA5    X0 
          MX0    6
          SA4    CCT
          SA1    RNSA 
          BX6    X0*X5       EXTRACT FIRST CHARACTER
          LX6    6
          SB6    X4-NCARDS
          SB7    X6-1R, 
          ZR     B6,RNS9     IF TOO MANY CONTINUATION CARDS 
          NZ     B7,RNS9     IF FIRST CHARACTER NOT COMMA 
          SA3    EDITFG 
          SB3    10 
          LX5    6
          SA4    X1-1 
          SB7    B3-B1       PREPARE TO UNPACK CONTINUATION CARD
          BX5    X5-X6       SO THAT ITS COLUMN 2 CHARACTER 
          LX7    X3          FOLLOWS COLUMN 72 OF PREVIOUS CARD 
          SA3    CP.IFORM 
          SA1    EDITM
          MX0    -6 
          BX6    X4 
          SB2    A4 
          SA6    A4 
          NZ     X3,RNS3     IF COMPRESSED SOURCE INPUT 
          SA3    A4-B1
          SB6    B1          SCOPE 2 COMPENSATE FOR COMMA.               CPS168 
          EQ     RNS5A       IF UNCOMPRESSED SOURCE INPUT 
  
*         END OF STATEMENT. 
  
 RNS9     SA4    LASTCOL     CLEAR FROM END OF THIS STATEMENT 
          SX7    X1-CARD     TO END OF PREVIOUS STATEMENT 
          SB3    X1+18
          SB4    X4+CARD
          SX6    1R 
          SB2    X1 
          SA7    A4          STORE NEW LASTCOL
          SA6    X1 
          GE     B3,B4,RNS9A
          SB3    B4 
 RNS9A    SB2    B2+B1
          SA6    A6+B1
          LT     B2,B3,RNS9A LOOP 
          EQ     RNS
  
 RNSA     DATA   0
 RSL      SPACE  4
**        RSL - RECORD SEGMENT LENGTH.
  
  
 RSL      PS                 RETURN EXIT
          SA2    O.SEGTAB 
          SA3    L.SEGTAB 
          SA1    ORGCTR 
          IX3    X2+X3
          SA2    A1+B1
          NZ     X2,RSL1     CHANGE ABSOLUTE ORIGIN TO 1
          SA2    UI+1 
 RSL1     LX2    21 
          BX6    X1+X2
          SA6    X3-4 
          EQ     RSL
 RSG      SPACE  4
**        RSG - RELOCATE SEGMENT TABLE. 
  
  
 RSG      PS                 RETURN EXIT
          SA1    O.SEGTAB 
          SA2    L.SEGTAB 
          SB6    X1 
          SB7    B6+X2
          SA3    O.USETAB 
          SB4    21-2 
          SB5    X3-2 
          SB7    B7-4 
          SX3    3774B       MASK FOR RELOCATION
          MX0    -21         FETCH SEGMENT LWA AND RELOCATION 
          SA1    B7 
          SA2    B7+B1       USETAB/IDTAB INDEX 
          SA5    A2+B1       SLITS/EPTAB/LITAB INDEX
 RSG1     LX4    X2 
          BX7    X5 
          SA5    A2+1 
 RSG2     AX2    X1,B4       RELOCATION * 4 
          BX6    X3*X2
          BX2    X4 
          AX2    18          USETAB INDEX 
          IX2    X2+X6
          SA2    B5+X2       FETCH BLOCK ORIGIN 
          IX6    X1+X2       CALCULATE SEGMENT LWA
          BX6    -X0*X6 
          SA6    B7 
          SA7    B7+3        SLITS/EPTAB/LITAB INDEX
          EQ     B6,B7,RSG   IF END OF TABLE
          SB7    B7-4 
          SA2    B7+B1
          BX6    X4-X2
          AX6    18 
          SA1    B7 
          ZR     X6,RSG2     IF SAME USETAB INDEX 
          EQ     RSG1 
 RSS      SPACE  4
**        RSS - RECORD SEGMENT START. 
  
  
 RSS      PS                 RETURN EXIT
          MANAGE SEGTAB,4 
          IX3    X2+X3
          SA1    L.IDTAB
          MX6    0
          SA6    X3-4 
          SA2    UI 
          SA3    EI 
          SA4    LI 
          LX2    18 
          SA5    DI 
          BX7    X2+X1
          LX3    18 
          SA7    A6+B1
          BX4    X3+X4
          LX5    36 
          BX7    X5+X4
          SA7    A7+B1
          SA6    A7+B1
          SA1    QVAL        RECORD CURRENT QUAL BLOCK
          SA2    NBASE       RECORD CURRENT BASE
          IX1    X1+X2
          ADDWORD IDTAB 
          PCARD  IDTAB
          EQ     RSS         RETURN 
 RST      SPACE  4
**        RST - RELOCATE SYMBOL TABLE.
  
  
 RST      PS                 RETURN EXIT
          SA1    L.SYMTAB 
          SA2    O.SYMTAB 
          SA3    O.USETAB 
          SA4    UI 
          IX3    X3+X4       BASE ADDRESS OF BLOCK GROUP
          SB2    B1+B1
          SB7    X1          (B7) = L.SYMTAB
          SB4    -31+59      (B4) = EXTERNAL SHIFT
          SB5    X3-2        (B5) = USETAB INDEX
          SB6    -29+59      (B6) = RELOCATION SIGN SHIFT 
          MX0    -21         (X0) = VALUE MASK
          MX5    8           (X5) = RELOCATION VALUE MASK 
          LX5    21-52
          MX7    31          (X7) = RELOCATION MASK 
          SX3    X2-1 
          RX1    X3 
          SB3    X3 
          EQ     RST2 
 RST1     AX2    21-2        4 * BLOCK NUMBER 
          SA2    B5+X2       SECOND WORD OF USETAB ENTRY
          LX6    X1,B6
          LX3    59-20+31-59
          AX6    59          SIGN OF RELOCATION 
          BX1    X7*X1
          AX3    59-20       SIGN EXTEND RELATIVE ADDRESS 
          BX4    -X0*X2      BLOCK ORIGIN 
          AX2    24-21
          BX6    X6-X4       COMPLEMENT BLOCK ORIGIN IF NEG RELOCATION
          BX2    X5*X2       BLOCK RELOCATION 
          IX3    X3+X6
          BX4    -X0*X3 
          IX2    X1+X2
          BX6    X2+X4
  
 RM       IFNE   CP#RM,7
          SA6    A1          RESTORE SYMBOL TABLE ENTRY 
 RST2     SB7    B7-B2
          SA1    A1+B2       NEXT SYMBOL TABLE ENTRY
 RM       ELSE
          SX3    B3          RESTORE SYMBOL TABLE ENTRY 
          WX6    X3 
 RST2     SX3    B3+B2
          RX1    X3          NEXT SYMBOL TABLE ENTRY
          SB3    X3 
          SB7    B7-B2
 RM       ENDIF 
  
          BX2    X5*X1
          LX3    X1,B4
          MI     B7,RST      IF END OF SYMBOL TABLE 
          ZR     X2,RST2     IF ABSOLUTE OR NULL ENTRY
          PL     X3,RST1     IF NOT EXTERNAL
          EQ     RST2        LOOP 
 RUT      SPACE  4
**        RUT - RELOCATE USE TABLE. 
*         ENTRY  (X1) = USE TABLE INDEX.
*         EXIT   (X0) = PROGRAM LENGTH. 
  
  
 RUT      PS                 RETURN EXIT
          SA5    ABSFG
          SA3    O.USETAB 
          SA2    L.USETAB 
          SA4    UI 
          LX1    2
          IX1    X1+X4
          IX6    X3+X1
          SB6    X6-4 
          IX2    X2+X3
          SB7    X2 
          SB4    X5+B1       ABSOLUTE FLAG + 1
          MX2    -21
          SB3    B0 
          SA3    =R/PROGRAM*/ SET UP REAL BLOCK NAMES 
          SA4    =R/ABSOLUTE*/
          BX6    X3 
          LX7    X4 
          SA6    B6+4 
          SA7    B6 
          BX0    X0-X0       PROGRAM LENGTH 
          SB5    33 
          EQ     B4,B1,RUT1  IF RELOCATABLE 
          SA6    A7 
 RUT1     SA1    B6+B1       FETCH BLOCK LENGTH 
          SA3    A1+B1       TYPE FLAG
          SA4    B6          CHECK NAME 
          SB2    B3+B4       ABSFG + 1 + INDEX
          BX1    -X2*X1 
 +        NE     B4,B1,*+1   IF ABSOLUTE ASSEMBLY 
          NZ     X3,RUT3     IF COMMON BLOCK
          NG     X4,RUT5     IF LCM BLOCK IN ABSOLUTE ASSEMBLY
          EQ     B1,B2,RUT4  IF ABSOLUTE BLOCK IN RELOCATABLE ASSEMBLY
          SB2    B1+B1
          SX5    B2-B4       CALCULATE BLOCK ORIGIN 
          LX5    24 
          BX6    X5+X0
          IX0    X1+X0       AUGMENT PROGRAM LENGTH 
          LX7    X0,B5
          BX6    X6+X7
          SA6    A3          STORE BLOCK ORIGIN, RELOCATION, MAXIMUM
 RUT2     MX6    0
          SB3    B3+4        INCREMENT BLOCK INDEX
          SA6    A6+B1       CLEAR BINWORD WORD 
          SB6    B6+4        INCREMENT LOAD ADDRESS 
          NE     B6,B7,RUT1  LOOP 
          EQ     RUT         RETURN 
  
*         COMMON BLOCK. 
  
 RUT3     SA4    NBLOCKS     INCREMENT BLOCK COUNT
          SX6    X4+B1
          LX7    X1,B5       BLOCK LENGTH 
          SA6    A4 
          SX5    X6+B1
          LX5    24 
          BX6    X7+X5       STORE BLOCK ORIGIN, RELOCATION, MAXIMUM
          SA6    A3 
          EQ     RUT2        LOOP 
  
*         ABSOLUTE BLOCK IN REL ASSEMBLY. 
  
 RUT4     SX6    1S17-1 
          LX6    33 
          SA6    A3 
          EQ     RUT2        LOOP 
  
*         LOCAL LCM BLOCK.
  
 RUT5     SA4    LCM         INCREMENT LCM LENGTH 
          IX7    X4+X1
          SA7    A4 
          LX5    X7,B5
          BX6    X4+X5       STORE BLOCK ORIGIN, RELOCATION, MAXIMUM
          EQ     B4,B1,RUT6  IF REL ASSEMBLY
          SA6    A3 
          EQ     RUT2 
 RUT6     SA1    LLB
          SA5    NBLOCKS
          NZ     X1,RUT7     IF NOT FIRST LOCAL LCM BLOCK IN REL ASMBLY 
          SX6    X5+B1
          SX1    X6+B1
          SA6    A5          INCREMENT BLOCK COUNT
          LX1    24 
          BX6    X1          SAVE LCM LOCAL BLOCK RELOCATION
          SA6    A1 
 RUT7     BX6    X1+X4
          LX5    X7,B5
          BX6    X6+X5       STORE BLOCK ORIGIN, RELOCATION, MAXIMUM
          SA6    A3 
          EQ     RUT2        LOOP 
 SIA      SPACE  4
**        SIA - SKIP ITERATIVE ARGUMENT.
*         ENTRY  (A7) = STACK ADDRESS.
*                (X4) = MARDIS INDEX. 
*         EXIT   (A7) = STACK ADDRESS.
*                (X6) = 0 IF END OF LIST. 
  
  
 SIA      PS                 RETURN EXIT
          SA1    O.MARDIS 
          SA5    O.MARGS
          SA0    60          (A0) = 60
          SB2    X4 
          SA2    X1+B2       (X2) = ARGUMENT DESCRIPTOR WORD
          SB3    X5 
          UX3,B4 X2 
          SB3    B3+X2       (B3) = FWA OF ARGUMENT 
          LX3    59-41
          SB4    -B4         (B4) = ARGUMENT CHARACTER COUNT
          SB6    X3          (B6) = SHIFT COUNT FOR NEXT CHARACTER
          UX3,B5             (B5) = COUNT OF CHARS PRECEDING CURRENT CH 
          LX3    41-29
          UX3,B2
          SA3    B3+B2       (X3) = CURRENT WORD OF ARGUMENT
          SB6    B6+6 
          SB5    B5+B1
          LX4    X3,B6       GET NEXT CHARACTER 
          SB7    A0-B6
          GT     B5,B4,SIA7  IF PAST END OF ARGUMENT
          BX6    -X0*X4 
          NZ     B7,SIA1     IF NOT END OF WORD 
          SA3    A3+B1
          SB6    B0 
 SIA1     SB7    X6-1R( 
          MX5    0
          ZR     B7,SIA4     IF FIRST CHARACTER IS *(*
          EQ     SIA3 
  
 SIA2     SB6    B6+6        SKIP ONE SUBARGUMENT 
          SB5    B5+B1
          LX4    X3,B6       GET NEXT CHARACTER 
          SB7    A0-B6
          GT     B5,B4,SIA7  IF PAST END OF ARGUMENT
          BX6    -X0*X4 
          NZ     B7,SIA3     IF NOT END OF WORD 
          SA3    A3+B1
          SB6    B0 
 SIA3     SX5    X6-1R, 
          NZ     X5,SIA2     IF NOT *,* 
          SX2    X2          UPDATE ARGUMENT POINTER
          SX6    B6 
          LX2    59-41
          BX2    X2+X6
          PX2    B5 
          SB2    A3-B3
          LX2    41-29
          PX2    B2 
          SB4    -B4
          LX2    29-59
          PX6    X2,B4
          SA6    A2 
          SA4    A7+2 
          SX6    X7 
          AX4    18          RESET MACRO DEFINITION POINTER 
          BX7    X7-X6
          BX7    X7+X4
          SX6    B1 
          SA7    A7 
          EQ     SIA         RETURN 
  
*         SKIP PARAMETER IN PARENS. 
  
 SIA4     SB6    B6+6        SKIP EMBEDDED SUBARGUMENT
          SB5    B5+B1
          LX4    X3,B6       GET NEXT CHARACTER 
          SB7    A0-B6
          GT     B5,B4,SIA7  IF PAST END OF ARGUMENT
          BX6    -X0*X4 
          NZ     B7,SIA5     IF NOT END OF WORD 
          SA3    A3+B1
          SB6    B0 
 SIA5     SB7    X6-1R( 
          ZR     B7,SIA6     IF *(* 
          NE     B7,B1,SIA4  IF NOT *)* 
 SIA6     SB7    B7+B7
          SX4    B1-B7
          IX5    X5+X4
          PL     X5,SIA4     IF STILL WITHIN PARENS 
          EQ     SIA2 
  
*         TERMINATE CURRENT IRP.
  
 SIA7     SX6    X2 
          PX6    B4 
          SA6    A2 
          MX6    0
          EQ     SIA         RETURN 
 SOS      SPACE  4
**        SOS - SCAN OPERATION SYNTAX.
*         ENTRY  SYNTAX IN LOCATION FIELD.
*         EXIT   (X6) = 0 IF ERROR. 
*                (X6) " 0 IF NO ERROR.
*                (P1TEMP) = CONVERTED SYNTAX. 
*                (P1TEMPD) = NUMBER OF PARAMETERS REQUIRED. 
  
  
 SOS      PS                 RETURN EXIT
          MX7    0           CLEAR ACCUMULATION CELLS 
          SA7    OPADS+1
          SA7    A7+B1
          SA7    A7+B1
          SB7    X1-1R
          SB3    B0 
 +        SB2    B0 
          NZ     B7,*+1      IF 1ST COLUMN IS NOT BLANK 
          SA1    A1+B1
          BX6    X1 
          SB7    X1-1R
          SA1    A1+B1       SECOND LETTER OF OP CODE 
          ZR     B7,SOSER    IF FIRST LETTER WAS BLANK
          SB7    X1-1R
          ZR     B7,SOSER    IF SECOND LETTER WAS BLANK 
          LX6    6
          BX6    X1+X6
          SB7    X1-3        TEST FOR OP-CODE REGISTER
          SB6    X1-1RX 
          SA6    OPADS
          SB3    B0 
 +        NG     B7,*+1 
          NZ     B6,SOS1
          SB3    B1          SET PARAMETER COUNT TO 1 
  
*         ENTRY ON NEW FIELD. 
  
 SOS1     MX6    0           SYNTAX MASK FOR SUBFIELD 
          SX7    B0          INTERLOCK FLAG FOR REGISTERS 
          BX5    X6          INTERLOCK FLAG FOR ADDRESSES 
 SOS2     SA1    A1+B1
 SOS3     SB7    X1-1R
          ZR     B7,SOS9     IF END OF FIELD
          EQ     B7,B1,SOS9  IF END OF SUBFIELD 
          NZ     X5,SOSER    IF SECOND Q FIELD
          SB7    X1-1RQ 
          ZR     B7,SOS8
          NZ     X7,SOSER    IF WE HAVE ALREADY WRITTEN REGISTERS 
          SB7    X1-1R+      CHECK LEADING OPERATOR 
          ZR     B7,SOS4     IF PLUS
          NE     B7,B1,SOS5  IF NOT MINUS 
 SOS4     SX0    B7 
          SA1    A1+B1
          LX0    7
          BX6    X0+X6
 SOS5     SB7    X1-3 
          SB6    X1-1RX 
          NG     B7,SOS6
          SX1    3
          NZ     B6,SOSER    ERROR IF NOT ABX 
 SOS6     LX1    5
          BX6    X1+X6
          SA1    A1+B1
          SB3    B3+B1       INCREMENT PARAMETER COUNT
          MX7    1           SET REGISTER INTERLOCK 
          SB7    X1-1R+      TEST INTERMEDIATE OPERATOR 
          SB6    X1-1R/-1 
          NG     B7,SOS3
          PL     B6,SOS3
          SX0    B7 
          SA1    A1+B1
          SB3    B3+B1       INCREMENT PARAMETER COUNT
          LX0    3
          BX6    X0+X6
          SB7    X1-3 
          SB6    X1-1RX 
          NG     B7,SOS7
          SX1    3
          NZ     B6,SOSER 
 SOS7     LX1    1
          BX6    X1+X6
          EQ     SOS2 
  
*         Q SUBFIELD. 
  
 SOS8     SX6    X6+B1       SET ADDRESS FLAG 
          MX5    1           SET ADDRESS INTERLOCK
          SB3    B3+B1       INCREMENT PARAMETER COUNT
          EQ     SOS2 
  
*         END OF SUBFIELD.
  
 SOS9     ZR     X6,SOS9A    IF EMPTY SUBFIELD
          SA6    A6+B1       STORE MASK 
          ZR     B7,SOS10    JUMP IF TERMINATOR WAS BLANK 
          SB2    B2+B1       INCREMENT SUBFIELD COUNT 
          SB7    B2-3 
          NG     B7,SOS1     IF NOT TOO MANY COMMAS YET 
          EQ     SOSER
 SOS9A    NZ     B7,SOS1     IF NOT END OF SYNTAX SPECIFICATION 
  
*         END OF SYNTAX.
  
 SOS10    SA1    OPADS       CONSTRUCT MASK 
          SA2    A1+B1
          LX1    36 
          SA3    A2+B1
          LX2    28 
          SA4    A3+B1
          BX6    X1+X2
          LX3    20 
          SX0    1R 
          BX6    X3+X6
          IX7    X0+X6
          LX4    12 
          BX6    X4+X7
          SX7    B3          PARAMETER COUNT
          SA6    P1TEMP 
          SA7    P1TEMPD
          EQ     SOS         RETURN 
  
*         ERROR IN SYNTAX.
  
 SOSER    SX6    B1          NOTE ARGUMENT COUNT ERROR
          SA6    W5ERR
          SA6    EFLG 
          MX6    0
          EQ     SOS         RETURN 
 SQUEEZE  SPACE  4
**        SQUEEZE - COMPRESS CARD.
*         ENTRY  IF (SQLGN) " 0 SQUEEZE IS NULL.
*         EXIT   (SQLGN) = LENGTH OF SQUEEZED IMAGE.
  
  
 SQUEEZE  PS                 RETURN EXIT
          SA1    SQLGN
          NZ     X1,SQUEEZE  IF CARD ALREADY SQUEEZED 
          SA3    LASTCOL
          SA5    STYPE
          SB2    -1R
          SB3    -2 
          SB4    77B
          SB6    10 
          SB7    STCA 
          BX6    X6-X6
          MX7    60 
          SA6    SQIMAGE-1
          SA7    CARD+X3     STORE -0 IN LAST COLUMN + 1
          PX0    X6,B6
  
 SQU1     SB6    B6-B1       PACK CHARACTER 
          BX6    X6+X5
          SA5    A5+B1       FETCH NEXT CHARACTER 
          SA2    X5+B7
 SQU2     NZ     B6,SQU3     IF WORD NOT FULL 
          SA6    A6+B1
          UX6,B6 X0 
 SQU3     LX6    6
          PL     X2,SQU1     IF NOT -0 NOR 00 NOR 55 NOR 77 
          SB5    B3 
 SQU4     SX2    X5+B2       COUNT BLANKS 
          SB5    B5+B1       (B5) = BLANK COUNT - 1 
          NO
          SA5    A5+B1
 SQU5     ZR     X2,SQU4
          LE     B5,B1,SQU6  IF 0, 1, OR 2 BLANKS 
          GT     B5,B4,SQU8  IF MORE THAN 64 BLANKS 
          SB6    B6-B1       PACK 0002-0077 FOR 3 TO 64 BLANKS
          SA5    A5+B3       RESET CHARACTER POINTER
 SQU5A    SX5    B5 
          BX2    X2-X2       GO PACK 00NN 
          EQ     SQU2 
  
 SQU6     SB5    B5-B3       0, 1, OR 2 BLANKS
          SA5    A5-B5       RESET CHARACTER POINTER
          GT     B5,B1,SQU1  IF 1 OR 2 BLANKS 
          MI     X5,SQU9     IF -0 (END OF STATEMENT) 
          ZR     X5,SQU7     IF 00 (COLON)
          SA2    A5+B1       77 (SEMICOLON OR PARAMETER MARK) 
          SX2    X2+B2       SEE IF NEXT CHARACTER IS 55 (BLANK)
          NZ     X2,SQU1     IF 77 NOT FOLLOWED BY 55 
          SB6    B6-B1
          BX6    X6+X5       PACK 77 (SEMICOLON OR PARAMETER MARK)
          NO
          SA5    A5+B1
          EQ     SQU2        GO PACK 55 (BLANK) 
  
 SQU7     SB6    B6-B1       00 (COLON), PACK 0001
          EQ     SQU5A
  
 SQU8     SB6    B6-B1       MORE THAN 64 BLANKS, PACK 0077 
          SB5    B5-B1       PACK 00
          NO
          SX5    B4 
          NZ     B6,SQU8A    IF WORD NOT FULL 
          SA6    A6+B1
          UX6,B6 X0 
 SQU8A    LX6    6           PACK 77
          SB6    B6-B1
          SB5    B5-B4       REDUCE BLANK COUNT 
          BX6    X6+X5
          NZ     B6,SQU8B    IF WORD NOT FULL 
          SA6    A6+B1
          UX6,B6 X0 
 SQU8B    LX6    6
          PL     B5,SQU5     IF AT LEAST ONE MORE BLANK 
          SA5    A5-B1
          LX6    -6 
          SA2    X5+B7
          EQ     SQU3        GO PROCESS NEXT CHARACTER
  
 SQU9     SX1    B6+B6       END OF STATEMENT 
          LX2    X1,B1
          IX3    X1+X2
          SX7    -B2
          SB6    X3-6        LEFT-JUSTIFY WORD IN X6
          LX6    X6,B6
          SA7    A7          RESTORE BLANK AFTER LAST COLUMN
          SB7    B6-6 
          SA6    A6+B1
          PL     B7,SQU9A    IF AT LEAST 12 ZERO BITS 
          BX6    X6-X6
          SA6    A6+B1
 SQU9A    SX6    A6-SQIMAGE+1 
          SA6    SQLGN
          EQ     SQUEEZE     RETURN 
 TLUMIC   SPACE  4
**        TLUMIC - LOOK UP ENTRY IN MICRO TABLE.
*         ENTRY  (X7) = MICRO NAME. 
*         EXIT   (B4) = WORD COUNT OF ENTRY INCLUDING HEADER WORD.
*                (B4) = 0 IF MICRO NOT FOUND. 
*                (A2) = FWA-1 OF ENTRY. 
*         USES  A2,A5,A7,X0,X2,X3,X5,X6,X7,B4,B6. 
*         CALLS  NONE.
  
  
 TLUMIC   PS                 RETURN EXIT
          SA2    L.MICTAB 
          SA5    O.MICTAB 
          SB6    X2-1 
          SA2    X5+B6
          PX7    X7,B1       STORE NAME TO STOP SEARCH
          SA7    X5 
          UX6    X7 
 MLU1     UX5,B4 X2          SEARCH MICRO TABLE 
          BX7    X6-X5
          SB6    B6-B4
          SA2    A2-B4
          NZ     X7,MLU1     LOOP 
          PL     B6,TLUMIC   IF FOUND, RETURN 
          BX7    X6 
          SB4    B0          NOT FOUND, TRY BUILT-IN MICROS 
          SA2    MLUB-1 
          SB6    MLUB-MLUA-1
          SA7    MLUA 
 MLU2     BX6    X7-X2       SEARCH BUILT-IN MICRO NAMES
          SB6    B6-B1
          SA2    A2-1 
          NZ     X6,MLU2     LOOP 
          MI     B6,TLUMIC   IF NOT FOUND, RETURN 
          SB4    2
          SA2    MLUB+B6
          NZ     B6,TLUMIC   IF NOT *SEQUENCE*, RETURN
          SA5    CP.IFORM 
          LX5    -1 
          MI     X5,MLU4     IF MODIFY COMPRESSED INPUT 
          SA5    A2+B1
          MX6    12 
          BX7    X6*X5       COLUMNS 81-82
          BX6    X7+X2
          BX7    X5-X7       COLUMNS 83-90
          LX6    12          COLUMNS 73-82
          SX5    8
          LX7    12 
          IX7    X7+X5       APPEND CHARACTER COUNT 
          SA7    P1TEMPE
          BX7    X6          STORE MICRO VALUE
          SA7    A7-B1
          SA2    A7-B1
          SB4    B4+B1       WORD COUNT = 3 
          EQ     TLUMIC      RETURN 
  
 MLU4     BX7    X3          MODIFY 
          MX6    -18
          SA7    P1TEMPC     SAVE (X3)
          SB4    B0 
          BX0    -X6*X2      SEQUENCE NUMBER
          SA5    =1H
          SA2    =0.1000000001P48 
          BX6    X5 
          SA5    =10.0P0
          PX0    X0 
          BX3    X5 
 MLU5     DX5    X0*X2       CONVERT TO DECIMAL 
          FX0    X0*X2
          SB6    X0 
          LX6    -6 
          SB4    B4+6 
          FX7    X5*X3
          SX5    X7+1R0-1R
          IX6    X5+X6
          NZ     B6,MLU5     LOOP 
          LX6    -6 
          LX6    X6,B4
          SA2    SEQMIC 
          SA5    =4L
          MX7    24 
          LX6    -24
          BX7    X7*X6
          BX6    X6-X7
          BX6    X5+X6
          LX5    -24
          SX0    8
          BX7    X5+X7
          BX7    X7+X0
          MX0    42 
          BX2    X0*X2
          MX0    6
 +        BX3    -X0*X2      FORM MASK FOR SIGNIFICANT CHARACTERS 
          AX0    6
          NZ     X3,* 
          MX3    6
          BX0    -X3*X0 
          LX0    6
          BX2    X0*X2
          BX6    -X0*X6 
          BX6    X2+X6       COLUMNS 73-82
          SA7    P1TEMPE
          BX7    X6          STORE MICRO VALUE
          SA7    A7-B1
          SB4    3           WORD COUNT = 3 
          SA2    A7-B1
          BX3    X2          RESTORE (X3) 
          EQ     TLUMIC      RETURN 
  
 MLUA     DATA   0           BUILT-IN MICRO NAMES 
          DATA   0RSEQUENCE 
          DATA   0RBASE 
          DATA   0RCODE 
          DATA   0RQUAL 
 MLUB     BSS    0           BUILT-IN MICRO VALUES
 SEQMIC   DATA   0,0         SEQUENCE MICRO VALUE 
 BASEMIC  CON    1LD+1       BASE MICRO VALUE 
 CODEMIC  CON    1LD+1       CODE MICRO VALUE 
 QUALMIC  CON    0           QUAL MICRO VALUE 
 UCARD    SPACE  4
**        UCARD - UNPACK CARD.
*         ENTRY  (X1) = ADDRESS OF IMAGE. 
*         EXIT   (X6) = ADDRESS OF NEXT CARD. 
*         THIS ROUTINE SETS UP... 
*                CARD              CONTAINS IMAGE WHICH HAS BEEN UPACKED
*                CCT               CONTAINS CARD COUNT. 
*                LASTCOL           CONTAINS LAST COLUMN NUMBER. 
  
  
 UCARD0   PL     B2,UCARD1   IF OUT OF RANGE OF CARD
          SA6    B2+B3
          SB2    B2+B1
 UCARD1   AX7    X1,B4       EXTRACT NEXT CHARACTER 
          SB6    B6-B1
          BX6    -X0*X7 
          LX1    6
          NZ     B6,UCARD2   IF NOT END OF WORD 
          SB6    A0 
          SA1    A1+B1
 UCARD2   NZ     X7,UCARD0   IF NOT 00 NOR 77 
          MI     X7,UCARDS   IF 77 (SEMICOLON OR PARAMETER MARK)
          SB6    B6-B1
          LX1    6           00, EXTRACT NEXT CHARACTER 
          BX6    -X0*X1 
          SB5    X6+B1
          NZ     B6,UCARD3   IF NOT END OF WORD 
          SB6    A0 
          SA1    A1+B1
 UCARD3   AX6    1
          SB2    B2+B5
          NZ     X6,UCARD1   IF 0002-0077 (3 TO 64 BLANKS)
          SB2    B2-B5
          BX6    X6-X6
          NE     B5,B1,UCARD0 IF 0001, GO STORE 00 (COLON)
  
          SB6    A0-B6       0000, END OF STATEMENT 
          NG     B2,UCARD4   IF STATEMENT NOT TOO LONG
          SB2    B0 
 UCARD4   SB2    B2+71*NCARDS+1  CALCULATE NUMBER OF COLUMNS
          SB3    71 
          SX7    B2 
          NZ     X7,UCARD5   IF NOT EMPTY STATEMENT 
          SX7    B1 
 UCARD5   SB2    B2-B3       CALCULATE NUMBER OF CARDS IN STATEMENT 
          SX6    X6+B1
          GT     B2,B3,UCARD5 
          SA6    CCT
          SA7    LASTCOL
          SX6    A1+B1       (X6) = FWA NEXT STATEMENT
          NZ     B6,UCARD    IF NOT END OF WORD 
          SX6    A1 
  
 UCARD    PS                 RETURN EXIT
          SX6    1R 
          BX7    X6 
          SA1    X1 
          SA4    LASTCOL
          SB7    X4-1 
          SA6    STYPE
          MX5    59 
          SB6    B1+B1
          SB2    -71*NCARDS-2 
          SB3    A6-B2
          MX0    -6 
 UCARD7   SA7    A6+B1       STORE BLANKS IN CARD AREA
          SB7    B7-2 
          SA6    A7+B1
          PL     B7,UCARD7
          SA0    10 
          SB4    54 
          SB6    A0 
          EQ     UCARD1 
  
*         SUSTITUTE PARAMETER.
  
 UCARDS   AX7    X1,B4       77, EXTRACT NEXT CHARACTER 
          BX7    -X0*X7 
          ZR     X7,UCARD0   IF 00 (END-OF-LINE OR COLON) 
          SA3    O.STACK
          SA4    L.STACK
          IX3    X3+X4
          ZR     X4,UCARD0   IF NO STACK ENTRY EXISTS 
          SB7    X7-1        PARAMETER NUMBER 
          SB5    A0 
          SA4    X3-3        FETCH SECOND WORD OF STACK ENTRY 
          SA2    L.MARDIS 
          SX3    X4+B7
          IX2    X3-X2
          PL     X2,UCARD0   IF PARAMETER NUMBER TOO LARGE
          SA2    O.MARDIS 
          SB6    B6-B1       UPDATE SOURCE POINTERS 
          LX1    6
          NZ     B6,UCD1     IF NOT END OF WORD 
          SB6    A0 
          SA1    A1+B1
 UCD1     IX4    X2+X3
          SA3    X4 
          SA4    O.MARGS
          SB7    X3 
          SA2    B7+X4
          UX3,B7
          PL     B7,UCARDS1  IF NOT IRP PARAMETER 
  
*         UNPACK IRP PARAMETER. 
  
          LX3    59-41
          SB4    X3          (B4) = SHIFT COUNT FOR CURRENT CHARACTER 
          UX3,B5
          SA0    60          (A0) = 60
          LX3    41-29
          SB5    B5+B7       (B5) = - REMAINING CHARACTER COUNT 
          UX3,B7
          SA2    A2+B7       (X2) = CURRENT WORD OF ARGUMENT
          SB4    B4+6 
          SB5    B5+B1
          LX3    X2,B4       GET NEXT CHARACTER 
          SB7    A0-B4
          GT     B5,UCD6     IF PAST END OF ARGUMENT
          BX6    -X0*X3 
          NZ     B7,UCD2     IF NOT END OF WORD 
          SA2    A2+B1
          SB4    B0 
 UCD2     SB7    X6-1R( 
          MX4    0
          ZR     B7,UCD7A    IF FIRST CHARACTER IS *(*
          EQ     UCD5 
  
 UCD3     PL     B2,UCD4     IF END OF CARD BUFFER
          SA6    B2+B3
          SB2    B2+B1
 UCD4     SB4    B4+6 
          SB5    B5+B1
          LX3    X2,B4       GET NEXT CHARACTER 
          SB7    A0-B4
          GT     B5,UCD6     IF PAST END OF ARGUMENT
          BX6    -X0*X3 
          NZ     B7,UCD5     IF NOT END OF WORD 
          SA2    A2+B1
          SB4    B0 
 UCD5     SX3    X6-1R, 
          NZ     X3,UCD3     IF NOT *,* 
  
 UCD6     SA0    10          END OF SUBARGUMENT, RESTORE REGISTERS
          SB4    54 
          EQ     UCARD1 
  
*         STORE PARAMETER IN PARENS.
  
 UCD7     PL     B2,UCD7A    IF END OF CARD BUFFER
          SA6    B2+B3
          SB2    B2+B1
 UCD7A    SB4    B4+6 
          SB5    B5+B1
          LX3    X2,B4       GET NEXT CHARACTER 
          SB7    A0-B4
          GT     B5,UCD6     IF PAST END OF ARGUMENT
          BX6    -X0*X3 
          NZ     B7,UCD8     IF NOT END OF WORD 
          SA2    A2+B1
          SB4    B0 
 UCD8     SB7    X6-1R( 
          ZR     B7,UCD9     IF *(* 
          NE     B7,B1,UCD7  IF NOT *)* 
 UCD9     SB7    B7+B7
          SX3    B1-B7
          IX4    X4+X3
          PL     X4,UCD7     IF STILL WITHIN PARENS 
          EQ     UCD4 
  
*         UNPACK FORMAL PARAMETER.
  
 UCARDS2  PL     B2,*+1 
          SA6    B2+B3
          SB2    B2+B1
 UCARDS1  SB5    B5-B1
          LX2    6
          SB7    B7-B1
          BX6    -X0*X2 
          NZ     B5,*+1 
          SA2    A2+B1
          SB5    A0 
          PL     B7,UCARDS2  LOOP TO END OF ARGUMENT
          EQ     UCARD1 
 WINTER   SPACE  4
**        WINTER - WRITE INTERMEDIATE FILE. 
*         THIS ROUTINE ADDS A STATEMENT TO THE INTERMEDIATE FILE OR 
*         INTERMEDIATE TABLE. 
*         INTERMEDIATE FILE FORMAT: 
* 
*         OPTYPE     3/TYPE,10/,1/TW,1/SF,1/FF,1/IF,2/,7/L,4/CCT,30/BIN 
*         IND        22/,8/FLAGS,12/,18/EFLAGS
*         FLAG       60/FLAG
*         SEQUENCE   12/,48/NAME
*                    60/NUMBER
*         CARD       60/CARD
* 
*                TYPE = OPERATION TYPE. 
*                TW = TWO-WORD SEQUENCE FIELD(S) PRESENT. 
*                SF = SEQUENCE FIELD PRESENT FOR EACH CARD. 
*                FF = FLAG PRESENT. 
*                IF = IND PRESENT.
*                L = LENGTH OF COMPRESSED RECORD. 
*                CCT = NUMBER OF CARDS. 
*                BIN = INFORMATION FROM PASS 1 PROCESSOR. 
*                FLAGS = 200 NOAS 
*                        100 TXTFLG 
*                        040 MICFLG 
*                        020 SYSFLG 
*                        010 MACFLG 
*                        004 ECHFLG 
*                        002 RMTFLG 
*                        001 LIMFLG 
  
  
*         TABLE JUST OVERFLOWED.
  
 WIN7     SX6    B0          CLEAR INTERMEDIATE FILE TABLE
          SA6    L.INTER
  
*         WRITE INFORMATION ON SCRATCH FILE.
  
  
 RM       IFEQ   CP#RM,0
 WIN8     WRITEW S,B6,B7-B6 
 RM       ELSE
 WIN8     SX3    B7-B6
          IX4    X3+X3
          LX3    3
          IX2    X3+X4
          SX1    B6 
          PUT    S,X1,X2
 RM       ENDIF 
  
          SA1    SQLGN
  
 RM       IFEQ   CP#RM,0
          WRITEW S,SQIMAGE,X1 
 RM       ELSE
          IX2    X1+X1
          LX1    3
          IX1    X1+X2
          PUT    S,SQIMAGE,X1 
 RM       ENDIF 
  
 WINTER   PS                 RETURN EXIT
          SA1    STCNT       INCREMENT STATEMENT COUNT
          SX6    B1 
          IX6    X6+X1
          SA6    A1 
          SA2    IFCNT       SET NOAS (NO ASSEMBLY FLAG) IF IFCNT .NE. 0
          SX6    B0 
          ZR     X2,WIN1     IF NOT IF SKIPPING 
          SA2    LF+1 
          ZR     X2,WINTER   IF NOT LISTING IF-SKIPPED LINES
          SX6    B1 
 WIN1     SA6    NOAS 
          RJ     SQUEEZE     COMPRESS LINE
          SB6    SEQ-1
          SB7    SEQ
          SA2    FLAG        CHECK FLAG WORD
          SX5    B1 
          LX5    44 
          SA1    OPTYPE 
          MX0    18 
          BX7    X2 
          SA7    B6 
          LX0    48 
          BX0    -X0*X1      (X0) = OPTYPE
 +        ZR     X2,*+1      IF NO FLAG 
          BX0    X0+X5
          SB6    B6-B1
          MX6    0           FETCH CONTROL FLAGS
          SB5    LIBFLG-NOAS
          SA1    NOAS 
 WIN2     SB5    B5-B1
          IX4    X6+X6
          BX6    X4+X1
          SA1    A1+B1
          PL     B5,WIN2     LOOP 
          SA1    EFLG 
          LX6    30 
          ZR     X1,WIN4     IF NO ERROR FLAGS
          SB5    LEFLG-1
          SA1    ERFLAGS
 WIN3     LX4    X1,B5
          SB5    B5-B1
          SA1    A1+B1
          BX6    X6+X4
          PL     B5,WIN3     LOOP 
 WIN4     AX5    -43+44 
          SA6    B6 
          SA1    CCT         CHECK SEQUENCE FIELDS
 +        ZR     X6,*+1      IF NO IND
          BX0    X0+X5
          SB6    B6-B1
          SA3    L.STACK
          SA2    CP.IFORM 
          BX6    X1 
          SB4    B1+B1
          SX5    B1+B1
          LX6    30 
          BX0    X0+X6
          LX2    59 
          NZ     X3,WIN6     IF GENERATED STATEMENT 
          SB4    X1                                                     S004 114
          SX5    B1 
          MI     X2,WIN6     IF MODIFY COMPRESSED INPUT 
  
          SB5    X1          CHECK FOR SEQUENCE FIELDS ALL BLANK
          MX1    0
          SA2    =8R
          SB4    B5+B5
          SA3    =10R 
          SA4    SEQ
          SA5    A4+B1
 WIN5     BX6    X2-X4
          SA4    A5+B1
          BX7    X3-X5
          SA5    A4+B1
          SB5    B5-B1
          BX6    X6+X7
          BX1    X1+X6
          NZ     B5,WIN5     LOOP TO CHECK ALL CARDS
          ZR     X1,WIN6A    IF SEQUENCE FIELDS ALL BLANK 
          SX5    3
 WIN6     LX5    45 
          SB7    B7+B4
          BX0    X0+X5
 WIN6A    SA1    SQLGN       SET RECORD LENGTH IN OPTYPE
          SB5    B7-B6
          SX7    X1+B5
          LX7    34 
          BX6    X0+X7
          SA2    INTERIO     CHECK INTERMEDIATE 
          SA6    B6          STORE OPTYPE 
          NZ     X2,WIN8     IF INTERMEDIATE ON DISK
          SX6    B6 
          SX7    B5 
          SA6    WINA 
          SA7    A6+B1
          MANAGE INTER,X1+B5 AUGMENT INTERMEDIATE 
          SA1    INTERIO
          SA4    WINA 
          SA5    A4+B1
          SB6    X4 
          SB7    X5+B6
          IX6    X3+X2
          NZ     X1,WIN7     IF TABLE JUST OVERFLOWED 
          SA1    SQLGN
          IX3    X6-X1
          IX2    X3-X5
 +        SA4    B6          MOVE FLAGS AND SEQUENCE FIELDS 
          SB6    B6+B1
          BX6    X4 
          SA6    X2 
          SX2    X2+B1
          NE     B6,B7,*-1   LOOP 
          SX2    SQIMAGE     MOVE PACKED IMAGE INTO TABLE 
          RJ     MOVE 
          EQ     WINTER      RETURN 
  
 WINA     BSS    2
 YDEFLOC  SPACE  4
**        YDEFLOC - DEFINE LOCATION SYMBOL. 
*         NULL ACTION IF BAD SYMBOL OR EMPTY SYMBOL.
*         ENTRY  (X2) = VALUE.
*                (X3) = RELOCATION. 
*                (X4) = EXTERNAL NUMBER.
*                (X5) = REDEFINITION FLAG.
  
  
 YDEFLOC1 SX6    B1          COMPLAIN ABOUT BAD LOCATION SYMBOL 
          SA6    EFLG 
          SA6    W1ERR
  
 YDEFLOC  PS                 RETURN EXIT
          SA1    BADLOC      CHECK FOR BAD SYMBOL 
          NZ     X1,YDEFLOC1
          SA1    LOCSYM 
          RJ     YDEFSYM     GO DEFINE SYMBOL 
          EQ     YDEFLOC
 YDEFSYM  SPACE  4
**        YDEFSYM - DEFINE SYMBOL.
*         WILL POST DERR AND CHECK SYMBOL FOR VALID CONSTRUCTION. 
*         ENTRY  (X1) = SYMBOL. 
*                (X2) = VALUE.
*                (X3) = RELOCATION. 
*                (X4) = EXTERNAL NUMBER.
*                (X5) = REDEFINITION FLAG.
*         EXIT   (X1) = SYMBOL. 
  
  
 YDEFSYM  PS                 RETURN EXIT
          ZR     X1,YDEFSYM  EXIT IF SYMBOL IS BLANK
          BX6    X1 
          MX0    39          MASK OUT 21-BIT VALUE
          BX7    -X0*X2 
          BX3    X4+X3       COMBINE RELOCATION AND EXTERNAL-NESS 
          LX5    3
          SX5    X5+B1       SET DEFINITION BIT 
 +        SB7    B1+B1
          ZR     X4,*+1 
          SX5    X5+B7       SET EXTERNAL BIT 
          LX3    21 
          BX2    X7+X3
          LX5    30          CONTROL BITS 
          BX7    X2+X5
          SA6    YDEFSYMT    SAVE SYMBOL
          MX0    6
          SA7    A6+B1       SAVE EQUIVALENT
 YDEFSYM1 LX1    6
          BX2    X1*X0       LEFT JUSTIFY SYMBOL
          ZR     X2,YDEFSYM1
          MX3    54          CHECK FOR INVALID SYMBOLS
          SB7    9
          SX6    B0 
          SA5    =77776360020B MASK FOR NUMBERS + - * / BL , &
 YDEFSYM8 LX1    6
          BX4    -X3*X1 
          SB6    X4 
          SB7    B7-B1
          LX7    X5,B6
          BX6    X6+X7
          SA5    =36060020B  MASK FOR + - * / BL , &
          PL     B7,YDEFSYM8
          NG     X6,YDEFSYM2 JUMP IF ANY BAD CHARACTERS PRESENT 
          LX2    12          CHECK FIRST CHARACTER FOR A B OR X 
          SA3    MACHINE
          SA4    SYNAME 
          SB7    X2-1RC*64
          SB6    X2-1RX*64
          NZ     X3,YDEFSYM4 DONT BOTHER IF PP CODE OR
          NZ     X4,YDEFSYM4 IF ASSEMBLING SYSTEM TEXT
 +        NG     B7,*+1      IF FIRST LETTER IS A OR B
          NZ     B6,YDEFSYM4 IF FIRST LETTER IS NOT X 
          AX1    48          CHECK ON SECOND LETTER 
          IX2    X1-X2
          SB7    X2-1R0 
          SB6    X2-1R8 
          SX5    X2-1R. 
          SA1    A6          RECLAIM RIGHT-JUSTIFIED SYMBOL 
          MX0    48 
          NG     B7,YDEFSYM4
          PL     B6,YDEFSYM3 IF 2ND CHAR NOT 0-7
          BX5    X0*X1
 YDEFSYM3 NZ     X5,YDEFSYM4 IF MORE THAN 2 CHARS OR 2ND CHAR NOT *.* 
          SX6    B1 
          SA6    EFLG        COMPLAIN ABOUT REGISTER SYMBOL 
          SA6    W1ERR
 YDEFSYM4 SA1    YDEFSYMT 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          NZ     X3,YDEFSYM5 IF FOUND 
 YDS4     SA2    YDEFSYMT+1 
          RJ     ENTSYMT     ENTER SYMBOL 
          MX6    0
          EQ     YDEFSYM
 YDEFSYM5 SX0    X3-1        CHECK QUALIFIER VALUE
          RX4    X0 
          BX6    X4-X5
          NZ     X6,YDS4     IF NOT SAME QUALIFIER
          LX2    59-30
          NG     X2,YDS5     IF DEFINED 
          LX2    30-59
          SA4    YDEFSYMT+1 
          MX5    28 
          BX6    X5*X2
          BX6    X6+X4       STORE VALUE
          WX6    X3 
          MX6    0
          EQ     YDEFSYM
 YDS5     LX2    30-33
          NG     X2,YDEFSYM6 IF REDEFINABLE SYMBOL
 YDEFSYM7 SA4    YDEFSYMT+1 
          SA5    =137777777777B 
          LX2    33-59
          BX6    X2-X4
          BX5    X5*X6
          SX6    B1 
          ZR     X5,YDEFSYM  EXIT IF NEW VALUE EQUALS OLD 
          SA6    DERR 
          SA6    EFLG 
          EQ     YDEFSYM
 YDEFSYM6 SA4    YDEFSYMT+1  OLD SYMBOL IS REDEFINABLE, CHECK NEW       P054   7
          RX5    X3 
          LX4    59-33                                                  P054   9
          PL     X4,YDEFSYM7 IF NOT ALSO REDEFINABLE                    P054  10
          MX0    25          RESET DEFINITION 
          LX4    33-59       RESTORE NEW VALUE                          P054  13
          BX6    X0*X5                                                  P054  14
          BX6    X6+X4                                                  P054  15
          WX6    X3 
          MX6    0
          EQ     YDEFSYM
 YDEFSYM2 SX6    B1          COMPLAIN ABOUT BAD LOCATION SYMBOL 
          SA6    EFLG 
          SA6    W1ERR
          EQ     YDEFSYM
  
 YDEFSYMT BSS    2
 YEVITEM  SPACE  4
**        YEVITEM - EVALUATE ITEM.
*         MANY ERRORS NOTED HERE. 
*         ENTRY  (X1) = FIELD LENGTH. 
*         EXIT   (ELVAL) = VALUE. 
*                (ELREL) = RELOCATION.
*                (ELEXT) = EXTERNAL NUMBER. 
*                (ELREG) = REGISTER.
  
  
 YEVITEM  PS                 RETURN EXIT
          BX6    X1          SAVE FIELD LENGTH
          SA6    YEVITFL
          MX6    0
          BX7    X7-X7
          SA6    ELVAL       CLEAR OUT REPLY CELLS
          SA7    A6+B1
          SA6    A7+B1
          SA7    A6+B1
          SA1    YEVITEMN    SET EXIT SWITCH FOR NORMAL EXIT
          BX6    X1 
          SA6    YEVITEMS 
          SA1    CHAR 
          SA2    MACHINE
          SB7    X1-3 
          NZ     X2,YEVIT10  JUMP IF PP TO IGNORE REGISTER CHECKS 
          NG     B7,YEVIT500 IF FIRST LETTER IS A OR B
          SB7    X1-1RX 
          EQ     B7,YEVIT500 IF FIRST LETTER IS X 
 YEVIT10  SB7    X1-1RZ-1 
          NG     B7,YEVIT21  JUMP IF LETTER 
          SB7    X1-1R9-1 
          NG     B7,YEVIT100 IF DIGIT 
          SB7    X1-1R/ 
          ZR     B7,YEVIT300 IF SLASH 
          SB7    X1-1R= 
          ZR     B7,YEVIT400 IF EQUALS SIGN 
          SB7    X1-1R* 
          ZR     B7,YEVIT200 IF ASTERISK
          SB7    X1-1R$ 
          EQ     B7,YEVIT250 IF DOLLAR SIGN 
  
*         ALPHABETIC CHARACTER LEADS THE ELEMENT. 
  
 YEVIT21  RJ     SCITEM 
 YEVIT22  BX1    X6 
          ZR     X1,YEVITER  COMPLAIN ABOUT EMPTY SYMBOL
          RJ     YTLUSYM     LOOK UP SYMBOL 
          EQ     YEVITEMS    AND GO TO EXIT SWITCH
  
*         ASTERISK. 
  
 YEVIT200 RJ     SCITEM 
          SB7    X6-1R* 
          SB6    X6-2R*L
          SB5    X6-2R*O
          ZR     B7,YEVIT210 IF ASTERISK
          ZR     B6,YEVIT210 IF *L
          ZR     B5,YEVIT220 IF *O
          SB7    X6-2R*P
          SB6    X6-2R*F
          ZR     B7,YEVIT230 IF *P
          ZR     B6,YEVIT240 IF *F
  
*         ERROR IN ITEM.
  
 YEVITER  SX6    B1          NOTE ERROR 
          SA6    AERR 
          SA6    EFLG 
          SA6    EXERR
          EQ     YEVITEMS 
  
*         * OR *L ELEMENT.
  
 YEVIT210 SA2    LOCCTR 
 YEVIT211 SA3    A2+B1
          BX6    X2 
          LX7    X3 
 YEVIT212 SA6    ELVAL
          SA7    A6+B1
          EQ     YEVITEMS 
  
*         *O ELEMENT. 
  
 YEVIT220 SA2    ORGCTR 
          EQ     YEVIT211 
  
*         *P ELEMENT. 
  
 YEVIT230 SA2    POSCTR 
 YEVIT231 BX6    X2 
          MX7    0
          EQ     YEVIT212 
  
*         *F ELEMENT. 
  
 YEVIT240 SA2    FMODE
          EQ     YEVIT231 
  
*         DOLLAR SIGN.
  
 YEVIT250 RJ     SCITEM      CHECK THAT ELEMENT IS ONLY DOLLAR SIGN 
          SA1    PPTYPE 
          SX1    X1+B1
          ZR     X1,YEVIT210 IF BCU ASSEMBLY
          SB7    X6-1R$ 
          SA2    POSCTR 
          NZ     X2,YEVITOK  EXIT IF STILL IN THIS WORD 
          RJ     YFOUP       RESET POSCTR 
          SA2    POSCTR 
 YEVITOK  SX6    X2-1 
          MX7    0
          ZR     B7,YEVIT212
          EQ     YEVITER
  
*         SLASH ELEMENT.
  
 YEVIT300 RJ     GETCH
          SA2    CHAR        CHECK NEXT CHARACTER 
          SX1    X2-1R/ 
          ZR     X1,YEVIT303 IF */* 
          RJ     SCITEM      SCAN OFF NAME OF ATTRIBUTE 
          SB7    X1-1R/      MAKE SURE IT ENDED ON A SLASH
          NZ     B7,YEVIT301
          BX1    X6 
 YEVIT303 RJ     SQV         SET QUAL VALUE 
          RJ     GETCH       THROW AWAY TERMINAL /
          RJ     SCITEM 
          BX1    X6 
          ZR     X6,YEVIT302 IF NO SYMBOL 
          RJ     YTLUSYM
          SA1    QVAL+1      RESET QVAL 
          BX6    X1 
          SA6    A1-B1
          ZR     X3,YEVITEMS IF NOT DEFINED 
          SX0    X3-1 
          RX1    X0 
          BX6    X5-X1
          ZR     X6,YEVITEMS IF THE SAME QUALIFIER
          SX6    B1          SET UNDEFINED ERROR
          MX7    0
          SA7    ELVAL
          SA7    A7+B1       ELREL
          SA7    A7+B1       ELEXT
          SA1    IFDF 
          NZ     X1,YEVIT304  IF IF DEF/EXT/REG 
          SA6    UERR 
          SA6    EFLG        SET UNDEFINED ERROR
          SA6    EXERR
          EQ     YEVITEMS 
 YEVIT304 SX6    B1+B1       IFDF = 2 
          SA6    A1 
          EQ     YEVITEMS 
 YEVIT302 SA1    QVAL+1 
          BX6    X1 
          SA6    A1-B1
 YEVIT301 SX6    B1          COMPLAIN 
          SA6    AERR 
          SA6    EFLG 
          SA6    EXERR
          EQ     YEVITEMS 
  
*         EQUALS SIGN.
  
 YEVIT400 RJ     GETCH
          SB7    X1-1RS      CHECK FOR SYMBOL LITERAL 
          SB6    X1-1RX 
          ZR     B7,YEVIT420
          ZR     B6,YEVIT430 IF =X FORMAT 
          SX2    VALUES      SCAN NUMERIC (CHARACTER) LITERAL 
          EQ     B6,B1,YEVIT435  IF =Y FORMAT 
          SX3    NLITS
          SX4    -B1
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM 
          ZR     X3,YEVITER  ERROR IF 0-LENGTH DATA 
          SX2    VALUES 
          RJ     YTLULIT     LOOK UP LITERAL
          MX0    39 
          BX6    -X0*X3 
          AX3    24 
          BX7    X3 
          SA6    ELVAL
          SA7    ELREL
          EQ     YEVITEMS 
  
*         SYMBOL LITERAL. 
  
 YEVIT420 RJ     GETCH       THROW AWAY S 
          SX7    B1 
 YEVIT423 LX7    -3 
          SA7    ELVAL       SAVE LITERAL TYPE FLAG 
          RJ     SCITEM      FETCH SYMBOL 
          ZR     X6,YEVIT301 COMPLAIN IF EMPTY SYMBOL 
          SA1    QVAL 
          BX6    X1+X6
          SA2    O.SLITS     SEARCH SYMBOL LITERALS 
          SA3    L.SLITS
          SB7    X3-1 
          ZR     X3,YEVIT422 IF SLITS TABLE EMPTY 
          MX0    3
          SA5    X2+B7       FETCH SYMBOL 
          BX4    -X0*X5      MASK OUT TYPE FLAGS
 YEVIT421 BX7    X6-X4       CHECK FOR SYMBOL ALREADY IN
          SA5    A5-B1
          SB7    B7-B1
          BX4    -X0*X5      EXTRACT NAME 
          ZR     X7,YEVIT424 IF NAME FOUND
          PL     B7,YEVIT421 KEEP LOOKING 
 YEVIT422 SA2    ELVAL
          BX1    X6+X2
          ADDWORD SLITS 
          MX4    12 
          BX6    -X4*X6 
          EQ     YEVIT22
  
 YEVIT424 SA5    A5+B1       RECLAIM SYMBOL 
          SA4    ELVAL       AND TYPE MASK
          BX7    X5+X4       OR TYPE MASKS TOGETHER 
          SA7    A5 
          EQ     YEVIT22
  
*         EXTERNAL LITERAL. 
  
 YEVIT430 RJ     GETCH
          SA5    MACHINE
          NZ     X5,YEVIT21 
          SX7    B1+B1
          EQ     YEVIT423 
  
 YEVIT435 RJ     GETCH       THROW AWAY *Y* 
          SA5    MACHINE
          NZ     X5,YEVIT21  IF PPU ASSEMBLY
          SX7    B0 
          EQ     YEVIT423    GO PROCESS SYMBOL LITERAL
  
*         NUMERIC ELEMENT.
  
 YEVIT100 SX2    ELVAL
          SX3    B1 
          SX4    B1 
          SA5    YEVITFL
          RJ     SCD         SCAN DATA ITEM 
 YEVITEMS SA1    CHAR        EXIT SWITCH
          EQ     YEVITEM
          SA1    CHAR 
          EQ     YEVIT10
  
*         SUSPECTED REGISTER NAME.
  
 YEVIT500 SA1    COLUMN 
          SA1    X1+CARD-1
          SA2    A1+B1       FETCH NEXT COLUMN
          SB7    X2-1R. 
          ZR     B7,YEVIT530 JUMP IF PERIOD 
          SB7    X2-1R0 
          NG     B7,YEVIT21 
          SB7    X2-1R8 
          PL     B7,YEVIT21 
          SA3    A2+B1
          SX4    3036B
          LX4    36 
          SB7    X3 
          AX5    X4,B7
          LX5    59 
          PL     X5,YEVIT21 
          SX4    X1 
          LX4    3
          RJ     GETCH
          SX5    X6-1R0 
          BX6    X5+X4
          SA6    ELREG       STORE REGISTER VALUE AND TYPE
          MX7    60 
          SA7    ELVAL       MAKE ELEMENT VALUE MINUS VERO
          RJ     GETCH
          EQ     YEVITEM
 YEVIT530 LX1    3
          BX6    X1 
          SA6    ELREG
          RJ     GETCH
          RJ     GETCH
          RJ     YEVITEMS    SET EXIT SWITCH TO EVALUATE REG. NO. 
          SA2    ELVAL
          SA3    A2+B1       ELREL
          SA4    A3+B1       ELEXT
          BX5    X3+X4
          SA3    EXERR
          IX5    X5+X3
          NZ     X5,YEVIT550 COMPLAIN IF NOT ABSOLUTE 
          SX7    7
          BX6    X7*X2
          MX7    60 
          SA7    A2 
          SA2    A4+B1       ELREG
          IX6    X2+X6
          SA6    A2 
          EQ     YEVITEMN 
 YEVIT550 SX6    B1 
          SA6    A3 
          SA6    AERR 
          SA6    EFLG 
 YEVITEMN SA1    CHAR 
          EQ     YEVITEM
  
 YEVITFL  DATA   0
 YFOUP    SPACE  4
**        YFOUP - FORCE UPPER.
  
  
 YFOUP    PS                 RETURN EXIT
          MX6    0
          SA1    POSCTR      TEST FOR BEING IN UPPER POSITION 
          SA2    LWORD
          IX3    X1-X2
          SA6    NFOUP       CLEAR FORCE-NEXT-UPPER FLAG
          ZR     X3,YFOUP    JUMP IF IN UPPER 
          BX6    X2 
          SX0    B1 
          SA6    A1          SET POSCTR TO WORD SIZE (12, 16, OR 60)
          SA1    ORGCTR      SET ORIGIN AND POSITION COUNTERS 
          IX6    X1+X0
          SA2    LOCCTR 
          IX7    X2+X0
          SA6    A1 
          SA7    A2 
          EQ     YFOUP
 YFUALL   SPACE  4
**        YFUALL - FORCE UPPER ON ALL BLOCKS. 
*         ALSO CREATES FLAG TO HAVE CURRENT BLOCK NUMBER IN HIGH
*         36 BITS, AND THE BASE USE IN THE LOW 24.
  
  
 YFU1     SA5    X2+B1
          BX4    X7*X5
          IX6    X3-X4
          SX2    X2+B5
 +        SB6    B6-B5
          ZR     X6,*+1 
          IX5    X5+X1
 +        BX4    -X0*X5 
          IX6    X4+X3
          SA6    A5 
          NZ     B6,YFU1
          SA1    ORGCTR+1    CONSTRUCT FLAG FOR INTERMEDIATE
 +        NZ     X1,*+1 
          SA1    UI+1 
          SA2    UI+1 
          LX1    24 
          BX6    X1+X2
          SA6    FLAG 
  
 YFUALL   PS                 RETURN EXIT
          RJ     YFOUP       BIND OFF CURRENT BLOCK 
          SA1    ORGCTR 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    LOCCTR 
          SA7    A6+B1
          SA2    O.USETAB 
          SA1    L.USETAB 
          SA3    UI 
          IX2    X2+X3
          IX1    X1-X3
          SA3    LWORD
          MX0    39 
          SB6    X1 
          MX7    6
          SB5    4
          LX3    24 
          SX1    B1 
          LX7    30 
          EQ     YFU1 
 YPRLOC   SPACE  4
**        YPRLOC - PROCESS LOCATION TERM AND MAKE ROOM FOR INSTRUCTION. 
*         ENTRY  (X1) = LENGTH OF INSTRUCTION.
  
  
 YPRLOC4  MX6    0           CLEAR FORCE UPPER
          SA6    NFOUP
  
 YPRLOC   PS                 RETURN EXIT
          SA2    POSCTR      ROUND TO NEAREST QUARTER WORD
          SA3    MACHINE     OR TO PP WORD BOUNDARY 
          SA4    LWORD
          PX0    X2 
          NZ     X3,YPRLOC1  JUMP IF PP 
          SA4    =0.067P48
          SA5    =15.0P0
          FX0    X0*X4
          DX4    X0*X5
          UX6    X4,B7
          EQ     YPRLOC2
 YPRLOC1  IX4    X2-X4
          SB7    X4 
          BX6    X2 
          ZR     B7,YPRLOC2 
          MX6    0
 YPRLOC2  SA6    A2          RESET POSITION COUNTER 
          BX7    X1          INCREMENT COUNT
          SA7    YPRLOCT     SAVE IT
 +        NZ     X6,*+1      FORCE UPPER IF AT BOTTOM OF WORD 
          RJ     YFOUP
          SA1    YPRLOCT
          SA2    POSCTR 
          IX6    X2-X1
 +        PL     X6,*+1 
          RJ     YFOUP       IF INSTRUCTION LENGTH DEMANDS IT 
          SA1    LOCSYM 
          SB7    X1-1R- 
          ZR     B7,YPRLOC4  IF LOCSYM MINUS
          SA2    NFOUP       CHECK NOMINAL FORCING
          BX1    X2+X1
 +        ZR     X1,*+1 
          RJ     YFOUP       IF NOMINAL FORCE OR LOCATION FIELD 
          SA1    LOCSYM 
          SB7    X1-1R+ 
          ZR     B7,YPRLOC
          NZ     X1,YPRLOC3 
          PL     X1,YPRLOC   IF LOCSYM PLUS ZERO
 YPRLOC3  SA2    LOCCTR      DEFINE THE LOCATION SYMBOL 
          SA3    A2+B1
          BX4    X4-X4
          SA5    LIBFLG 
          LX5    1
          RJ     YDEFLOC
          EQ     YPRLOC      AND EXIT 
  
 YPRLOCT  DATA   0           TEMPORARY STORAGE
 YTLULIT  SPACE  4
**        YTLULIT - LOOK UP LITERAL AND ENTER INTO TABLE. 
*         ENTRY  (X2) = ORIGIN OF VALUES. 
*                (X3) = COUNT OF VALUES.
*         EXIT   (X3) = RELOCATED EQUIVALENT. 
  
  
 YTLULIT  PS                 RETURN EXIT
          SB7    X2 
          SB6    X3 
          SA1    L.LITAB
          SA2    LI          LITERAL INDEX
          IX1    X1-X2
          ZR     X1,YTLIT20  IF LITERAL TABLE IS EMPTY
          SB5    X1 
          SB4    B0 
          SA1    O.LITAB
          IX1    X1+X2
          SA0    X1 
 YTLIT1   SA1    B7          FETCH FIRST VALUE
          SA2    A0+B4
          BX3    X1-X2
          NG     X3,YTLIT10 
          NZ     X3,YTLIT10  IF NO MATCH FOUND
          SB3    B0 
 YTLIT2   SB2    B3+B4
          GE     B2,B5,YTLIT20
          SA2    A0+B2
          SA1    B7+B3
          BX3    X1-X2
          NG     X3,YTLIT10 
          NZ     X3,YTLIT10 
          SB3    B3+B1
          NE     B3,B6,YTLIT2 
          SX3    B4 
          EQ     YTLIT6      MATCH FOUND
 YTLIT10  SB4    B4+B1       INDEX
          NE     B4,B5,YTLIT1 
 YTLIT20  SX1    B6          SAVE PARAMETERS
          SX6    B7 
          LX1    18 
          IX6    X1+X6
          SA6    YTLITT 
          MANAGE LITAB,B6    AUGMENT LITERAL TABLE
          SA1    YTLITT      MOVE DATA
          IX3    X2+X3
          SB7    X1 
          AX1    18 
          SB6    X1 
          IX3    X3-X1
          SX2    B7 
          RJ     MOVE 
          SA1    L.LITAB
          SA2    LWORD
          SA3    O.USETAB 
          SA4    UI          USE INDEX
          SA5    LI          LITERAL INDEX
          IX3    X3+X4
          IX1    X1-X5
          LX2    24 
          BX6    X2+X1
          SA6    X3+2*4+1    STORE LWORD, LENGTH IN LITS BLOCK
          SX0    B6 
          IX3    X1-X0
 YTLIT6   SA4    UI+1        USE INDEX
          SX4    X4+2 
          LX4    24 
          BX3    X4+X3
          EQ     YTLULIT
  
 YTLITT   DATA   0           TEMPORARY STORAGE
 YTLUSYM  SPACE  4
**        YTLUSYM - EVALUATE SYMBOL.
*         UERR SET IF NOT IN TABLE. 
*         ENTRY  (X1) = SYMBOL. 
*         EXIT   ELVAL = VALUE. 
*                ELREL = RELOCATION.
*                ELEXT = EXTERNAL NUMBER. 
*                (X3) = LOCATION OF EQUIVALENT. 
*                (X5) = SYMBOL WITH QUALIFIER.
  
  
 YTLUSYM2 LX2    2
          PL     X2,YTLUSYM  IF + RELOC OR ABS
          SA2    ELVAL       COMPLEMENT VALUE 
          BX6    -X2
          SA6    A2 
  
 YTLUSYM  PS                 RETURN EXIT
          RJ     TLUSYMT
          LX2    29 
          NG     X2,YTLUSYM1 JUMP IF DEFINED
          SX7    B1 
          SA1    IFDF 
          ZR     X1,YTLUSYM3  IF NOT IF DEF/EXT/REG 
          SX6    B1+B1
          SA6    A1          IFDF = 2 
          EQ     YTLUSYM4 
 YTLUSYM3 SA7    UERR        SET UNDEFINED ERROR
          SA7    EFLG 
          SA7    EXERR
 YTLUSYM4 MX7    0
          SX6    B0 
          SA7    ELVAL
          SA6    A7+B1       ELREL
          SA7    A6+B1       ELEXT
          EQ     YTLUSYM
 YTLUSYM1 LX2    10          SIGN EXTEND VALUE
          AX2    39 
          BX6    X2 
          RX2    X3 
          SX0    777B 
          SA6    ELVAL
          AX2    21 
          BX6    X0*X2
          LX2    49 
          SA6    A6+B1       ELREL
          MX7    0
          SA7    A6+B1       ELEXT
          PL     X2,YTLUSYM2 IF NOT EXTERNAL
          SA6    A7          RESET EXTERNAL NUMBER
          SA7    A7-B1       ELREL
          EQ     YTLUSYM
 YUPLOC   SPACE  4
**        YUPLOC - UPDATE LOCATION COUNTERS.
*         ENTRY  (X1) = INCREMENT TO ORGCTR AND LOCCTR. 
  
  
 YUPLOC   PS                 RETURN EXIT
          SA2    ORGCTR 
          SA3    LOCCTR 
          IX6    X2+X1
          IX7    X3+X1
          SA6    A2 
          SA7    A3 
          EQ     YUPLOC 
 AEI      TITLE  PASS 2 SUBROUTINES.
**        AEI - ADVANCE ENTRY INDEX.
*         ENTRY  (SI) = SEGTAB INDEX. 
*         EXIT   (UI) = USETAB INDEX. 
*                (UI+1) = FIRST BLOCK NUMBER WITHIN BLOCK GROUP.
*                (EI) = EPTAB INDEX.
*                (EI+1) = LWA EPTAB.
*                (LI) = LITAB INDEX.
*                (LI+1) = LWA LITAB.
*                (DI) = SLITS INDEX.
*                (DI+1) = LWA SLITS.
  
  
          SEG    PASS 2 SUBROUTINES.
          QUAL   PASS2
 AEI      PS                 RETURN EXIT
          SA1    O.SEGTAB 
          SA2    SI 
          IX1    X1+X2
          SA1    X1+B1       SEGTAB(2)
          AX1    18 
          BX6    X1 
          AX1    2
          SX7    X1+B1
          SA6    UI 
          SA7    A6+B1
          SA1    A1+B1       SEGTAB(3)
          SA2    A1+B1       SEGTAB(4)
          SX6    X1 
          SX7    X2 
          SA6    LI 
          SA7    A6+B1
          AX1    18 
          AX2    18 
          SX6    X1 
          SX7    X2 
          SA6    EI 
          SA7    A6+B1
          AX1    18 
          AX2    18 
          SX6    X1 
          SX7    X2 
          SA6    DI 
          SA7    A6+B1
          EQ     AEI         RETURN 
 BKS      SPACE  4
**        BKS - BACKSPACE SECTIONS. 
*         BACKSPACE N SECTIONS ON BINARY OUTPUT FILE. 
*         ENTRY  (X4) = NUMBER OF SECTIONS. 
  
  
 BKS      PS                 RETURN EXIT
  
 RM       IFEQ   CP#RM,0
  
          SKIPB  B,X4 
          EQ     BKS         RETURN 
  
 RM       ELSE
  
          SA1    B-1
          ZR     X1,BKS1     IF *W* RECORDS 
          SKIPBL B,X4 
          EQ     BKS         RETURN 
 BKS1     BX6    X4          SAVE SECTION COUNT 
          SA6    BKSA 
          STORE  B,DX=BKS3   SET END OF DATA EXIT 
 BKS2     SKIPBL B,377777B   BACKSPACE MANY RECORDS 
          EQ     BKS2 
 BKS3     PS                 END OF DATA EXIT 
          SA1    BKSA 
          SX6    X1-1        REDUCE SECTION COUNT 
          SA6    A1 
          PL     X6,BKS2     IF NOT DONE
          STORE  B,DX=0 
          FETCH  B,FP,X1     CHECK TERMINATOR 
          SX6    X1-#EOS# 
          NZ     X6,BKS4     IF NOT END OF SECTION
          WEOR   B
          EQ     BKS         RETURN 
 BKS4     SX6    X1-#EOP# 
          NZ     X6,BKS      IF NOT END OF PARTITION
          ENDFILE B                                                     S028 708
          EQ     BKS         RETURN 
  
 BKSA     DATA   0
  
 RM       ENDIF 
 CRL      SPACE  4                                                      S004 116
**        CRL - CHECK RECURSION LIMIT.                                  S004 117
                                                                        S004 118
                                                                        S004 119
 CRL      PS                 RETURN EXIT                                S004 120
          SA1    CRLF                                                   S004 121
          ZR     X1,CRL      IF FLAG NOT SET IN PASS 1                  S004 122
          SA2    ASMM+1                                                 S004 123
          BX6    X2                                                     S004 124
          SA6    CRLB                                                   S004 125
          JOBMSG CRLA        ISSUE DAYFILE MESSAGE                      S004 126
          JP     CRL                                                    S004 127
                                                                        S004 128
 CRLA     DATA   H*  RECURSION DEPTH .GT. "LIMRECUR" IN *               S004 129
 CRLB     DATA   0                                                      S004 130
 ENTREF   SPACE  4
**        ENTREF - PLACE ENTRY IN CROSS REFERENCE TABLE.
*         ENTRY  (X4) = SYMBOL TABLE ADDRESS. 
*                (X1) = SYMBOL USAGE LETTER.
*                (X2) = SYMBOL EQUIVALENT.
  
  
 ENTREF1  SX6    B0          JUST OVERFLOWED
          SA6    L.REFTAB 
  
          IFEQ   CP#RM,0,2
 ENTREF2  WRITEW R,CONREF,1 
          ELSE   1
 ENTREF2  PUTP   R,CONREF,10                                            S028 710
  
 ENTREF   PS     0           RETURN EXIT
          LX2    -35+59 
          NG     X2,ENTREF   IF NOREF SYMBOL
          MX0    -17
          SA2    SUPREF 
          NZ     X2,ENTREF   RETURN IF NO REFERENCE 
          SA2    LPCX        LINE NUMBER
          SA3    A2+B1
          LX2    6           LETTER TO BITS 0 - 5 
          SA5    LOCCTR      LOCATION COUNTER 
          BX6    X1+X2       LINE TO BITS 6 - 12
          LX3    13 
          BX5    -X0*X5 
          BX6    X6+X3       PAGE TO BITS 13 - 24 
          LX5    25 
          BX6    X6+X5       LOCATION TO BITS 25 - 41 
          LX4    42 
          BX6    X6+X4       SYMBOL TABLE ADDRESS TO BITS 42 - 59 
          SA6    CONREF 
          SA1    LOSTREF     ACCUMULATE REFERENCES
          SX6    B1 
          IX6    X6+X1
          SA6    A1 
          SA2    REFIO
          NZ     X2,ENTREF2  IF ON DISK 
          MANAGE REFTAB,B1
          SA1    REFIO
          NZ     X1,ENTREF1  IF JUST OVERFLOWED 
          SA4    CONREF 
          IX2    X2+X3
          BX6    X4 
          SA6    X2-1 
          EQ     ENTREF      RETURN 
 LLA      SPACE  4
**        LLA - LIST LOCATION ADDRESS.
  
  
 LLA      PS                 RETURN EXIT
          SA1    LOCCTR      CALL PACKO(LOCCTR,14 OR 12,6 OR 4) 
          SX2    14 
          SA3    MACHINE
          LX5    X3,B1
          IX2    X2-X5
          MX3    0
          RJ     PACKO
          SA1    LOCCTR      CHECK IF LOCCTR " ORGCTR 
          SA2    ORGCTR 
          BX3    X1-X2
          ZR     X3,LLA      IF COUNTERS ARE EQUAL
          SX6    1RL         LIST AN L
          SA6    OCTAL+6
          EQ     LLA         RETURN 
 PACKOR   SPACE  4
**        PACKOR - PACK OCTAL DIGITS AND RELOCATION INDICATION. 
*         PACKS RELOCATION INFORMATION IN COLUMN (X2) + 2.
*         ENTRY  (X1) = VALUE.
*                (X2) = LOW-ORDER COLUMN NUMBER.
*                (X3) = COLUMN COUNT. 
*                (EXREL) = RELOCATION INFORMATION.
*                (EXEXT) = RELOCATION INFORMATION.
  
  
 PACKOR1  SA6    X2+OCTAL+1  STORE RELOCATION INDICATOR 
          RJ     PACKO       AND GO TO PACK OCTAL DIGTIS
  
 PACKOR   PS                 RETURN EXIT
          SA5    EXEXT       CHECK TYPE OF RELOCATION 
          SA4    EXREL
          SX6    1RX
          NZ     X5,PACKOR1  IF EXTERNAL
          SB7    X4-1 
          SX6    1R 
          ZR     X4,PACKOR1  IF ABSLUTE 
          SX6    1R+
          ZR     B7,PACKOR1  IF PROGRAM 
          SB7    X4-401B
          SX6    1RC
          NZ     B7,PACKOR1  IF COMMON
          SX6    1R-
          EQ     PACKOR1     IF NEGATIVE PROGRAM
 PBN      SPACE  4
**        PBN - PRINT BLOCK NAMES.
*         ENTRY  (SI) = SEGTAB INDEX. 
*         USES   P2TEMP, P2TEMPA, P2TEMPB.
  
  
 PBN      PS                 RETURN EXIT
          SA1    O.SEGTAB    SET UP USE INDEX 
          SA2    SI 
          SA3    L.SEGTAB 
          BX6    X3-X2
          IX2    X1+X2
          SA1    X2-3        SEGTAB(2)
          SA3    L.USETAB 
          AX1    18 
          MX0    -21
          ZR     X6,PBN1
          SA3    X2+B1       NEXT SEGTAB(2) 
          AX3    18 
 PBN1     BX6    X1 
          LX7    X3 
          SA6    P2TEMP      BLOCK COUNTER FOR FOLLOWING LOOP 
          SA6    A6+B1
          SA7    A6+B1
          IX3    X7-X6
          SX1    X3-3*4 
          NZ     X1,PBN2     IF MORE THAN 3 BLOCKS
          SA2    O.USETAB 
          IX2    X2+X6       CHECK BLOCK LENGTHS
          SA1    X2+2*4+1    LITERALS*(2) 
          BX6    -X0*X1 
          NZ     X6,PBN2     IF LITERALS* NOT EMPTY 
          SA1    X2+4+1      PROGRAM*(2)
          BX6    -X0*X1 
          ZR     X6,PBN      IF PROGRAM* EMPTY
          SA1    X2+B1
          BX6    -X0*X1 
          ZR     X6,PBN      IF ABSOLUTE* EMPTY 
 PBN2     SX0    2
          RJ     LBL
          SA1    =40HBLOCKS    TYPE      ADDRESS    LENGTH
          SA2    A1+B1       LIST OUT BLOCK LENGTHS AND ORIGINS 
          BX6    X1 
          LX7    X2 
          SA6    LINE 
          SA7    A6+B1
          SA1    A2+B1
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    A7+B1
          SA7    A6+B1
          RJ     LIST2L 
  
*         PRINT USE BLOCKS. 
  
 PBN3     SA1    O.USETAB 
          SA2    P2TEMPA
          IX0    X1+X2
          SA1    X0          FETCH BLOCK NAME 
          SX7    1R 
          BX5    X1          COMPLEMENT NAME IF LCM 
          AX5    60 
          BX1    X1-X5
          NZ     X1,PBN4     CHANGE BLANK COMMON BLOCK NAME 
          SX1    2R// 
 PBN4     SA3    A1+2        BLOCK ORIGIN 
          MX6    6
 PBN5     LX1    6           LEFT JUSTIFY BLOCK NAME
          BX4    X6*X1
          BX1    X7+X1
          ZR     X4,PBN5
          BX6    X1 
          MX0    -9 
          PL     X5,PBN6     IF NOT LCM 
          SX1    1R+-1R 
          SA4    ABSFG
          SA5    LLB
          IX6    X6+X1       APPEND + BEFORE BLOCK TYPE 
          LX4    24 
          BX5    X4+X5
          BX4    X5-X3
          AX4    24 
          BX4    -X0*X4 
          NZ     X4,PBN6     IF NOT LOCAL LCM BLOCK IN REL ASSEMBLY 
          SA5    =10HLOCAL
          EQ     PBN7 
 PBN6     BX5    X3 
          AX5    24 
          BX2    -X0*X5 
          SB7    X2 
          SA5    =10HCOMMON 
          GT     B7,B1,PBN7 
          SA5    B7+=20HABSOLUTE  LOCAL 
 PBN7     SA6    LINE        STORE BLOCK NAME 
          BX6    X5 
          SA6    A6+B1       STORE BLOCK TYPE 
          MX0    -21         PACK AWAY BLOCK LENGTHS AND ORIGINS
          BX1    -X0*X3 
          SA2    A1+B1
          BX5    -X0*X2 
          RJ     CONOCT      LIST FIRST WORD ADDRESS
          LX6    18 
          BX1    X5          LIST LENGTH
          SA6    LINE+2 
          RJ     CONOCT 
          LX6    18 
          SA6    LINE+3 
          SA4    P2TEMPA     LIST LINE IF LENGTH IS NON-ZERO
          SA1    A4-B1
          IX4    X4-X1
          SB7    X4-2*4-1    OR BEYOND OUR 3 BLOCKS 
          PL     B7,PBN8
          ZR     X5,PBN9     IF LENGTH = 0
 PBN8     RJ     LISTL
 PBN9     SA2    P2TEMPA     INCREMENT INDEX
          SA3    A2+B1
          SX6    X2+4 
          SA6    A2 
          BX3    X6-X3
          NZ     X3,PBN3     LOOP 
          SA1    =1H
          BX6    X1 
          SA6    LINE 
          SA6    A6+B1
          SA6    A6+B1
          SA6    A6+B1
          EQ     PBN         RETURN 
 PEP      SPACE  4
**        PEP - PRINT ENTRY POINTS. 
*         ENTRY  (EI - EI+1) = EPTAB INDEX. 
  
  
 PEP      PS                 RETURN EXIT
          SA1    EI 
          SA2    A1+B1
          IX1    X2-X1
          ZR     X1,PEP      IF NO ENTRY POINTS 
          SX6    X1+2 
          SX3    3           COMPUTE NUMBER OF ROWS 
          IX6    X6/X3
          SA6    P2TEMP      NUMBER OF ROWS 
          SA6    A6+B1       LINE INCREMENT 
          SX0    2
          RJ     LBL
          SA1    =H*ENTRY POINTS.*
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    LINE 
          SA7    A6+B1
          RJ     LIST2L 
 PEP1     SA1    P2TEMP      DECREMENT ROW COUNT
          SX6    X1-1 
          SA6    A1 
          ZR     X1,PEP      IF END OF TABLE
          SA1    EI          ADVANCE ENTRY INDEX
          SX6    X1+B1
          SA6    A1 
          BX7    X1 
          SA7    P2TEMPC
          MX6    0           LINE INDEX 
          SA6    A7-B1
 PEP2     SA2    P2TEMPC     READ ENTRY ADDRESS 
          SA1    O.EPTAB
          IX2    X1+X2
          SA1    X2          READ ENTRY 
          MX0    1
          BX1    -X0*X1      CLEAR CONDITIONAL FLAG 
          RJ     LJUST
          SA1    A1          FETCH SYMBOL AGAIN 
          MX5    1
          SA3    P2TEMPB     ROW INDEX
          PL     X1,PEP2A    IF NOT CONDITIONAL 
          SX0    1R*-1R 
          BX1    -X5*X1 
          IX6    X6+X0
 PEP2A    SA6    LINE+X3     STORE NAME 
          MX7    0
          SA7    EXERR
          RJ     ZTLUSYM     LOOK UP SYMBOL 
          MX6    0
          SA6    UERR 
          SA1    ELVAL       ERROR IF EXTERNAL OR NEGATIVE
          SA3    =20H ******* 
          SA4    A3+B1
          BX6    X3 
          SA2    ELEXT
          SA3    EXERR       CHECK EXPRESSION ERROR 
          SA5    ELREL
          BX2    X3+X2
          NZ     X2,PEP4     IF BAD ENTRY POINT 
          SX7    X5-401B
          MI     X7,PEP2B    IF +RELOCATION 
          NZ     X7,PEP4     IF -COMMON RELOCATION
          BX1    -X1
  
 PEP2B    RJ     CONOCT      CONVERT TO OCTAL 
          SA4    =10R 
          SA1    ELREL
          LX6    12 
          ZR     X1,PEP4     IF ABSOLUTE
          SA3    LLB
          SX7    X1-401B
          SX0    1R+-1R 
          SX2    X1-1 
          NZ     X7,PEP2C    IF NOT NEGATIVE PROGRAM RELOCATION 
          SX0    1R--1R 
          SX2    B0 
 PEP2C    LX0    6
          IX6    X6+X0       APPEND + OR - AFTER VALUE
          LX1    24 
          BX3    X3-X1
          ZR     X2,PEP4     IF LOCAL SCM 
          NZ     X3,PEP3     IF NOT LOCAL LCM 
          LX0    60-12
          IX6    X6+X0       APPEND + BEFORE VALUE
          EQ     PEP4 
 PEP3     SA3    O.USETAB    COMMON, GET BLOCK NAME AND TYPE
          SA2    UI 
          IX3    X2+X3       BASE ADDRESS OF BLOCK GROUP
          SA2    X3+2 
          SX4    1R/-1R      APPEND / AFTER + AFTER VALUE 
          MX5    -9 
          IX6    X6+X4
          LX5    24 
 PEP3A    BX3    -X5*X2      SEARCH USE TABLE FOR BLOCK 
          IX7    X3-X1       WITH MATCHING RELOCATION 
          SA2    A2+4 
          NZ     X7,PEP3A 
          SA1    A2-6        GET BLOCK NAME 
          LX0    60-12
          BX7    X1 
          SX4    1R/
          AX7    59 
          BX1    X1-X7       UNCOMPLEMENT BLOCK NAME IF LCM 
          BX0    X0*X7
          LX1    6
          IX6    X6+X0       APPEND + BEFORE VALUE IF LCM 
          BX1    X1+X4       APPEND / AFTER BLOCK NAME
          SA6    ELEXT
          RJ     LJUST       LEFT JUSTIFY BLOCK NAME
          SA1    ELEXT
          BX4    X6 
          LX6    X1 
 PEP4     SA3    P2TEMPB
          BX7    X4 
          SA6    LINE+1+X3
          SA7    A6+B1
          SA2    A3-B1       INCREMENT TABLE INDEX
          SA4    A3+B1
          SX6    X3+3        INCREMENT LINE LENGTH
          IX7    X2+X4
          SA6    A3 
          SA7    A4 
          SA2    EI+1 
          IX6    X2-X7
          SB7    X6 
          GT     B7,PEP2     LOOP TO END OF LINE
          RJ     LISTL
          EQ     PEP1        LOOP 
 PES      SPACE  4
**        PES - PRINT EXTERNAL SYMBOLS. 
  
  
 PES      PS                 RETURN EXIT
          SA1    L.EXTAB
          ZR     X1,PES      IF NO EXTERNALS
          SX7    X1+7        COMPUTE NUMBER OF ROWS 
          AX7    3
          SA1    O.EXTAB
          SA7    P2TEMP      ENTRY INCREMENT
          BX6    X1 
          SA6    A7+B1       ENTRY ADDRESS
          SA7    A6+B1       ROW COUNT
          SX0    2
          RJ     LBL
          SA1    =H*EXTERNAL SYMBOLS.*
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    LINE 
          SA7    A6+B1
          RJ     LIST2L 
  
 PES1     SA1    P2TEMPB     DECREMENT ROW COUNT
          SX6    X1-1 
          SA2    A1-B1       ENTRY INDEX
          SA6    A1 
          ZR     X1,PES      RETURN IF ALL ROWS LISTED
          SX6    X2+B1       ADVANCE TABLE
          SA6    A2 
          SA3    A2-B1       SET ENTRY INCREMENT
          SB3    X2 
          SA4    O.EXTAB
          SB4    X4 
          SA4    L.EXTAB
          SB6    X3 
          SB4    X4+B4
          SB5    B0 
 PES2     SA1    B3          LEFT JUSTIFY EXTERNAL NAME 
          MX0    1
          SB3    B3+B6
          BX5    X0*X1       SAVE WEAK-EXT FLAG FROM BIT 59 
          IX1    X1-X5
          RJ     LJUST
          LX5    0-59 
          BX7    X7+X5       INSERT WEAK-EXT FLAG INTO BIT 0
          SA7    A1 
 +        ZR     X5,*+1 
          SX5    2R* -2R     INSERT ASTERISK IF WEAK EXTERNAL 
 +        IX6    X6+X5
          SA6    LINE+B5     STORE NAME 
          SB5    B5+B1
          LT     B3,B4,PES2  LOOP TO END OF LINE
          RJ     LISTL       LIST LINE
          EQ     PES1        LOOP 
 PLM      SPACE  4
**        PLM - PRINT LOAD MAP. 
  
  
 PLM      PS                 RETURN EXIT
          SA1    CP.LISTF 
          SA2    LB+1 
          BX1    X1*X2
          ZR     X1,PLM3     IF NO LIST 
          MX7    0
          SA7    SI          SEGTAB INDEX 
          SA1    =H*        STORAGE ALLOCATION.*
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA1    A2+B1
          SA6    SUBTIT 
          SA7    A6+B1
          BX6    X1 
          SA6    A7+B1
          SX6    B1 
          SA6    SUPREF 
 PLM1     RJ     AEI         ADVANCE EPTAB INDEX
          RJ     PSN         PRINT SEGMENT NAMES
          RJ     PBN         PRINT BLOCK NAMES
          RJ     PEP         PRINT ENTRY POINTS 
          RJ     PES         PRINT EXTERNAL SYMBOLS 
          SA1    L.SEGTAB 
          SA2    SI 
          IX6    X1-X2
          SX6    X6-4 
          ZR     X6,PLM2     IF END OF TABLE
          SX0    4           LIST BLANK LINES 
          RJ     LBL
          EQ     PLM1        LOOP 
 PLM2     SA1    LPCNT       FORCE PAGE EJECT 
          SA2    PSIZE
          IX7    X1+X2
          SA7    A1 
          NZ     X2,PLM5     IF PAGE EJECT NOT SUPPRESSED 
          SX0    4
          RJ     LBL         ELSE PRINT BLANK LINES 
          EQ     PLM5 
  
 PLM3     SA1    O.EXTAB     NO LIST - LEFT JUSTIFY EXTERNAL SYMBOLS
          SA2    L.EXTAB
          SB3    X1 
          SB5    X2 
          ZR     B5,PLM5     IF NO EXTERNAL SYMBOLS 
 PLM4     SA1    B3 
          MX0    1
          SB5    B5-B1
          BX5    X0*X1       SAVE WEAK-EXT FLAG FROM BIT 59 
          IX1    X1-X5
          RJ     LJUST       LEFT JUSTIFY SYMBOL
          LX5    0-59 
          BX7    X7+X5       INSERT WEAK-EXT FLAG INTO BIT 0
          SB3    B3+B1
          SA7    A1 
          NZ     B5,PLM4     LOOP 
  
 PLM5     SA1    =1H         CLEAR SUBTITLE 
          MX7    0           RESET ORGCTR 
          BX6    X1 
          SA7    SI 
          SA7    ORGCTR 
          SA6    SUBTIT 
          SA6    A6+B1
          SA6    A6+B1
          SA7    SEQ
          RJ     AEI         ADVANCE ENTRY INDEX
          SX6    10          RESTORE NUMBER BASE
          SA6    NBASE
          EQ     PLM         RETURN 
 PLO      SPACE  4
**        PLO - PRESET LIST OPTIONS.
  
  
 PLO      PS                 RETURN EXIT
          SA1    CP.LISTF    IF  L = 0
          SA2    LL+1        OR  LIST -L
          SA3    LR+1        OR  LIST -R
          SX6    B1 
          BX4    X1*X6       THEN SET PERMANENT REFERENCE 
          BX5    X2*X3       SUPPRESSION FLAG = 0 
          BX6    X4*X5
          SA6    LXRF 
          SB7    LLISTOPS/2  INITIALIZE LIST OPTIONS
          SA1    LISTOPS
 PLO1     SX6    X1 
          SA6    A1+B1
          SB7    B7-B1
          SA1    A6+B1
          NZ     B7,PLO1     LOOP 
          EQ     PLO         RETURN 
 PLT      SPACE  4
**        PLT - PRINT LITERAL TABLE.
  
  
 PLT      PS                 RETURN EXIT
          SA1    =1H
          SA2    LD+1 
          SA3    LL+1 
          SA4    CP.LISTF 
          BX3    X2*X3
          LX6    X1          CLEAR UNAME
          SA1    O.USETAB 
          SA2    UI 
          IX1    X1+X2
          BX3    X3*X4
          SA1    X1+2*4+2 
          SA2    LPGM 
          AX1    33          LWA OF LITERALS BLOCK
          IX2    X2-X1
          SA6    UNAME
 +        PL     X2,*+1      IF LITERALS BLOCK INSIDE SEGMENT 
          SX3    B1          LIST LITERALS BLOCK IF OUTSIDE SEGMENT 
          ZR     X3,PLT      IF LIST -D OR LIST -L OR L=0 
          RJ     LDL         LIST DEFERRED LINE 
          SA1    =0RLITERALS
          SA2    IND
          BX7    X1 
          SA6    QNAME       CLEAR QNAME
          SA7    SUBNAME     SUBNAME = *LITERALS* 
          ZR     X2,PLT1     IF IND = 0 
          MX6    0
          SB6    ERFLAGS
          SB7    LEFLG-1
          SA6    EFLG 
 +        SA6    B6+B7       CLEAR ERROR FLAGS
          SB7    B7-B1
          PL     B7,* 
          SB7    LIBFLG-NOAS-1
          SA6    LIBFLG 
 +        SB7    B7-B1       CLEAR INDICATORS 
          SA6    A6-B1
          PL     B7,* 
 PLT1     SX6    LINE+9*NCARDS
          MX1    0
          SA6    LLINE
          RJ     SQV         SET BLANK QUALIFIER
          RJ     CUL         CLEAN UP LINE AREA 
          SX6    B1 
          SA6    PLFLG
  
**        LIST SYMBOL LITERALS WHICH COMPASS DEFINED BY DEFAULT.
  
          SA1    DI 
          SA2    A1+B1
          SA3    O.SLITS
          IX2    X2-X1
          ZR     X2,PLT6     IF NO SYMBOL LITERALS
          IX3    X3+X1
          SB7    X2 
          SA1    X3 
 +        NG     X1,PLT2     IF DEFINED BY COMPASS
          SB7    B7-B1
          SA1    A1+B1
          NZ     B7,*-1 
          EQ     PLT6        IF ALL DEFINED BY PROGRAMMER 
 PLT2     RJ     LISTER 
          SX1    4
          SX2    =H+DEFAULT SYMBOLS DEFINED BY COMPASS.+
          SX3    LINE 
          RJ     MOVE 
          RJ     LISTER 
          RJ     LISTER 
 PLT3     SA1    DI          GET NEXT SYMBOL
          SA2    A1+B1
          SA3    O.SLITS
          IX2    X2-X1
          SX6    X1+B1
          IX3    X1+X3
          SA6    A1 
          ZR     X2,PLT5     IF END OF TABLE
          SA1    X3 
          MX0    12 
          PL     X1,PLT3     IF DEFINED BY PROGRAMMER 
          BX1    -X0*X1 
          RJ     LJUST       STORE SYMBOL LEFT JUSTIFIED
          SA6    LINE 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          LX2    59-31
          PL     X2,PLT4     IF NOT EXTERNAL
          LX2    0-21-59+31 
          SA1    O.EXTAB
          MX0    -9          EXTRACT EXTERNAL NUMBER
          BX6    -X0*X2 
          SB7    X1-1 
          SA1    B7+X6       FETCH EXTAB ENTRY (WEAK-EXT FLAG IN BIT 0) 
          LX2    59-31-0+21 
          SX6    1RX+X1      SET *X* OR *Y* 
          SA6    OCTAL+15 
 PLT4     LX2    32 
          BX3    X3-X3
          MX0    -21
          BX1    -X0*X2      VALUE
          SX2    14 
          RJ     PACKO       CALL PACKO (VALUE,14,0)
          RJ     LISTER 
          EQ     PLT3        LOOP 
 PLT5     SA1    LI 
          SA2    A1+B1
          IX2    X2-X1
          ZR     X2,PLT10    IF NO LITERALS 
          EQ     PLT7 
  
**        LIST CONTENT OF LITERALS BLOCK. 
  
 PLT6     SA1    LI 
          SA2    A1+B1
          IX2    X2-X1
          ZR     X2,PLT11    IF NO LITERALS 
 PLT7     RJ     LISTER 
          SX1    3
          SX2    =H+CONTENT OF LITERALS BLOCK.+ 
          SX3    LINE 
          RJ     MOVE 
          RJ     LISTER 
          RJ     LISTER 
          SA1    O.USETAB 
          SA2    UI 
          MX0    -21
          IX1    X1+X2
          SA1    X1+2*4+2 
          BX6    -X0*X1 
          SA6    ORGCTR      ORGCTR = FWA OF LITERALS BLOCK 
 PLT8     SA1    LI 
          SA2    A1+B1
          SA3    O.LITAB
          IX2    X2-X1
          SX6    X1+B1
          IX3    X1+X3
          SA6    A1 
          ZR     X2,PLT10    IF END OF TABLE
          SA5    MACHINE
          SA1    X3 
          MX0    -6 
          SX7    1R 
          MX2    0
 +        ZR     X5,*+1      IF CPU ASSEMBLY
          MX2    -12
 +        BX6    -X2*X1 
          SB7    10 
 +        BX4    -X0*X6 
          NZ     X4,*+1      IF NOT 00 CHARACTER
          BX6    X6+X7
 +        SB7    B7-B1
          LX6    6
          NZ     B7,*-1      LOOP 
          SA4    MACHINE
          SX2    36 
          SX3    20 
          ZR     X4,PLT9     IF CPU ASSEMBLY
          SX2    25 
          SA3    PPBYT
 PLT9     SA6    LINE 
          RJ     PACKO       PACK VALUE 
          SA1    O.USETAB 
          SA2    UI 
          IX1    X1+X2
          SA1    X1+2*4+2 
          AX1    33          LWA OF LITERALS BLOCK
          SA2    LPGM 
          IX2    X2-X1
          SX6    B1 
          SA1    ORGCTR 
          PL     X2,PLT9A    IF LITERALS BLOCK WITHIN SEGMENT 
          SA6    RERR        RANGE ERROR IF LIT BLOCK OUTSIDE SEGMENT 
          SA6    EFLG 
 PLT9A    SA4    MACHINE
          SX2    14 
          MX3    0
          SX6    X1+B1       ADVANCE ORGCTR 
          LX5    X4,B1
          SA6    A1 
          IX2    X2-X5
          RJ     PACKO       PACK LOCATION
          RJ     LISTER 
          EQ     PLT8        LOOP 
  
*         WRAPUP. 
  
 PLT10    RJ     LISTER 
 PLT11    SA1    QVAL+1      RESTORE QUAL VALUE 
          SA2    O.QVTAB
          BX6    X1 
          LX1    12 
          SA6    A1-B1
          SB7    X2-1 
          ZR     X1,PLT12    IF BLANK QUALIFIER 
          SA1    X1+B7       GET QUAL SYMBOL
          MX6    -48
          BX1    -X6*X1 
 PLT12    RJ     LJUST       LEFT JUSTIFY AND 
          SA6    QNAME       STORE WITH BLANK FILL
          SA1    IND
          ZR     X1,PLT15    IF IND = 0 
          SB7    LEFLG-1
          SB6    ERFLAGS+1
          MX0    60-LEFLG 
          SX6    B1 
          BX2    -X0*X1 
          SX5    B1 
          ZR     X2,PLT13    IF NO ERRORS 
          SA6    EFLG 
 PLT13    BX6    X5*X1       RESTORE ERROR FLAGS
          SB7    B7-B1
          LX1    59 
          SA6    B6+B7
          PL     B7,PLT13 
          AX1    30-LEFLG 
          SB7    LIBFLG-NOAS-1
          BX6    X5*X1
          AX1    1
          SA6    LIBFLG 
 PLT14    BX6    X5*X1       RESTORE INDICATORS 
          SB7    B7-B1
          AX1    1
          SA6    A6-B1
          PL     B7,PLT14 
 PLT15    MX6    0           PREPARE TO PRINT *END* OR *IDENT* CARD 
          SA6    DETFLG 
          SA6    PLFLG
          RJ     CPL         CREATE PRINT LINE
 PLT16    MX6    0
          SA6    SUBNAME     CLEAR SUBNAME
          EQ     PLT
 PRS      SPACE  4
**        PRS - PRESET CONSTANTS. 
  
  
 PRS      PS                 RETURN EXIT
          SX7    B1                                                      F4810A 
          SA7    P2TEMPA     INDICATE LINE NUMBER FOR NO HEADER PRINTED  F4810A 
          SX6    B0 
          SB7    LEFLG-1     CLEAR OUT PAGE-RECORD OF ERRORS
          SA6    LSLB 
 PRS1     SB7    B7-B1
          SA6    A6+B1
          NZ     B7,PRS1
          SA2    CP.PAGE
          PL     X2,PRS4     IF PROPAGATING PAGE NUMBERS
          SA3    CP.LISTF 
          ZR     X3,PRS4     IF NO LIST 
          SA2    E
          ZR     X2,PRS4     IF ERROR FILE SAME AS OUTPUT FILE
          SA1    CP.BATCH 
          LX1    59-11
          NG     X1,PRS4     IF COMPASS WAS CALLED BY A COMPILER
                                                                         F4810A 
 RM       IFEQ   CP#RM,0                                                 F4810A 
                                                                         F4810A 
          SX7    B1+B1                                                   F4810A 
          SA7    A7          2 INDICATES LINE COUNT AFTER HEADER PRINTED F4810A 
          SA1    IDNAM       WRITE HEADER 
          RJ     LJUST
          MX0    36 
          SX1    1R*
          BX0    X0*X7
          BX7    X0+X1
          LX7    -6 
          SA7    P2TEMP 
          WRITEW O,A7,1 
          SA1    CP.PAGE
          LX0    X1,B1
          MI     X0,PRS4     FILE ALREADY WRITTEN TO
          MX0    1
          LX0    -1 
          BX7    X1+X0
          SA7    CP.PAGE     SET FIRST WRITING FLAG 
          SA1    FRSTLIN
          ZR     X1,PRS4     IF NO NEED TO RESET PRINTER DENSITY
          WRITEH O,FRSTLIN,1 ELSE RESET PRINTER DENSITY 
  
 RM       ELSE
  
          SX7    B1+B1                                                   F4810A 
          SA7    A7          2 INDICATES LINE COUNT AFTER HEADER PRINTED F4810A 
          SA1    IDNAM       WRITE HEADER 
          RJ     LJUST                                                   F4810A 
          MX0    -6 
          SX1    1R*
          BX0    X0*X6
          BX7    X0+X1
          LX7    -6 
          SA7    P2TEMP 
          PUT    O,P2TEMP,10
          SA1    CP.PAGE
          LX0    X1,B1
          MI     X0,PRS4     FILE ALREADY WRITTEN TO
          MX0    1
          LX0    -1 
          BX7    X1+X0
          SA7    CP.PAGE     SET FIRST WRITING FLAG 
          SA1    FRSTLIN
          ZR     X1,PRS4     IF NO NEED TO RESET PRINTER DENSITY
          PUT    O,FRSTLIN,10  ELSE RESET PRINTER DENSITY 
          MX6    60 
          SA6    FRSTLIN     -0 INDICATES PRINTER HAS BEEN SET
  
 RM       ENDIF 
  
 PRS4     SX2    CLP2        CLEAR OUT PASS 2 CELLS 
          SX3    CLP2+LCLP2 
          RJ     CLS
          SA1    PPTYPE 
          SX1    X1+3 
          NZ     X1,PRS4A    IF NOT 180 PP ASSEMBLY 
          SA2    VWORD
          NZ     X2,PRS4A    IF 12-BIT MODE FOR *CON* AND *VFD* 
          SX6    5
          SX7    45          SET CHARACTER TYPE TO 8-BIT ASCII
 PRS4A    BSS    0
          SA6    CT+1 
          SA7    CT          CLEAR FLAGS AND CELLS
          SX6    B0 
          MX7    0
          SA6    DLFLG
          SA7    TITFG
          SA6    NFOUP
          SA7    QVAL 
          SA6    CLF
          SA1    CP.PS       PAGE SIZE                                   F4810A 
          SX7    X1+5        FORCE EJECT                                 F4810A 
          SA6    IFCDGP 
          SA7    ELCNT
          SA6    ABASE
          SA7    LPCNT
          RJ     CPS         CLEAR PUSH-DOWN STACKS 
          SA2    ABSFG
          SA1    L.USETAB 
          NZ     X2,PRS5     IF ABSOLUTE ASSEMBLY 
          AX1    1
          MANAGE RELTAB,X1   CREATE RELOCATION TABLE
          IX3    X2+X3       CLEAR IT 
          RJ     CLS
 PRS5     SX6    B1          SET PRINT LINE READY 
          SA6    CCT
          SA1    P2TEMPA     1 IF HEADER NOT PRINTED, 2 IF PRINTED       F4810A 
          BX7    X1                                                      F4810A 
          SA7    LCCT        1 IF NO HEADER, 2 IF HEADER PRINTED         F4810A 
          SA6    PLFLG
          SA1    =1H         CLEAR SUBTITLE 
          SX2    SUBTIT 
          SX3    SUBTIT+SUBL
          RJ     PRESET 
          SX6    COMCOL      RESET COMMENT COLUMN 
          SA6    CCOL 
          SA1    LWORD       RESET POSITION COUNTER 
          SA2    NBLOCKS
          BX7    X1 
          SX6    X2+B1       SET MAX RELOCATION FOR SCAD
          SA7    POSCTR 
          SA6    UI+2 
          SX7    10          SET BASE 
          SA7    NBASE
          SA7    MBASE
          SX6    B1+B1       SET PASS = 2 
          SA6    PASS 
          SX6    1R          SET USAGE LETTER 
          SA6    REFLET 
          SA2    RJZ         SET EVALUATE ITEM JUMP 
          BX6    X2 
          SA6    SCANEV 
          SB7    39 
          SX1    1R          CLEAR PRINT AREA 
          SX2    OCTAL
          SX3    OCTAL+40 
          RJ     PRESET 
          SA1    =1H
          SX2    LINE 
          SX3    LINE+9*NCARDS
          RJ     PRESET 
          EQ     PRS         RETURN 
 PSN      SPACE  4
**        PSN - PRINT SEGMENT NAMES.
*         ENTRY  (SI) = SEGTAB INDEX. 
*         USES   P2TEMP, P2TEMPA, ORGCTR. 
  
  
 PSN      PS                 RETURN EXIT
          SA2    =60HADDRESS   LENGTH              BINARY CONTROL CARDS.
          SA1    A2+B1       LIST OUT SEGMENT NAMES 
          SA3    A1+B1
          SA4    A3+B1
          BX6    X3 
          LX7    X4 
          SA6    LINE 
          SA7    A6+B1
          SA3    A4+B1
          SA4    A3+B1
          BX7    X3 
          SA7    A7+B1
          BX7    X4 
          SA7    A7+B1
          MX0    -6 
          SB7    10 
 PSN1     SB7    B7-B1
          BX6    -X0*X1 
          LX1    -6 
          SA6    A6-B1
          NZ     B7,PSN1     LOOP 
          SB7    10 
          BX1    X2 
          MX2    0
          NZ     X1,PSN1     LOOP 
          RJ     LIST2L 
  
*         PRINT SEGMENT NAMES.
  
 PSN2     RJ     UPS         UNPACK SEGMENT CARD
          SA5    SI 
          SA2    O.SEGTAB 
          IX3    X5+X2
          SA3    X3          LWA
          SA1    A3-4        LWA OF PREVIOUS SEGMENT
          BX6    X3 
          BX7    X1 
          SA6    P2TEMP 
          SA7    A6+B1
          SA4    IOP         CHECK TYPE 
          SA2    =5RIDENT 
          SA3    =7RSEGMENT 
          BX2    X2-X4
          IX3    X3-X4
          ZR     X3,PSN3     IF *SEGMENT* 
          NZ     X2,PSN4     IF NOT *IDENT* 
          RJ     SCLIST      SKIP IDENT NAME
          SA1    P2TEMPA     LWA OF PREVIOUS SEGMENT
          ZR     X6,PSN4     IF IDENT WITH NO NAME
          SX1    18          SCAN ENTRY POINT 
          RJ     SCAD 
          SA1    EXVAL       SET BASE ADDRESS 
          BX6    X1 
          SA6    ORGCTR 
          EQ     PSN4 
 PSN3     SX1    18          SCAN ENTRY POINT 
          RJ     SCAD 
          SA1    EXVAL
 PSN4     BX6    X1          LIST FWA 
          MX3    0
          SA6    P2TEMPA
          SX2    27 
          MX0    -21
          BX1    -X0*X1 
          RJ     PACKO
          SA2    P2TEMP      LWA
          SA3    A2+B1       FWA
          IX1    X2-X3       LIST LENGTH
          MX0    -21
          BX1    -X0*X1 
          MX3    0
          SX2    36 
          RJ     PACKO
          SA1    EFLG        TO SUPPRESS FATAL ERROR
          BX6    X1 
          MX7    0
          SA6    W2ERR
          SA7    UERR 
          SA7    AERR 
          RJ     LISTL       LIST LINE
          SA1    SI 
          SX6    X1+4        INCREMENT INDEX
          SA2    L.SEGTAB 
          SA6    A1 
          IX2    X2-X6
          SX2    X2-4 
          NZ     X2,PSN5     IF NEXT SEGMENT IS NOT *END* 
          RJ     UPS         UNPACK END CARD
          EQ     PSN6 
 PSN5     SA3    O.SEGTAB    CHECK USE INDEX
          IX1    X1+X3
          SA2    X1+B1       OLD SEGTAB(2)
          SA3    X1+5        NEW SEGTAB(2)
          BX7    X2-X3
          AX7    18 
          ZR     X7,PSN2     IF SAME OVERLAY
 PSN6     SA1    P2TEMP      LIST PROGRAM LWA 
          SX2    27 
          MX3    0
          RJ     PACKO
          SA1    MACHINE
          ZR     X1,PSN7     IF CP
          SA1    ORGCTR      LIST LENGTH IN CM WORDS
          SA2    P2TEMP 
          SX5    5
          IX4    X2-X1
          SX4    X4+9 
          IX1    X4/X5
          MX3    0
          SX2    36 
          RJ     PACKO
          SX6    1R(
          SX7    1R)
          SA6    A6-B1
          SA7    OCTAL+36 
 PSN7     RJ     LISTL
          MX6    0           RESET QUAL 
          SA6    QVAL 
          EQ     PSN         RETURN 
 RBV      SPACE  4
**        RBV - READ BINARY VALUE.
*         ENTRY  (X1) = DIRECT MEMORY LOCATION. 
*         EXIT   (X6) = BINARY VALUE OF LOCATION. 
  
  
 RBV      PS                 RETURN EXIT
          SA2    LPGM        CHECK FOR IN RANGE 
          SA3    ORGBASE
          IX6    X1-X2       -
          IX1    X1-X3       +
          BX7    -X1*X6 
          SX6    B0 
          PL     X7,RBV      IF OUT OF RANGE OF PROGRAM 
          SX0    5
          LX1    1
          SB4    X1 
          IX1    X1/X0       WORD INDEX 
          SA2    O.MEMORY 
          SB6    X1 
          SB5    B6+B6
          SB7    B5+B5
          SB5    B7+B6       5*LOCATION 
          SX7    B4-B5       REMAINDER
          IX6    X7+X7       2*REMAINDER
          IX7    X6+X7       3*REMAINDER
          LX7    2           12*REMAINDER 
          SB7    X7+12
          SB5    60 
          MX0    -12
          SA1    O.MEMORY    READ MEMORY
          SA5    X1+B6
          LX5    X5,B7
 +        BX6    -X0*X5 
          NE     B5,B7,*+1
          SA5    A5+B1
 +        LX5    12 
          BX7    -X0*X5 
          LX6    8
          IX6    X6+X7
          EQ     RBV         RETURN 
 RINT     SPACE  4
**        RINT - READ AND CREATE INTERMEDIATE LINE. 
*         USED TO DO THE READING.  IT DOES NOT CREATE THE PRINT LINE. 
  
  
 RINT     PS
          RJ     RINTRD      READ INTERMEDIATE FILE 
          SA1    RELVEC      STORE OPTYPE 
          BX6    X1 
          LX1    59-43       PREPARE TO DECODE REMAINDER OF INT.
          SA6    OPTYPE 
          SA2    A1+B1
          MX6    0
          PL     X1,RINT1    IF NO IND
          BX6    X2 
          SA2    A2+B1
 RINT1    SA6    IND
          LX1    59 
          MX6    0
          PL     X1,RINT2    IF NO FLAG 
          BX6    X2 
          SA2    A2+B1
 RINT2    SA6    FLAG 
          SA5    CCT
          LX1    59-46+45 
          SB7    X5 
          MI     X1,RIN2     IF TWO-WORD SEQUENCE FIELDS ARE PRESENT
          LX1    1
          PL     X1,RIN1     IF NO SEQUENCE FIELDS ARE PRESENT
  
          MX6    0           STORE ONE-WORD SEQUENCE FIELDS 
          BX7    X2 
          SA2    A2+B1
          SA6    SEQ
          SA7    A6+B1
          EQ     B7,B1,RINT3 IF NO CONTINUATION CARDS 
 RIN1A    BX7    X2 
          SA2    A2+B1
          SA6    A7+B1
          SB7    B7-B1
          SA7    A6+B1
          GT     B7,B1,RIN1A
          EQ     RINT3
  
 RIN1     SA3    =8R         NO SEQUENCE FIELDS - USE BLANKS
          SA4    =10R 
          BX6    X3 
          LX7    X4 
          SA6    SEQ
          SA7    A6+B1
          EQ     RIN3        CONTINUE BELOW 
  
 RIN2     SA3    A2+B1       TWO-WORD SEQUENCE FIELDS 
          LX1    1
          BX6    X2 
          SA2    A3+B1
          LX7    X3 
          SA6    SEQ
          SA7    A6+B1
 RIN3     EQ     B7,B1,RINT3 IF NO CONTINUATION CARDS 
          MI     X1,RIN4     IF NOT SAME SEQUENCE FIELDS FOR ALL CARDS
 RIN3A    SA6    A7+B1
          SB7    B7-B1
          SA7    A6+B1
          GT     B7,B1,RIN3A
          EQ     RINT3
  
 RIN4     SA3    A2+B1       TWO-WORD SEQUENCE FIELD FOR EACH CARD
          BX6    X2 
          SA2    A3+B1
          LX7    X3 
          SA6    A7+B1
          SB7    B7-B1
          SA7    A6+B1
          GT     B7,B1,RIN4 
  
 RINT3    SB5    1R 
          SB6    B5 
          MX0    -6 
          SB3    10 
          SB4    B0 
          LX2    6
          SB7    B3-B1
          BX6    -X0*X2 
          SA6    STYPE
          EQ     RIN6 
  
 RIN5     SB4    B4-B1       STORE CHARACTER
          SA6    A6+B1
          PL     B4,RIN5     LOOP IF FILLING BLANKS 
 RIN6     LX2    6
          SB7    B7-B1       EXTRACT NEXT CHARACTER 
          BX6    -X0*X2 
          NZ     B7,RIN7     IF WORD NOT EXHAUSTED
          SA2    A2+B1
          SB7    B3 
 RIN7     ZR     B6,RIN8     IF 00XX CODE 
          SB6    X6 
          NZ     B6,RIN5     IF NOT 00 CHARACTER, GO STORE IT 
          EQ     RIN6        GO GET XX
 RIN8     SB4    X6 
          SX6    B5 
          SB6    B5 
          GT     B4,B1,RIN5  IF 0002-0077 CODE, GO STORE BLANKS 
          SB4    B4-B1
          MX6    0
          ZR     B4,RIN5     IF 0001 CODE, GO STORE 00 CHARACTER
  
          SA5    LASTCOL     0000 CODE, END OF STATEMENT
          SX7    A6-CARD+1
 +        NZ     X7,*+1      IF NOT ALL BLANKS
          SX7    B1 
          SB7    X5+CARD-1
          SA7    A5 
          SX6    B5 
          SB7    A6-B7
          SX7    B5 
 RIN9     SB7    B7+2 
          SA7    A6+B1
          SA6    A7+B1
          NG     B7,RIN9     LOOP 
  
*         END OF CARD - RECREATE INDICATOR AND ERROR FLAGS
  
          SA1    IND
          SB7    LEFLG-1
          SB6    ERFLAGS+1
          MX0    60-LEFLG 
          SX6    B1 
          BX2    -X0*X1 
          SX5    B1 
          ZR     X2,RINT6    IF NO ERRORS 
          SA6    EFLG 
 RINT6    BX6    X1*X5
          LX1    59 
          SB7    B7-B1
 +        SA6    B7+B6
          PL     B7,RINT6 
          AX1    30-LEFLG 
          SX0    B1 
          SB7    LIBFLG-NOAS-1
          BX6    X0*X1
          SA6    LIBFLG 
          AX1    1
          BX6    X0*X1
 +        SB7    B7-B1
          SA6    A6-B1
          AX1    1
          BX6    X0*X1
          PL     B7,*-1 
          EQ     RINT 
 RINTER   SPACE  4
**        RINTER - READ INTERMEDIATE STATEMENT. 
*         RINTER RE-CREATES THE STATEMENT, SETS ALL ERROR FLAGS, SETS 
*         ALL INDICATORS, AND CREATES THE PRINT LINE. 
  
  
 RIS1     RJ     RINT        READ IN SUBSTITUTED LINE 
          SA1    MICFLG 
          NZ     X1,RIS1     IF ANOTHER MICRO, LOOP 
  
 RINTER   PS                 RETURN EXIT
 RIS2     RJ     RINT        READ IN INTERMEDIATE LINE
          MX6    0
          SA6    DETFLG      CLEAR DETAIL FLAG
          SA6    CTYPE       CLEAR CONTROL CARD TYPE
          SA6    PLFLG       CLEAR PRINT LINE READY 
          SA6    NLFLG       CLEAR NO LIST FLAG 
          SA1    LR+1        SET SUPREF 
          SA2    LX+1 
          SA3    LIBFLG 
          SA4    LXRF 
          BX3    -X2*X3 
          BX1    X1*X4
          SX2    B1 
          IX6    X2-X1
          BX6    X6+X3
          SA6    SUPREF 
          SA3    EFLG        CHECK ERROR FLAG 
          SA1    RISA 
          NZ     X3,RIS7     IF ERROR 
          SB7    30 
 RIS3     AX2    X1,B7
          SA3    X1 
          SA4    X2 
          SA1    A1+B1
          BX0    -X3*X4 
          ZR     X0,RIS3     IF LINE WILL LIST
          SX6    A1-RISA-RISAL
          NZ     X6,RIS6     IF LIST OPTION FAILS 
 RIS4     RJ     LDL
          MX6    0
          SA6    PLFLG       CLEAR PRINT LINE READY 
 RIS5     SA1    LPCNT       INCREMENT PRINTED LINE COUNT 
          SA2    PGCNT
          SX6    X1 
          SX7    X2 
          SA6    LPCX 
          SA7    A6+B1      SAVE PAGE NUMBER FOR ENTREF 
          RJ     CPL         CREATE PRINT LINE
          SA1    MICFLG 
          SA2    LA+1 
          ZR     X1,RINTER   IF NOT MICRO/CONCATENATION LINE
          ZR     X2,RIS1     IF NO *A* OPTION 
          RJ     LISTER 
          EQ     RIS2 
 RIS6     SA1    MICFLG      CHECK FOR MICRO/CONCATENATION LINE 
          SX6    B1 
          SA6    NLFLG
          NZ     X1,RIS1     IF MICRO/CONCATENATION LINE
          EQ     RINTER 
 RIS7     SA1    DLFLG
          ZR     X1,RIS5     IF NO DEFERRED LINE
          SX7    B1 
          SA7    FLIST
          RJ     LISTER 
          MX6    0
          SA6    DLFLG
          EQ     RIS5 
  
 RISA     VFD    30/=1,30/LL+1     MASTER LIST
          VFD    30/=1,30/CP.LISTF  EXTERNAL LIST 
          VFD    30/SYSFLG,30/LS+1 SYSTEM MACRO 
          VFD    30/LIBFLG,30/LX+1 XTEXT
          VFD    30/MACFLG,30/LM+1 MACRO
          VFD    30/ECHFLG,30/LE+1 DUP
          VFD    30/RMTFLG,30/LD+1 RMT
          VFD    30/NOAS,30/LF+1   IF SKIPPED 
          VFD    30/=1,30/=0       END OF TABLE 
 RISAL    EQU    *-RISA 
 RINTRD   SPACE  4
**        RINTRD - READ WORDS FROM INTERMEDIATE FILE INTO RELVEC. 
*         RINTRD WILL ACCESS EITHER INTERMEDIATE FILE OR TABLE. 
*         EXIT   (CCT) = NUMBER OF CARDS. 
  
  
 RIF1     SA1    RIFA 
          NZ     X1,RIF2     IF NOT FIRST READ
  
          IFEQ   CP#RM,0,3
          READ   S
          READW  S,RIFA,1 
          ELSE   1
          GET    S,RIFA,10
  
          SA1    RIFA 
 RIF2     BX6    X1 
          MX0    60-4 
          AX1    30 
          SA6    RELVEC 
          BX6    -X0*X1 
          MX0    60-8 
          AX1    34-30
          BX2    -X0*X1 
          SA6    CCT
  
 RM       IFEQ   CP#RM,0
          READW  S,RELVEC+1,X2
          SA1    B6-B1
 RM       ELSE
          BX6    X2 
          IX3    X2+X2
          LX2    3
          IX4    X3+X2
          SA6    T6RM1
          GET    S,RELVEC+1,X4
          SA2    T6RM1
          SA1    RELVEC+X2   NEXT HEADER WORD 
 RM       ENDIF 
  
          BX6    X1 
          SA6    RIFA 
  
 RINTRD   PS                 RETURN EXIT
          SA2    INTERIO
          NZ     X2,RIF1     IF FILE ON DISK
          SA2    O.INTER
          SA3    X2 
          MX0    60-4 
          AX3    30 
          BX6    -X0*X3 
          SA6    CCT
          MX0    60-8 
          AX3    34-30
          BX1    -X0*X3 
          SA4    L.INTER
          IX6    X2+X1
          IX7    X4-X1
          SA6    A2          RESET TABLE POINTERS 
          SA7    A4 
          SX3    RELVEC      MOVE DATA
          RJ     MOVE 
          EQ     RINTRD      RETURN 
 SBL      SPACE  4
**        SBL - SET BINARY LENGTH.
*         SETS (LPGM) AND ALLOCATES MEMORY FOR AN ABSOLUTE CP PROGRAM.
  
  
 SBL      PS                 RETURN EXIT
          RJ     ASU         ACCUMULATE STORAGE USED
          SA4    O.SEGTAB    SET PROGRAM LENGTH 
          SX6    X4+4 
          SA6    A4 
          SA4    X4 
          BX6    X4 
          SA6    LPGM 
          SA4    L.SEGTAB    REDUCE LENGTH
          SX6    X4-4 
          SA6    A4 
          RJ     ALM         ALLOCATE MEMORY
          EQ     SBL         RETURN 
 SIC      SPACE  4
**        SIC - SCAN IDENT CARD.
*         ENTRY  (X1) = 0 IF *IDENT*,  1 IF *SEGMENT*.                  S002  68
*                (X6) = DEFAULT OVERLAY LEVELS.                         S002  69
*         EXIT   (P2TEMP) = IDENT NAME. 
*                (P2TEMPA) = OVERLAY LEVELS.                            S002  71
*                (ORGBASE) = BASE ORIGIN. 
*                (SEGEPT) = ENTRY POINT ADDRESS.                        S002  73
  
  
 SIC3     MX0    -7*6                                                   S002  75
          BX2    X0*X6                                                  S002  76
          ZR     X2,SIC      IF NOT MORE THAN 7 CHARACTERS              S002  77
          RJ     VFYLINK     TRUNCATE NAME                              S002  78
          SA6    P2TEMP                                                 S002  79
 SIC3A    SX6    B1                                                      CPS127 
          SA6    AERR 
          SA6    EFLG 
  
 SIC      PS                 RETURN EXIT
          SA6    P2TEMPA     SAVE DEFAULT OVERLAY LEVELS                S002  81
          NZ     X1,SIC1     IF *SEGMENT*                               S002  82
          RJ     SCLIST      SCAN IDENT NAME                            S002  83
          SA1    ABSFG
          SA6    P2TEMP                                                 S002  85
          ZR     X1,SIC3     IF RELOCATABLE PROGRAM 
          RJ     VFYLINK
          SA6    P2TEMP                                                 S002  88
          ZR     X7,SIC1     IF NAME GOOD 
          SX6    B1 
          SA6    EFLG 
          SA6    AERR 
 SIC1     SX1    18                                                     S002  90
          SX6    3
          RJ     SCADCON     SCAN ORIGIN VALUE
          SA1    EXVAL
          MX6    -18                                                    S002  92
          BX7    -X6*X1 
          SA7    ORGBASE
          SX1    18                                                     S002  94
          SX6    3
          RJ     SCADCON
          SA1    EXVAL
          MX6    -18                                                    S002  96
          BX6    -X6*X1 
          SA6    SEGEPT      ENTRY POINT FOR SEGMENT
          SA1    MACHINE
          SA2    EXSTOP                                                 S002  98
          SA3    PPTYPE                                                  CPS127 
          NZ     X1,SIC2     IF PP
          ZR     X2,SIC      IF NO LEVEL NUMBERS                        S002 100
          SX1    6           LEVEL NUMBER 1 
          SX6    3
          RJ     SMC
          SA2    EXVAL
          SX1    6           LEVEL NUMBER 2 
          BX6    X2 
          SA6    P2TEMPA
          SX6    3
          RJ     SMC
          SA1    P2TEMPA     DUMP PRELIMINARY INFORMATION 
          SA2    EXVAL
          MX0    -6 
          BX6    -X0*X1 
          LX6    6
          BX2    -X0*X2 
          IX6    X2+X6
          SA6    A1 
          EQ     SIC         RETURN 
 SIC2     NZ     X3,SIC2A    IF PPU                                      CPS127 
          NZ     X2,SIC3A    IF COMMA                                    CPS127 
          EQ     SIC         RETURN                                      CPS127 
 SIC2A    SX1    12          PPU NUMBER                                  CPS127 
          SX6    3
          RJ     SMC
          MX4    -12
          SA2    SEGEPT      ENTRY POINT
          SA1    EXVAL
          BX2    -X4*X2 
          BX1    -X4*X1 
          LX2    12 
          LX1    36 
          BX6    X2+X1
          SA6    A2 
          EQ     SIC         RETURN 
 SMO      SPACE  4
**        SMO - SET MINIMUM AND MAXIMUM ORIGIN. 
  
  
 SMO      PS                 RETURN EXIT
          SA1    ABSFG
          MX6    0
          SX7    B1 
          IX7    X7-X1       1-ABSFG = BLOCK NUMBER TO START WITH 
          SA6    ORGCTR 
          SA7    A6+B1
          SA6    LOCCTR 
          SA7    A6+B1
          LX7    2
          SA4    O.USETAB 
          SA1    UI 
          SB7    X7+2 
          IX4    X4+X1
          SA2    X4+B7
          MX3    -21
          BX7    -X3*X2 
          AX2    33 
          BX6    -X3*X2 
          SA6    MAXORG 
          SA7    A6+B1       MINORG 
          RJ     RESORG 
          EQ     SMO         RETURN 
 SUO      SPACE  4
**        SUO - SET USE ORIGINS.
*         SET THE ORIGIN OF ALL USE BLOCKS TO ZERO. 
  
  
 SUO      PS                 RETURN EXIT
          SA1    O.USETAB 
          SA2    L.USETAB 
          SA5    LWORD
          LX5    24 
          MX0    -21
          SA3    X1+2 
          SB6    -4 
 SUO1     BX6    -X0*X3 
          IX6    X5+X6
          SA6    A3-B1
          SA3    A3-B6       ADVANCE TO NEXT ORIGIN 
          SX2    X2+B6
          NZ     X2,SUO1     LOOP 
          EQ     SUO         RETURN 
 TLIST    SPACE  4
**        TLIST - TEST FOR LISTING OF TITLE CARDS.
*         RETURN TO Z100 IF CARD WILL NOT LIST. 
  
  
 TLIST    PS                 RETURN EXIT
          SA1    LOCSYM 
          BX6    X1 
          SA6    SUBNAME
          SA1    LL+1 
          SA2    CP.LISTF 
          BX6    X1*X2
          ZR     X6,Z100     IF NO LIST 
          SA6    CTYPE
          EQ     TLIST       RETURN 
 UPS      SPACE  4
**        UPS - UNPACK SEGMENT CARD.
*         ENTRY  (SI) = SEGMENT TABLE INDEX.
  
  
 UPS      PS                 RETURN EXIT
          SA5    SI 
          SA2    O.SEGTAB 
          IX3    X5+X2
          SA4    O.IDTAB     UNPACK CARD
          SA3    X3+B1
          IX1    X3+X4
          SA2    X1          SET CURRENT QUAL 
          SX1    X1+B1
          MX0    12 
          SX7    X2 
          BX6    X0*X2
          SA6    QVAL 
          SA7    NBASE
          RJ     /PASS1/UCARD 
          RJ     SETUP
          MX6    0           CREATE PRINT LINE
          SX7    B1 
          SA6    PLFLG
          SA6    DLFLG
          SA7    CCT
          RJ     CPL
          SA1    =1H         CLEAR SEQ FIELD
          BX6    X1 
          SA6    LINE+7 
          SA6    A6+B1
          EQ     UPS         RETURN 
 URS      SPACE  4
**        URS - UNDEFINE REDEFINABLE SYMBOLS
* 
  
  
 URS      PS
          SA1    L.SYMTAB 
          SA2    O.SYMTAB 
          SA5    =7777770070BS30
          SB7    X1          LENGTH OF SYMTAB 
          SB2    B1+B1       SYMTAB ENTRY SIZE
          SB6    59-33       REDEF FLAG POSITION
          SX2    X2-1 
 URS1     SB7    B7-B2       DECREMENT LENGTH 
          SX2    X2+B2       INCREMENT TABLE POSITION 
          RX1    X2          FETCH 2ND WORD OF ENTRY
          NG     B7,URS      IF END OF TABLE, EXIT
          LX6    X1,B6
          PL     X6,URS1     IF NOT REDEFINABLE, LOOP 
          BX6    X5*X1
          WX6    X2          REPLACE ENTRY
          EQ     URS1        LOOP 
  
 ZDEFSYM  SPACE  4
**        ZDEFSYM - DEFINE SYMBOL.
*         MAKES TYPE *D* REF TABLE ENTRY AND STORES SYMBOL VALUE
*         RIGHT JUSTIFIED IN OCTAL EXPANSION AREA.
*         NO ERRORS DETECTED. 
*         ENTRY  (X1) = SYMBOL. 
*                (X2) = VALUE.
*                (X3) = RELOCATION. 
*                (X4) = EXTERNAL NUMBER.
*                (X5) = REDEFINITION FLAG.
  
  
 ZDEFSYM  PS                 RETURN EXIT
          ZR     X1,ZDEFSYM  EXIT IF SYMBOL IS EMPTY
          MX0    39 
          BX2    -X0*X2      TRUNCATE TO 21-BIT VALUE 
          BX3    X4+X3       OR RELOCATION AND EXTERNAL 
          LX3    21 
          IX6    X3+X2
 +        LX5    2
          ZR     X4,*+1 
          SX5    X5+B1       ADD EXT BIT
          LX5    1
          SX5    X5+B1       ADD DEFINED BIT
          LX5    30 
          BX6    X6+X5       SAVE 
          SA6    ZDEFSYMT    EQUIVALENT 
          RJ     TLUSYMT     FIND SYMBOL
          SX0    X3-1 
          ZR     X3,ZDEFSYM2 IF NOT FOUND 
          RX1    X0 
          MX0    28 
          BX6    X1-X5
          SA1    ZDEFSYMT 
          LX1    59-33
          NZ     X6,ZDEFSYM2 IF NOT SAME QUALIFIER
          PL     X1,ZDEFSYM1 IF NOT REDEFINABLE 
          LX1    33-59
          BX2    X0*X2
          BX6    X2+X1
          WX6    X3          STORE NEW EQUIVALENT 
 ZDEFSYM1 SX1    1RD         USAGE = D
          RJ     ENTREF      ENTER REFERENCE TABLE
 ZDEFSYM2 SA1    ZDEFSYMT 
          SX2    36 
          LX1    59-20       EXTEND SIGN OF VALUE 
          SX3    B0 
          AX1    59-20
          RJ     PACKOR      CALL PACKOR (VALUE,36,7) 
          EQ     ZDEFSYM
  
 ZDEFSYMT DATA   0           TEMPORARY STORAGE
 ZEVITEM  SPACE  4
**        ZEVITEM - EVALUATE ITEM.
*         MANY ERRORS DETECTED HERE.
*         ENTRY  (X1) = FIELD WIDTH.
  
  
 ZEVITEM  PS                 RETURN EXIT
          BX6    X1 
          SA6    ZEVITFL
          MX6    0
          BX7    X7-X7       CLEAR OUT REPLY CELLS
          SA6    ELVAL
          SA7    A6+B1
          SA6    A7+B1
          SA7    A6+B1
          SA1    ZEVITEMN    SET SWITCH FOR NORMAL EXIT 
          BX6    X1 
          SA6    ZEVITEMS 
          SA1    CHAR 
          SA2    MACHINE
          SB7    X1-3 
          NZ     X2,ZEVIT10  JUMP IF PP TO IGNORE REGISTER CHECKS 
          NG     B7,ZEVIT500 IF FIRST LETTER IS (A) OR (B)
          SB7    X1-1RX 
          ZR     B7,ZEVIT500 IF FIRST LETTER IS (X) 
 ZEVIT10  SB7    X1-1RZ-1 
          NG     B7,ZEVIT21  JUMP IF LETTER 
          SB7    X1-1R9-1 
          NG     B7,ZEVIT100 IF DIGIT 
          SB7    X1-1R/ 
          ZR     B7,ZEVIT300 IF SLASH 
          SB7    X1-1R= 
          ZR     B7,ZEVIT400 IF EQUALS SIGN 
          SB7    X1-1R* 
          ZR     B7,ZEVIT200 IF ASTERISK
          SB7    X1-1R$ 
          EQ     B7,ZEVIT250 IF DOLLAR SIGN 
  
*         ALPHABETIC CHARACTER LEADS THE ELEMENT. 
  
 ZEVIT21  RJ     SCITEM      ISOLATE THE SYMBOL 
 ZEVIT22  BX1    X6 
          ZR     X6,ZEVITER  COMPLAIN IF EMPTY SYMBOL 
          RJ     ZTLUSYM     EVALUATE SYMBOL
          EQ     ZEVITEMS 
  
*         ASTERISK ELEMENT. 
  
 ZEVIT200 RJ     SCITEM      ISOLATE THE ITEM 
          SB7    X6-1R*      ISOLATE VALURIOS LEGAL COMBINATIONS
          SB6    X6-2R*L
          SB5    X6-2R*O
          ZR     B7,ZEVIT210 IF * 
          ZR     B6,ZEVIT210 IF *L
          ZR     B5,ZEVIT220 IF *O
          SB7    X6-2R*P
          SB6    X6-2R*F
          ZR     B7,ZEVIT230 IF *P
          ZR     B6,ZEVIT240 IF *F
 ZEVITER  SX6    B1          NOTE ERROR 
          SA6    AERR 
          SA6    EFLG 
          SA6    EXERR
          EQ     ZEVITEMS 
  
*         * OR *L ELEMENT.
  
 ZEVIT210 SA2    LOCCTR 
 ZEVIT211 SA3    A2+B1
          BX6    X2 
          LX7    X3 
 ZEVIT212 SA6    ELVAL
          SA7    ELREL
          EQ     ZEVITEMS 
  
*         *O ELEMENT. 
  
 ZEVIT220 SA2    ORGCTR      USE ORIGIN COUNTER 
          EQ     ZEVIT211 
  
*         *P ELEMENT. 
  
 ZEVIT230 SA2    POSCTR 
 ZEVIT231 BX6    X2 
          MX7    0
          EQ     ZEVIT212 
  
*         *F ELEMENT. 
  
 ZEVIT240 SA2    FMODE
          EQ     ZEVIT231 
  
*         DOLLAR SIGN.
  
 ZEVIT250 RJ     SCITEM      GET ITEM 
          SA1    PPTYPE 
          SX1    X1+B1
          ZR     X1,ZEVIT210 IF BCU ASSEMBLY
          SB7    X6-1R$      AND COMPLAIN IF ANYTHING MORE THAN 
          SA1    POSCTR      JUST A DOLLAR SIGN 
          SX6    X1-1 
          MX7    0
          ZR     B7,ZEVIT212
          EQ     ZEVITER
  
*         SLASH ELEMENT.
  
 ZEVIT300 RJ     GETCH
          SA2    CHAR        CHECK NEXT CHARACTER 
          SX1    X2-1R/ 
          ZR     X1,ZEVIT303 IF */* 
          RJ     SCITEM 
          SB7    X1-1R/ 
          NZ     B7,ZEVITER  IF NOT QUAL SYMBOL 
          BX1    X6 
 ZEVIT303 RJ     SQV         SET QUAL VALUE 
          RJ     GETCH       SKIP TERMINAL /
          RJ     SCITEM 
          SA6    ZEVA 
          BX1    X6 
          NZ     X6,ZEVIT301 IF NOT EMPTY SYMBOL
          SX6    B1 
          SA6    AERR 
          SA6    EFLG 
          EQ     ZEVIT302 
 ZEVIT301 RJ     ZTLUSYM
          SA1    ZEVA        LOOK UP SYMBOL 
          RJ     TLUSYMT
          SX0    X3-1 
          RX1    X0 
          BX6    X5-X1
          ZR     X6,ZEVIT302 IF THE SAME QUALIFIER
          SX2    B0 
          RJ     ENTSYMT     ENTER SYMBOL TABLE 
          EQ     ZEVIT301    AND GO LOOK AGAIN
 ZEVIT302 SA1    QVAL+1      RESET QUAL VALUE 
          BX6    X1 
          SA6    A1-B1
          EQ     ZEVITEMS    RETURN 
  
*         EQUALS SIGN.
  
 ZEVIT400 RJ     GETCH
          SB7    X1-1RS 
          SB6    X1-1RX 
          ZR     B7,ZEVIT402  IF =S TYPE SYMBOL 
          EQ     B6,B1,ZEVIT402  IF =Y TYPE SYMBOL
          NZ     B6,ZEVIT401 JUMP IF NUMERIC LITERAL
 ZEVIT402 RJ     GETCH       THROW AWAY THE *S* OR *X* OR *Y* 
          EQ     ZEVIT21     AND GO EVALUATE NORMAL SYMBOL
 ZEVIT401 SX2    VALUES      PREPARE TO EVALUATE LITERAL
          SX3    NLITS
          SX4    -B1
          SA5    LWORD
          RJ     SCD         SCAN DATA ITEM 
          ZR     X3,ZEVITER  COMPLAIN IF ZERO-LENGTH DATA 
          SX2    VALUES 
          RJ     ZTLULIT     LOOK UP LITERAL
          MX0    39 
          BX6    -X0*X3 
          AX3    24 
          MX2    -9 
          BX7    -X2*X3 
          EQ     ZEVIT212 
  
*         NUMERIC ELEMENT.
  
 ZEVIT100 SX2    ELVAL
          SX3    B1 
          BX4    X3 
          SA5    ZEVITFL
          RJ     SCD         SCAN DATA ITEM 
 ZEVITEMS PS
          SA1    CHAR 
          EQ     ZEVIT10
  
*         SUSPECTED REGISTER NAME.
  
 ZEVIT500 SA1    COLUMN 
          SA1    X1+CARD-1
          SA2    A1+B1
          SB7    X2-1R. 
          ZR     B7,ZEVIT530 IF LETTER FOLLOWED BY DECIMAL POINT
          SB7    X2-1R0      CHECK FOR NUMBER OUTSIDE OF 0-7
          NG     B7,ZEVIT21 
          SB7    X2-1R8 
          PL     B7,ZEVIT21 
          SA3    A2+B1
          SX4    3036B
          LX4    36          CHECK FOR EXAACTLY 2-LETTERS 
          SB7    X3 
          AX5    X4,B7
          LX5    59 
          PL     X5,ZEVIT21 
          SX4    X1 
          LX4    3
          RJ     GETCH
          SX5    X6-1R0      GET REGISTER NUMBER
          BX6    X4+X5
          MX7    60 
          SA6    ELREG
          SA7    ELVAL
          RJ     GETCH
          EQ     ZEVITEM
  
 ZEVIT530 LX1    3           ISOLATE REGISTER CLASS 
          BX6    X1 
          SA6    ELREG
          RJ     GETCH
          RJ     GETCH       THROW AWAY PERIOD
          SA2    REFLET      SAVE REFERENCE TYPE LETTER 
          SX7    1R 
          BX6    X2 
          SA7    A2          MAKE IT BLANK TEMPORARILY
          SA6    ZEVB 
          RJ     ZEVITEMS    GO BACK TO EVALUATE IT 
          SA2    ZEVB        RESTORE FLAGGING SYMBOL
          BX7    X2 
          SA7    REFLET 
          SA2    ELVAL
          SA3    A2+B1       ELREL
          SA4    A3+B1       ELEXT
          BX5    X3+X4
          SA3    EXERR
          IX5    X5+X3
          NZ     X5,ZEVIT550
          MX5    -3 
          BX6    -X5*X2 
          MX7    60 
          BX5    X5*X2
          SA7    A2 
          SA2    A4+B1       ELREG
          IX6    X6+X2
          SA6    A2 
          ZR     X5,ZEVITEM  IF NO FIELD OVERFLOW 
          SX6    B1          COMPLAIN 
          SA6    EFLG 
          SA6    W7ERR
          EQ     ZEVITEM
 ZEVIT550 SX6    B1          COMPLAIN 
          SA6    A3 
          SA6    AERR 
          SA6    EFLG 
 ZEVITEMN SA1    CHAR 
          EQ     ZEVITEM
  
 ZEVITFL  DATA   0
 ZEVA     DATA   0
 ZEVB     DATA   0
 ZFOUP    SPACE  4
**        ZFOUP - FORCE UPPER.
  
  
 ZFOUP    PS                 RETURN EXIT
          MX6    0
          SA1    POSCTR 
          SA2    LWORD
          BX3    X1-X2
          SA6    NFOUP
          ZR     X3,ZFOUP    EXIT IF ALREADY AT TOP OF WORD 
          SA4    MACHINE
          NZ     X4,ZFOUP1   JUMP IF PP CODING
          SA3    =0.067P48   ROUND DOWN TO NEAREST QUARTER WORD 
          SA4    =15.0P0
          PX0    X1 
          FX5    X0*X3
          DX7    X5*X4
          SA6    A1 
          SX2    X7 
          SA1    =460006100046000B
          SX3    B0 
          MX4    0
          RJ     BINOUT      OUTPUT THE NO-OP INSTRUCTIONS
 ZFOUP1   RJ     DWORD       DUMP THIS WORD 
 ZFOUP2   SA1    LWORD       RESET TO NEW WORD
          SA2    ORGCTR 
          SA3    LOCCTR 
          BX6    X1 
          SX0    B1 
          IX7    X2+X0
          SA6    POSCTR 
          SA7    A2 
          IX6    X3+X0
          SA6    A3          RESET POSCTR TO LWORD
          EQ     ZFOUP       RETURN 
 ZFUALL   SPACE  4
**        ZFUALL - FORCE ALL BLOCKS UPPER.
*         USES FLAG SETTING SET IN YFUALL IN PASS 1.
  
  
 ZFU1     SA6    FLAG 
          RJ     USER 
          RJ     ZFOUP
          SA1    FLAG 
          SX3    X1-1 
          SX2    X1 
          LX2    24 
          IX6    X2+X3
          NZ     X3,ZFU1
          SA1    ZFUALT      RESET TO CURRENT BLOCK 
          SX2    B1 
          LX2    24 
          AX1    24 
          IX6    X1+X2
          SA6    FLAG 
          RJ     USER 
  
 ZFUALL   PS                 RETURN EXIT
          SA1    FLAG 
          BX6    X1 
          SA6    ZFUALT 
          RJ     ZFOUP
          RJ     USER        SWITCH TO BASE BLOCK 
          SA1    L.USETAB 
          SA2    UI 
          IX1    X1-X2
          AX1    2           NUMBER OF BLOCKS ABOVE CURRENT GROUP 
          SA2    ZFUALT 
          SX2    X2 
          LX2    24 
          IX6    X1+X2
          EQ     ZFU1 
  
 ZFUALT   DATA   0
 ZPRLOC   SPACE  4
**        ZPRLOC - PROCESS LOCATION SYMBOL. 
*         ENTRY  (X1) = INSTRUCTION LENGTH. 
  
  
 ZPRLOC   PS                 RETURN EXIT
          SA2    POSCTR      ROUND TO NEAREST QUARTER WORD
          SA3    MACHINE     OR TO PP WORD BOUNDARY 
          SA4    LWORD
          PX0    X2 
          BX6    X2 
          NZ     X3,ZPRLOC1  IF PP
          SA4    =0.067P48
          SA5    =15.0P0
          FX0    X0*X4
          DX4    X0*X5
          UX6    X4,B7
          EQ     ZPRLOC2
 ZPRLOC1  IX4    X2-X4
          SB7    X4 
          ZR     B7,ZPRLOC2 
          MX6    0
 ZPRLOC2  SA6    A2          RESET POSITION COUNTER 
          BX7    X1 
          SA7    ZPRLOCT     SAVE INCREMENT COUNT 
 +        NZ     X6,*+1 
          RJ     ZFOUP       IF AT BOTTOM OF WORD, FORCE UPPER
          SA1    ZPRLOCT
          SA2    POSCTR 
          IX6    X2-X1       CHECK IF ROOM EXISTS FOR THIS
 +        PL     X6,*+1      INSTRUCTION
          RJ     ZFOUP       IF INSTRUCTION LENGTH DEMANDS IT 
          SA1    LOCSYM 
          SB7    X1-1R- 
          NZ     B7,ZPRLOC4  IF NOT MINUS 
          MX6    0           CLEAR FORCE UPPER
          SA6    NFOUP
          EQ     ZPRLOC3
 ZPRLOC4  SA2    NFOUP
          BX1    X2+X1
 +        ZR     X1,*+1      IF LOCSYM NON BLANK OR NFOUP NON 0 
          RJ     ZFOUP
 ZPRLOC3  BSS    0
          SA1    POSCTR 
          SA2    LWORD       CHECK FOR BEING AT TOP OF WORD 
          BX3    X1-X2
          NZ     X3,ZPRLOC5  IF NOT AT TOP OF WORD
          RJ     LLA         LIST LOCATION ADDRESS
 ZPRLOC5  SA1    LOCSYM 
          ZR     X1,ZPRLOC   EXIT IF NO LOCATION SYMBOL 
          MX6    0
          SB7    X1-1R+ 
          SA6    A1 
          ZR     B7,ZPRLOC   IF + 
          EQ     B7,B1,ZPRLOC IF -
          RJ     TLUSYMT     LOOK UP SYMBOL 
          ZR     X3,ZPRLOC   IF NOT FOUND 
          SX1    1RL         USAGE = L
          RJ     ENTREF      ENTER REFERENCE TABLE
          EQ     ZPRLOC      EXIT 
  
 ZPRLOCT  DATA   0           TEMPORARY STORAGE
 ZTLIST   SPACE  4
**        ZTLIST - SEE IF THIS CARD WOULD LIST. 
*         USED BY SPACE AND EJECT TO SEE IF SPACING SHOULD BE DONE. 
*         IF YES, EXIT.  IF NO, JUMP TO Z100. 
  
  
 ZTLIST   PS                 RETURN EXIT
          SA1    LOCSYM 
          BX6    X1 
          SA6    SUBNAME
          SA1    LSLA 
          SB7    30 
 ZTL1     AX2    X1,B7       CHECK LIST OPTIONS 
          SA3    X1          LIST CONTROL 
          SA4    X2          CARD TYPE
          BX6    -X3*X4 
          SA1    A1+B1
          ZR     X6,ZTL1     IF LIST STILL POSSIBLE 
          SX6    A1-LSLA-LSLAL
          NZ     X6,Z100     IF NO LIST 
          RJ     LDL         LIST DEFERRED LINE 
          RJ     CPL         CREATE PRINT LINE
          EQ     ZTLIST      RETURN 
 ZTLULIT  SPACE  4
**        ZTLULIT - LOOK UP LITERALS. 
*         ENTRY  (X2) = ORIGIN OF VALUES. 
*                (X3) = WORD COUNT. 
*         EXIT   (X3) = RELOCATED EQUIVALENT. 
  
  
 ZTLULIT  PS                 RETURN EXIT
          SA4    O.LITAB     FIND LITERAL TABLE 
          SA5    LI 
          IX4    X4+X5
          SB6    X4 
          SA4    B6 
          SB2    X2 
          SB3    X3 
          SA2    X2 
 ZLIT1    BX7    X4-X2
          SA4    A4+B1
          NG     X7,ZLIT1    IF NO MATCH
          NZ     X7,ZLIT1 
          SB5    B0          CHECK FOR SEQUENTIAL EQUALITY OF 
          MX0    0           BOTH ELEMENTS
 ZLIT2    SA5    A4+B5
          SB5    B5+B1
          BX0    X0+X7       ACCUMULATE DIFFERANCES 
          SA3    A2+B5
          BX7    X3-X5       COMPARE VALUES 
          NE     B5,B3,ZLIT2
          NZ     X0,ZLIT1    IF MATCH NOT FOUND 
          NG     X0,ZLIT1 
          SB7    A4-B1       INDEX OF ENTRY IN LITAB
          SX4    B7-B6
          SA1    O.USETAB    FIND LITERALS ORIGIN 
          SA2    UI 
          IX1    X1+X2
          SA2    X1+2*4+2 
          IX3    X2+X4
          EQ     ZTLULIT     RETURN 
 ZTLUSYM  SPACE  4
**        ZTLUSYM - EVALUATE SYMBOL.
*         MANY ERRORS DETECTED HERE.
*         REFERENCE TABLE ENTRIES MADE HERE.
*         ENTRY  (X1) = SYMBOL. 
*         EXIT   (ELVAL) = SYMBOL VALUE.
*                (ELREL) = SYMBOL RELOCATION. 
*                (ELEXT) = SYMBOL EXTERNAL. 
  
  
 ZTLUSYM  PS                 RETURN EXIT
          RJ     TLUSYMT     LOOK UP SYMBOL 
          NZ     X3,ZTLU2    IF FOUND 
 ZTLU4    MX2    0
          RJ     ENTSYMT     ENTER SYMBOL TABLE 
          EQ     ZTLUSYM+1   AND GO TRY AGAIN 
 ZTLU2    LX2    59-30
          NG     X2,ZTLUSYM1 IF DEFINED SYMBOL
          SX7    B1 
          SA1    IFDF 
          ZR     X1,ZTLU2A   IF NOT IF DEF/EXT/REG
          SX6    B1+B1
          SA6    A1          IFDF = 2 
          EQ     ZTLUSYM1 
 ZTLU2A   SA7    UERR        SET UNDEFINED ERROR
          SA7    EFLG 
          SA7    EXERR
 ZTLUSYM1 LX2    10 
          AX2    39          SIGN EXTEND VALUE
          BX6    X2 
          RX2    X3          RECLAIM VALUE OF SYMBOL
          SX0    777B 
          SA6    ELVAL
          AX2    21 
          BX6    X0*X2
          LX2    49 
          SA6    A6+B1       ELREL
          MX7    0
          SA7    A6+B1       ELECT
          PL     X2,ZTLUSYM6 IF NOT EXTERNAL
 ZTLU7    BSS    0
          SA6    A7 
          SA7    ELREL
          EQ     ZTLUSYM3 
 ZTLUSYM6 LX2    2
          PL     X2,ZTLUSYM3 IF + RELOC OR ABS
          AX0    1           CHECK IF NEG. RELOCATION WITHIN ABS. BLOCK.
          BX6    X0*X6       GET RELOCATION.
          ZR     X6,ZTLU7    IF NEG. RELOCATION IN ABS. BLOCK.
          SA2    ELVAL       COMPLEMENT VALUE 
          BX6    -X2
          SA6    A2 
 ZTLUSYM3 RX2    X3          RECLAIM SYMBOL VALUE 
          SA1    REFLET      USAGE
          RJ     ENTREF      ENTER REFERENCE TABLE
          EQ     ZTLUSYM
 ZUPLOC   SPACE  4
**        ZUPLOC - UPDATE LOCATION COUNTER. 
*         ENTRY  (X1) = INCREMENT.
  
  
 ZUPLOC   PS                 RETURN EXIT
          SA2    ORGCTR 
          SA3    LOCCTR 
          IX6    X1+X2
          IX7    X1+X3
          SA6    A2 
          SA7    A3 
          RJ     RESORG      RESET ORIGIN 
          EQ     ZUPLOC      RETURN 
 ALM      TITLE  BINARY OUTPUT ROUTINES.
**        TEMPORARY STORAGE FOR BINARY OUTPUT ROUTINES. 
  
  
          SEG    BINARY OUTPUT SUBROUTINES. 
 BTEMP    DATA   0           GENERAL TEMPORARY
 BTEMPA   DATA   0           GENERAL TEMPORARY
 BTEMPB   DATA   0           GENERAL TEMPORARY
 ALM      SPACE  4
**        ALM - ALLOCATE MEMORY.
  
  
 ALM      PS                 RETURN EXIT
          SA1    B
          SA2    ABSFG
          ZR     X1,ALM      IF NO BINARY FILE
          ZR     X2,ALM      IF RELOCATABLE ASSEMBLY
          SA2    ORGBASE
          SA3    MACHINE     0 (CP) OR 1 (PP) 
          SA4    LPGM 
          SA1    PPTYPE 
          LX3    2           0 OR 4 
          IX0    X4-X2       SIZE OF PROGRAM IMAGE
          SX1    X1+B1
          SX6    X3+B1       1 OR 5 
          NZ     X1,ALM1     IF NOT BCU 
          LX0    1           DOUBLE BYTE COUNT FOR BCU
  
 ALM1     SX1    X1+2 
          NZ     X1,ALM2     IF NOT 180 PP ASSEMBLY 
  
*         FOR A 180 PPU ASSEMBLY, THE 16-BIT PP BYTES ARE PACKED INTO 
*         60-BIT WORDS LEAVING NO UNUSED BITS.  E.G., SO AS TO FIT
*         15 16-BIT BYTES (240 BITS) EXACTLY INTO 4 CM WORDS (240 BITS).
*         THE NUMBER OF CM WORDS NEEDED FOR A PPU PROGRAM OF N BYTES IN 
*         LENGTH IS...
  
*                ( ( N * 16 ) + 59 ) / 60 
  
          SX3    59 
          LX0    4           N*16 
          SX6    X3+B1
  
 ALM2     IX0    X0+X3       ROUND TO NEAREST CM WORD IF ANY PP TYPE
          MI     X0,ALM      IF PROGRAM SIZE NEGATIVE 
          IX1    X0/X6       MEMORY SIZE IN CM WORDS
          SA2    L.MEMORY 
          IX1    X1-X2
          MANAGE MEMORY,X1
          ZR     X3,ALM      IF NO MEMORY 
          IX3    X2+X3       CLEAR MEMORY AREA
          RJ     CLS
          EQ     ALM         RETURN 
 BINOUT   SPACE  4
**        BINOUT - OUTPUT BYTE OF INFORMATION.
*         BINOUT RECORDS INFORMATION BY OR-ING INTO BINWORD/BINREL. 
*         R-ERRORS AND A-ERRORS POSTED FOR RANGE/ILLEGAL RELOCATION.
*         ENTRY  (X1) = VALUE.
*                (X2) = BIT COUNT.
*                (X3) = RELOCATION. 
*                (X4) = EXTERNAL NUMBER.
  
  
 BINOUTR  SX6    B1          DATA OUT OF RANGE - POST R ERROR 
          SA6    RERR 
          SA6    EFLG 
  
 BINOUT   PS                 RETURN EXIT
          ZR     X2,BINOUT   QUIT IF ZERO-LENGTH BYTE 
          SA5    ABSFG
          SB2    X2          CHECK FOR IN RANGE 
          SA2    ORGCTR 
          ZR     X5,BINOUT1 
          SA5    LPGM        MAKE ABSOLUTE CHECK
          IX7    X2-X5
          SA5    ORGBASE
          IX6    X2-X5
          BX7    -X6*X7 
          PL     X7,BINOUTR  IF OUTSIDE RANGE OF PROGRAM
 BINOUT1  SA5    MAXORG      CHECK BLOCK RANGE
          IX7    X2-X5
          SA5    MINORG 
          IX6    X2-X5
          BX7    -X6*X7 
          SA2    A2+B1
          SX6    X2-400B
          BX7    X6*X7
          PL     X7,BINOUTR  IF OUTSIDE VALID RANGES
          SB7    60          MASK OUT UNUSED BITS 
          BX6    X1 
          EQ     B2,B7,BINOUT2 IF 60-BIT FIELD
          MX0    1
          SB6    B7-B2
          SB5    B6-B1
          AX0    X0,B5
          BX6    -X0*X1 
 BINOUT2  SA1    POSCTR 
          SA2    BINWORD
          SB4    X1 
          LX6    X6,B4
          BX7    X6+X2
          SA7    A2 
          SX5    1           CONVERT RELOCATION 
          LX5    17 
          IX6    X5+X4
          NZ     X4,BINOUT3  IF EXTERNAL
          ZR     X3,BINOUT   IF ABSOLUTE
          SB7    X3 
          BX6    X3 
          EQ     B7,B1,BINOUT3     IF + PROGRAM 
          SB6    401B 
          SX6    B1+B1
          EQ     B7,B6,BINOUT3     IF - PROGRAM 
          SX6    B7+B1
          GT     B7,B6,BINOUT5     IF NOT COMMON
 BINOUT3  SA2    BINREL 
          SX4    B2          FIELD SIZE 
          LX6    6
          SB6    B1+B1
          SX7    X2+B1       BUMP HALFWORD NUMBER 
          LX2    -1 
          SB7    X2+B1       BINREL WORD NUMBER 
          BX6    X6+X1       POSITION COUNTER 
          SA3    A2+B7       FETCH BINREL WORD
          GT     B7,B6,BINOUT5     IF MORE THAN 4 HALFWORDS 
          LX6    6
          SA7    A2          UPDATE HALFWORD NUMBER 
          BX4    X6+X4
          MI     X2,BINOUT4  IF LOWER HALFWORD
          LX4    30          SHIFT RELOCATION 
 BINOUT4  BX6    X3+X4
          SA6    A3          STORE UPDATED BINREL WORD
          EQ     BINOUT      RETURN 
 BINOUT5  SX7    B1 
          SA7    AERR        BAD RELOCATION OR TOO MANY REL FIELDS
          SA7    EFLG 
          EQ     BINOUT 
 DBSSZ    SPACE  4
**        DBSSZ - DUMP SAVED BSSZ CODING. 
*         DBSSZ CREATES THE FOLLOWING TABLES: 
* 
*         RELOCATABLE PROGRAMS... 
*                FOR LESS THAN 5 WORDS OF ZEROES... 
*                   40 TABLE FOR STORING 5 OR LESS ZEROES.
*                FOR MORE THAN 5 WORDS OF ZEROES... 
*                   40 TABLE = TEXT FOR STORING ONE ZERO. 
*                   43 TABLE = REPL FOR REPLICATING THE ZEROES. 
* 
*         FOR ABSOLUTE ROUTINES, MEMORY IS CLEARED OUT. 
  
  
 DBSSZX   MX6    0           CLEAR OUT RECORD 
          SA6    CNTBSSZ
  
 DBSSZ    PS                 RETURN EXIT
          RJ     RESORG 
          SA1    CNTBSSZ
          SA2    MACHINE
          ZR     X1,DBSSZ    QUIT IF NO WORDS TO DUMP 
          SA3    B
          ZR     X3,DBSSZX   IF NO BINARY FILE
          NZ     X2,DBSSZP   IF PP CODING 
          SA2    ABSFG
          NZ     X2,DBSSZC   IF CP ABSOLUTE PROGRAM 
          SA4    ORGBSSZ+1   CONVERT RELOCATION 
          SA2    DBTB        TEXT TABLE HEADER
 +        AX6    X4,B1
          ZR     X6,*+1 
          SX4    X4+B1       CONVERT RELOCATION 
          SA3    A4-B1
          LX4    18 
          BX5    X3 
          AX3    17 
          SX7    5
          ZR     X3,DBZ1     IF ORIGIN LESS THAN 2**17
          SA2    A2+B1       XTEXT TABLE HEADER 
          LX4    6
 DBZ1     IX2    X4+X2
          BX3    X2+X5       ADD IN ORIGIN
          SX4    B1 
          IX7    X1-X7
 +        PL     X6,*+1      IF NOT CONDITIONAL 
          LX4    33          SET CONDITIONAL LOAD FLAG
          BX3    X3+X4
 +        PL     X7,DBZ3     IF 5 OR MORE WORDS 
          LX1    36 
          IX6    X1+X3       ADD WORD COUNT 
          MX7    0
          SA6    DBZT 
          SA7    DBZT+3 
          SA7    A7+B1
          SA7    A7+B1
  
 RM       IFEQ   CP#RM,0
          LX6    -36
          WRITEW B,A6,X6+B1 
 RM       ELSE
          LX1    -36
          IX4    X1+X1
          LX1    3
          IX2    X1+X4
          SX3    X2+20
          SA1    B-1
          NZ     X1,DBZ2     IF NOT *W* RECORDS 
          PUT    B,DBZT,X3
          EQ     DBSSZX 
 DBZ2     PUTP   B,DBZT,X3
 RM       ENDIF 
  
          EQ     DBSSZX 
 DBZ3     MX0    -33
          SX4    B1          ADD 1 TO TEXT WORD COUNT 
          LX4    36 
          IX6    X3+X4
          BX7    -X0*X3 
          LX4    -36
          SA6    DBZT        STORE TEXT/XTEXT HEADER
          SA7    DBZT+4 
          IX1    X1-X4       REDUCE WORD COUNT
          MX0    -9 
          SA2    =43000002000000000001B      REPL HEADER
          SB7    42 
          BX3    X6 
          LX0    12 
          SX7    1S17-1      MAX REPL COUNT 
          SX5    B0 
          LX6    59-33
          MI     X3,DBZ4     IF NOT EXTENDED
          LX4    56 
          BX2    X2+X4       FORM XREPL HEADER
          AX3    24-18
          SB7    45 
          AX7    2
 DBZ4     PL     X6,*+1      IF NOT CONDITIONAL 
          AX3    18-12
          BX5    -X0*X3 
 +        IX6    X2+X5       INSERT BLOCK NUMBER INTO REPL HEADER 
          IX5    X7-X1
          LX7    B7 
          BX3    -X5
 +        MI     X5,*+1      IF REPL COUNT GREATER THAN MAX 
          BX3    X3-X3
          LX7    X1,B7
          SA6    A7-B1
          SA7    A7+B1
          BX6    X3          REDUCE COUNT 
          SA6    CNTBSSZ
  
 RM       IFEQ   CP#RM,0
          WRITEW B,DBZT,6    WRITE TEXT/XTEXT AND REPL/XREPL
 RM       ELSE
          SA1    B-1
          NZ     X1,DBZ5     IF NOT *W* RECORDS 
          PUT    B,DBZT,60
          EQ     DBZ6 
 DBZ5     PUTP   B,DBZT,60
 RM       ENDIF 
  
 DBZ6     SA1    CNTBSSZ
          SA2    DBZT 
          ZR     X1,DBSSZX   IF COUNT COMPLETED 
          SA4    DBZT+4 
          SA5    A4+B1
          SX6    B1 
          PL     X2,DBZ7     IF EXTENDED
          SA3    A4-B1
          SA6    A2 
          LX4    -18
          SX7    X4          CHANGE REPL TO XREPL 
          LX6    56 
          IX4    X4-X7
          BX6    X3+X6
          LX4    -6 
          BX4    X4+X7
          LX5    45-42
          LX4    24 
          SA6    A3 
 DBZ7     LX5    15 
          IX6    X4+X5       UPDATE SOURCE ADDRESS
          SX7    1S15-1 
          IX5    X7-X1
          BX3    -X5
 +        MI     X5,*+1      IF REPL COUNT GREATER THAN MAX 
          BX3    X3-X3
          BX7    X1 
 +        LX7    45 
          SA6    A4          STORE SOURCE ADDRESS 
          SA7    A5          STORE COUNT
          BX6    X3 
          SA6    A1          UPDATE CNTBSSZ 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,DBZT+3,3 
 RM       ELSE
          SA1    B-1
          NZ     X1,DBZ8     IF NOT *W* RECORDS 
          PUT    B,DBZT+3,30
          EQ     DBZ6 
 DBZ8     PUTP   B,DBZT+3,30
 RM       ENDIF 
  
          EQ     DBZ6        LOOP 
  
 DBSSZC   SA2    ORGBSSZ     OUTPUT CENTRAL MEMORY
          SA3    ORGBASE
          IX0    X2-X3
          SA4    O.MEMORY 
          IX2    X4+X0
          IX3    X2+X1
          RJ     CLS         CLEAR STORAGE
          EQ     DBSSZX 
  
 DBSSZP   SA2    ORGBSSZ     OUTPUT PP WORDS
          SA3    ORGBASE
          IX0    X2-X3
          SB2    X1 
          SX7    5
          SA3    PPTYPE 
          SX3    X3+B1
 +        NZ     X3,*+1      IF NOT BCU ASSEMBLY
          LX0    1           DOUBLE OFFSET
          SB2    B2+B2       DOUBLE PP BYTE COUNT TO STORE
 +        SX3    X3+2 
          ZR     X3,DBSSZQ   IF 180 PP ASSEMBLY 
          SB6    X0 
          IX4    X0/X7
          SB4    X4 
          LX4    2
          SX3    X4+B4
          SB7    X3 
          SB5    B6-B7
          MX0    12 
          ZR     B5,DBSSZP1 
 +        SB5    B5-B1
          LX0    48 
          NZ     B5,* 
 DBSSZP1  SA4    O.MEMORY 
          SA1    X4+B4
          BX6    -X0*X1 
          LX0    48 
          PL     X0,*+1 
          SB4    B4+B1
 +        SB2    B2-B1
          SA6    A1 
          NZ     B2,DBSSZP1 
          EQ     DBSSZX 
  
*         180 PP ASSEMBLY.  BSSZ WORDS ARE STORED IN THE PROGRAM IMAGE
*         BY ZEROING AS MANY FULL CM WORDS AS POSSIBLE... 
* 
*         1) THE STARTING POSITION AND BIT COUNT FOR THE FIRST WORD ARE 
*            DETERMINED AND THAT AMOUNT IS ZEROED.
*         2) IF THE BSSZ COUNT IS LARGE ENOUGH TO INCLUDE MORE WORDS, 
*            THEN AS MANY FULL WORDS AS POSSIBLE ARE ZEROED.
*         3) THE REMAINING BIT COUNT FOR THE FINAL WORD IS DETERMINED 
*            AND THAT AMOUNT IS ZEROED. 
  
 DBSSZQ   LX1    4           (X1) = CBIT = NUMBER OF BITS TO STORE
          SX7    60 
          LX0    4           RELATIVE BIT OFFSET
          BX4    X0 
          IX2    X0/X7       (X2) = POS = OFFSET TO FIRST WORD
          SB6    X2 
          BX3    X2 
          LX2    2           POS*4
          LX3    6           POS*64 
          IX2    X3-X2       POS*60 
          IX3    X4-X2       (X3) = ST = LEFT-MOST BIT FOR FIRST WORD 
          SX4    X1+59       CBIT + 59
          IX4    X4+X3       ST + CBIT + 59 
          SX7    60 
          IX7    X4/X7       (ST + CBIT + 59) / 60
          SX7    X7-1        (X7) = RW = NUMBER OF ADDITIONAL WORDS 
          SB2    60 
          SB4    X3          (B7) = SE = NO. BITS TO ZERO IN FIRST WORD 
          SB7    B2-B4            = 60 - ST 
          SB5    B7 
          NZ     X7,DBQ1
          SB7    X1          (B7) = SE = CBIT 
 DBQ1     MX0    1           FORM MASK FOR ZEROING IN FIRST WORD
          SB4    B7-B1
          AX0    X0,B4
          LX0    X0,B5       POSITION MASK
          SA4    O.MEMORY    ZEROING INTO FIRST WORD
          SA4    X4+B6
          BX6    -X0*X4 
          SA6    A4 
          ZR     X7,DBSSZX   RETURN IF NO ADDITIONAL WORDS
          MX6    0
          SB3    X7-1        (REMAINING WORDS) - 1
          ZR     B3,DBQ3     IF NO FULL WORDS 
 DBQ2     SB3    B3-B1       LOOP ON FULL WORDS 
          SA6    A6+B1
          NZ     B3,DBQ2
  
 DBQ3     BX6    X7          CLEAR BITS IN LAST WORD
          LX7    2           RW*4 
          LX6    6           RW*64
          IX7    X6-X7       RW*60
          IX7    X3-X7       ST - (RW*60) 
          IX7    X1+X7       SE = ST + CBIT - RW*60  (BITS IN LAST WORD)
          SB6    X7-1        FORM MASK FOR UPPER PART OF LAST WORD
          MX0    1
          AX0    X0,B6
          SA2    A6+B1       ZERO BITS IN LAST WORD 
          BX6    -X0*X2 
          SA6    A2 
          EQ     DBSSZX      RETURN 
  
 DBZT     BSSZ   6           TEMPORARY
 DDUMP    SPACE  4
**        DDUMP - DUMP CODING.
*         DDUMP DUMPS MEMORY FOR ABSOLUTE ROUTINES. 
*         ORGBASE/LPGM GOVERN AMOUNT TO DUMP. 
*         FOR PP ROUTINES, THE CONTROL WORD IS FORMED AND OUTPUT HERE.
*         FOR 7600 PP FORMAT THE 5200 TABLE IS FORMED HERE. 
  
  
 DDUMP    PS                 RETURN EXIT
          SA3    B
          ZR     X3,DDUMP    IF NO BINARY FILE
          SA1    ERCNT
          SA2    CP.ERRCT 
          ZR     X1,DDUMPA   IF NO ERRORS 
          PL     X2,DDUMP    IF D NOT SET 
 DDUMPA   SA1    ABSFG
          SA2    MACHINE
          ZR     X1,DDUMP    IF CP RELOCATABLE
          ZR     X2,DDUMPC   IF CP ABSOLUTE 
          SA1    LPGM 
          SA2    ORGBASE
          SX0    5
          SA5    DKNAM
          SA3    PPTYPE 
          SB7    X3+3 
          ZR     B7,DDUMPK   IF 180 PP ASSEMBLY 
          IX1    X1-X2       CALCULATE PROGRAM LENGTH 
          ZR     X3,DDUMPE   IF PERIPH TYPE 
          PL     X3,DDUMPJ   IF PPU TYPE
          SX3    X3+B1
          LX1    1
          ZR     X3,DDUMPJ   IF BCU TYPE
          AX1    1
 DDUMPJ   SA3    SEGEPT 
          SX5    5200B
          LX5    48 
          BX5    X5+X3
 DDUMPE   IX3    X2-X0       PROGRAM ORIGIN 
          PL     X3,DDUMPB
          MX7    48          MASK 12 BITS 
          BX3    -X7*X3 
          SX3    X3+1        2-S COMPLEMENT ORGBASE 
 DDUMPB   LX3    24 
          BX7    X3+X5
          PL     X1,DDUMPG
          MX1    0           CHANGE NEGATIVE TO ZERO
 DDUMPG   SX2    X1+9 
          IX1    X2/X0
          BX7    X1+X7
          SX6    X1-1 
          SA7    BTEMP
  
          IFNE   CP#RM,0,3
          IX4    X6+X6
          LX6    3
          IX6    X4+X6
  
          SA6    A7+B1
          SA1    NOLFG
  
 RM       IFEQ   CP#RM,0
          SX1    X1-1 
          ZR     X1,DDUMPF   IF NO LABEL
          WRITEW B,A7,1 
 DDUMPF   SA3    BTEMPA 
          SA2    O.MEMORY 
          WRITEW B,X2,X3
 RM       ELSE
          SA2    PCC
          SX3    X1-1 
 +        ZR     X3,*+1      IF NO HEADER WANTED
          SX6    X6+10
 +        SA1    B-1                                                    S028 712
          IX4    X2+X6
 +        ZR     X1,*+1      IF RECORD TYPE W                           S028 714
          SX4    0                                                      S028 715
          STORE  B,RL=X4
          ZR     X3,DDUMPF   IF NO LABELS AT ALL
          ZR     X2,DDUMPH   IF PRFX TABLE NOT WANTED 
          PUTP   B,PRFX,X2
 DDUMPH   PUTP   B,BTEMP,10 
 DDUMPF   SA2    O.MEMORY 
          SA3    BTEMPA 
          ZR     X3,DDUMP    IF NO BINARY                               S028 717
          PUTP   B,X2,X3
 RM       ENDIF 
  
          EQ     DDUMP
  
 DDUMPC   SA4    LPGM 
          SA5    ORGBASE
          IX3    X4-X5
          NG     X3,DDUMP    IF NO BINARY 
          ZR     X3,DDUMP                                               S028 719
          SA2    O.MEMORY 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,X2,X3
 RM       ELSE
          IX5    X3+X3
          LX3    3
          IX4    X3+X5
          SA1    B-1
          NZ     X1,DDUMP2   IF NOT W RECORDS 
          PUT    B,X2,X4
          EQ     DDUMP
 DDUMP2   PUTP   B,X2,X4
 RM       ENDIF 
          EQ     DDUMP
  
 DDUMPK   SX7    6100B       FORM 6100 TABLE HEADER - 
          LX7    48          VFD  12/6100B,16/(ENTRY),16/(LDFWA),16/(CT)
          LX2    16*1        POSITION LOAD FWA (ORGBASE)
          SA5    L.MEMORY    LENGTH OF MEMORY IMAGE IN CM WORDS 
          SA4    SEGEPT      ISOLATE ENTRY ADDRESS
          MX0    -12
          AX4    12 
          BX6    -X0*X4 
          SX3    X5+B1       LENGTH IN HEADER TO INCLUDE HEADER WORD
          LX6    16*2        POSITION ENTRY ADDRESS 
          BX7    X7+X3       MERGE FIELDS 
          BX7    X7+X2
          BX7    X7+X6
          SA7    BTEMP       SAVE HEADER WORD 
  
 RM       IFEQ   CP#RM,0
          SA1    NOLFG
          SX1    X1-1 
          ZR     X1,DDUMPL   IF NO HEADER WANTED
          WRITEW B,BTEMP,1   WRITE HEADER WORD
 DDUMPL   SA2    O.MEMORY 
          WRITEW B,X2,X5     WRITE MEMORY IMAGE (X5 = CM WORD COUNT)
  
 RM       ELSE
          IX4    X5+X5       SAVE BINARY LENGTH IN CHARS
          LX5    3
          IX6    X4+X5
          SA6    A7+B1
          SA1    NOLFG       (X3) = 0 IF NO LABELS WANTED 
          SA2    PCC         (X2) = PRFX LENGTH IN CHARS (OR 0) 
          SX3    X1-1 
          ZR     X3,DDUMPL   IF NO HEADER WANTED
          SX6    X6+10       INCLUDE HEADER IN RECORD LENGTH
 DDUMPL   SA1    B-1
          IX4    X2+X6       INCLUDE PRFX IN RECORD LENGTH
          ZR     X1,DDUMPM   IF RECORD TYPE W 
          SX4    0
 DDUMPM   STORE  B,RL=X4
          ZR     X3,DDUMPP   IF NO LABELS AT ALL
          ZR     X2,DDUMPN   IF PRFX TABLE NOT WANTED 
          PUTP   B,PRFX,X2
 DDUMPN   PUTP   B,BTEMP,10 
 DDUMPP   SA2    O.MEMORY 
          SA3    BTEMPA 
          ZR     X3,DDUMP    IF NO BINARY 
          PUTP   B,X2,X3
 RM       ENDIF 
  
          EQ     DDUMP       RETURN 
 DFIRST   SPACE  4
**        DFIRST - DUMP PRELIMINARY BINARY INFORMATION. 
*         DFIRST CREATES THE FOLLOWING TABLES:  
* 
*         RELOCATABLE ROUTINES. 
*                77 TABLE = IDENT.
*                70 TABLE = LDSET.
*                34 TABLE = PIDL. 
*                36 TABLE = ENTR. 
* 
*         ABSOLUTE CP ROUTINES. 
*                77 TABLE = IDENT.
*                50 TABLE = OVERLAY CONTROL WORD. 
* 
*         ABSOLUTE CP ROUTINES WITH ENTRY POINTS. 
*                77 TABLE = IDENT.
*                51 TABLE = OVERLAY ENTRY POINT TABLE.
* 
*         PP ROUTINES.
*                77 TABLE = IDENT.
* 
*         FOR ALL ABSOLUTE ROUTINES, ALLOCATES AND CLEARS MEMORY. 
*         FOR ALL ROUTINES, UPS DKCNT AND CLEARS BINARY RECORD. 
*         ENTRY  (X1) = DECK NAME.
*                (X2) = OVERLAY LEVEL NUMBER. 
  
  
 DFIRSTP  BSS    0
 DFIRSTX  SA1    DKCNT       INCREMENT DECK COUNT 
          SA2    QVAL+1 
          SX6    X1+B1
          BX7    X2          RESTORE QUAL VALUE 
          SA6    A1 
          SA7    A2-B1
                                                                        S028 721
          IFNE   CP#RM,0,1                                              S028 722
          STORE  B,RL=0                                                 S028 723
                                                                        S028 724
          RJ     SBL         SET BINARY LENGTH
  
 DFIRST   PS                 RETURN EXIT
          BX6    X2          SAVE SEGMENT INDICATOR 
          SA6    BTEMP
          RJ     LJUST       LEFT JUSTIFY DECK NAME 
          SA7    DKNAM       SET DECK NAME
          SA7    PRFX+1 
          RJ     DIM         DISPLAY IDENT MESSAGE
          MX1    0
          RJ     SQV         SET BLANK QUALIFIER
          SA1    B
          ZR     X1,DFIRSTP  IF NO BINARY FILE
          CHECK  B
  
 RM       IFEQ   CP#RM,6                                                S028 726
          FETCH  B,OC,X1
          SX6    X1-#YES# 
          ZR     X6,DFIRST0  IF BINARY FILE IS OPEN 
          OPENM  B,OUTPUT,N 
 RM       ENDIF 
  
 DFIRST0  SA3    NOLFG
          MX6    0
          NZ     X3,DFIRSTA  IF NO LABELS 
          SA1    MACHINE
          SA2    TARGET 
          SA3    VALID
          SX6    2R 
          ZR     X1,DFT4     IF CPU ASSEMBLY
          BX2    X6 
          SX6    X3+1RP 
          EQ     DFT4A
 DFT4     ZR     X3,DFT4A    IF NO VALID PROCESSOR SPECIFIED
          SX6    X3+1RX 
 DFT4A    LX2    12 
          SA3    FMODE
          BX6    X2+X6
          MX0    30 
          SA4    PRFX+6 
          LX6    6
          SX7    1R 
          SA2    ABSFG
          ZR     X3,DFT5     IF FMODE = 0 
          SX7    X3+1R0 
 DFT5     BX5    X0*X4
          IX6    X6+X7
          SA3    =4RHPA 
          MX0    -6 
          BX6    X5+X6
          ZR     X2,DFT6     IF REL CPU ASSEMBLY
          AX3    6
          ZR     X1,DFT6     IF ABS CPU ASSEMBLY
          AX3    6           PPU ASSEMBLY 
          SA2    PPTYPE 
          SX2    X2+3 
          NZ     X2,DFT6     IF NOT 180 PPU ASSEMBLY
          AX3    6           SET *TYPE* = H 
 DFT6     BX7    -X0*X3 
          SA1    HTYPE
          LX7    54 
          BX7    X7+X1
          SA6    A4          STORE WORDS 6 AND 7 OF PRFX TABLE
          SA7    A4+B1
          SB4    PRFXC
          SB5    PRFXC+7
          MX6    0
 +        SA6    B4          CLEAR PRFX COMMENT AREA
          SB4    B4+B1
          NE     B4,B5,*
          SA3    O.IDTAB
          SB6    X3+B1
          MX0    -12
          SA1    O.SEGTAB    FIND COMMENT TEXT IN IDTAB 
          SA2    SI 
          IX6    X1+X2
          SA1    X6+B1
          SA2    A1+4 
          SB4    PRFXC
          SB7    B6+X2
          SB6    B6+X1
 DFT1     SA1    B6          FIND END OF COMPRESSED 
          BX6    -X0*X1      BINARY CONTROL STATEMENT 
          SB6    B6+B1
          NZ     X6,DFT1
          SB7    B7-B1
 DFT1A    GE     B6,B7,DFT1B IF END OF COMMENT TEXT 
          SA1    B6 
          SB6    B6+B1
          BX6    X1 
          SA6    B4 
          SB4    B4+B1
          LT     B4,B5,DFT1A IF PRFX TABLE NOT FULL 
 DFT1B    BSS    0
  
          IFEQ   CP#RM,0,1
          WRITEW B,PRFX,LPRFX 
  
          SA3    NOLFG
          SX6    10*LPRFX 
 DFIRSTA  SA6    PCC
          SA1    MACHINE
          SA2    ABSFG
          SX3    X3-1 
          NZ     X1,DFIRSTP  IF PP, QUIT
          ZR     X2,DFIRST1  IF RELOCATABLE 
          ZR     X3,DFIRSTP  IF NO HEADERS WANTED 
          SA1    EI 
          SA2    A1+B1
          IX5    X2-X1
          ZR     X5,DFT3     IF NOT MULTIPLE ENTRY POINT OVERLAY
          SX1    5100B       OVERLAY IDENT WORD 
          SA3    ORGBASE
          MX0    42 
          LX1    48 
          SX3    X3-1 
          IX3    X3-X5
          BX6    -X0*X3 
          LX6    18 
          IX1    X1+X5
          BX6    X6+X1
          SA1    BTEMP
          LX1    36 
          IX6    X6+X1
          SA6    OVLHDR 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,A6,1 
 RM       ELSE
          IX7    X5+X5
          SA1    PCC
          SA2    B-1                                                    S028 728
          LX5    3
          SX3    X1+10
          IX7    X5+X7
 +        IX4    X3+X7                                                  S028 730
          ZR     X2,*+1      IF RECORD TYPE W                           S028 731
          SX4    B0                                                     S028 732
          STORE  B,RL=X4
          SX2    PRFX 
 +        NZ     X1,*+1      IF PRFX TABLE WANTED 
          SX2    OVLHDR 
          PUTP   B,X2,X3
 RM       ENDIF 
  
 DFT2     SA1    O.EPTAB     OUTPUT ENTRY POINT TABLE 
          SA2    EI 
          SA3    A2+B1
          IX3    X3-X2
          ZR     X3,DFIRSTP  IF END OF EPTAB
          SX6    X2+B1
          SA6    A2 
          IX1    X1+X2
          SA1    X1 
          RJ     TLUSYMT
          MX0    42 
          BX5    -X0*X2 
          RJ     LJUST
          BX6    X7+X5
          SA6    BINREC 
  
          IFEQ   CP#RM,0,2
          WRITEW B,A6,1 
          ELSE   1
          PUTP   B,BINREC,10
  
          EQ     DFT2        LOOP 
 DFT3     SA1    =5000BS48   OVERLAY IDENT WORD 
          SA2    SEGEPT 
          SA3    ORGBASE
          SA4    BTEMP
          MX0    42 
          SX3    X3-1 
          BX3    -X0*X3 
          LX3    18 
          LX4    36 
          BX1    X2+X1
          IX3    X4+X3
          BX6    X1+X3
          SA6    OVLHDR 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,A6,1 
 RM       ELSE
          SA1    PCC
          SA2    B-1                                                    S028 734
          SX3    X1+10
          BX4    X3                                                     S028 736
 +        ZR     X2,*+1      IF RECORD TYPE W                           S028 737
          SX4    0                                                      S028 739
          STORE  B,RL=X4                                                S028 740
          SX2    PRFX                                                   S028 741
 +        NZ     X1,*+1      IF PRFX WANTED 
          SX2    OVLHDR 
          PUTP   B,X2,X3
 RM       ENDIF 
  
          EQ     DFIRSTX
  
 RM       IFEQ   CP#RM,0
 DFIRST1  SA3    L.TLDS      WRITE LDSET TABLE
          ZR     X3,DFIRST1A IF TABLE EMPTY 
          SB3    X3-1 
          ZR     B3,DFIRST1A
          RJ     LDHDR       PLACE CORRECT WC IN CONTROL WORD 
          SA1    O.TLDS 
          SA3    L.TLDS 
          SX3    X3-1        DROP EXTRA LDSET CONTROL WORD
          WRITEW B,X1,X3
 RM       ENDIF 
  
 RM       IFNE   CP#RM,0
 DFIRST1  SA1    L.TLDS 
          SA2    NBLOCKS     PIDL BLOCK COUNT 
          SA3    PCC         PRFX CHARACTER COUNT 
          SA4    L.EPTAB
          ZR     X1,DFIRST1B IF NO TLDS 
          SX5    X1+B1       ADD HEADER WORD
          IX6    X5+X5       MULTIPLY BY TEN
          LX5    3
          IX1    X5+X6       LDSET CHARACTER COUNT
 DFIRST1B IX5    X2+X2       MULTIPLY BY TEN
          LX2    3
          IX6    X2+X5       PIDL CHARACTER COUNT 
          SX7    X6+20       ADD TWO HEADER WORDS FOR PIDL TABLE
          ZR     X4,DFIRST1C IF NO ENTRY POINTS 
          LX4    1
          SX2    X4+B1       LENGTH OF ENTRY TABLE
          IX5    X2+X2       MULTIPLY BY TEN
          LX2    3
          IX4    X2+X5       ENTRY TABLE CHARACTER COUNT
 DFIRST1C IX2    X3+X1
          IX5    X4+X7
          IX4    X2+X5       CHAR COUNT OF TABLES ABOVE 
          SX6    X1-10       LENGTH OF TLDS  WITHOUT HEADER WORD
          SA7    T6RM1       SAVE PIDL CHARACTER COUNT
          SA6    T6RM2       SAVE LDSET CHAR COUNT WITHOUT HEADER WORD
          SA2    B-1
 +        ZR     X2,*+1      IF RECORD TYPE W 
          SX4    0
          STORE  B,RL=X4
          ZR     X3,DFIRST1D IF NO PRFX TABLE 
          PUTP   B,PRFX,X3
 DFIRST1D SA3    L.TLDS      WRITE LDSET TABLE
          SB2    36 
          SX2    70B
          LX2    59-5 
          ZR     X3,DFIRST1A IF NO LDSET TABLE
          LX4    X3,B2
          BX6    X2+X4       INSERT WORD COUNT
          SA6    BTEMP
          PUTP   B,BTEMP,10  WRITE HEADER WORD
          SA1    O.TLDS 
          SA3    T6RM2
          PUTP   B,X1,X3
 RM       ENDIF 
  
          RJ     ASU         ACCUMULATE STORAGE USED
  
          MX6    0           CLEAR TLDS 
          SA6    L.TLDS 
  
 DFIRST1A SA1    =34000001BS36     WRITE PIDL TABLE 
          SA2    NBLOCKS
          LX2    36 
          IX6    X1+X2
          SA1    DKNAM
          SA2    ENDP 
          BX7    X1+X2
          SA6    RELVEC 
          SA7    A6+B1
          MX6    0
          SA6    BTEMPA      CLEAR LOOP INDEX 
          SA6    A6+B1
 DFIRST2  SA1    O.USETAB 
          SA4    UI 
          IX1    X1+X4       BASE ADDRESS OF BLOCK GROUP
          IX3    X1+X6
          SA4    X3+2        FETCH ORIGIN OF BLOCK
          MX0    -8 
          AX4    25          CHECK BLOCK NUMBER 
          BX4    -X0*X4 
          ZR     X4,DFIRST3  IF ABSOLUTE OR SCM LOCAL BLOCK 
          SA1    A4-2        FETCH BLOCK NAME 
 +        NZ     X1,*+1      CHANGE ZERO NAME TO BLANK
          SA1    =7R
          BX0    X1          UNCOMPLEMENT NAME IF LCM 
          AX1    60 
          BX1    X0-X1
          RJ     LJUST
          SA2    BTEMPB 
          SA3    A4-2 
          SA1    A4 
          MX0    -9 
          SX6    X2+B1
          LX1    -33
          PL     X3,DFIRST2B  IF SCM COMMON BLOCK 
          SA5    LLB
          LX1    33 
          LX0    24 
          SX2    X6+B1
          BX3    -X0*X1 
          LX2    24 
          IX4    X3-X5
          BX5    X2-X5
          LX1    -33
          NZ     X4,DFIRST2A IF LCM COMMON BLOCK
          NZ     X5,DFIRST3  IF NOT FIRST LCM LOCAL BLOCK 
          SA1    LCM
          MX7    0
 DFIRST2A SX3    7
          SX0    B1          ROUND UP BLOCK SIZE TO A MULTIPLE
          IX1    X1+X3       OF 8 AND SET BIT 17 FOR LCM BLOCK
          LX0    17 
          AX1    3
          BX1    X1+X0
 DFIRST2B MX0    42 
          BX4    X7*X0
          BX2    -X0*X1 
          IX7    X2+X4
          SA6    A2 
          SA7    RELVEC+1+X6
 DFIRST3  SA1    BTEMPA 
          SA2    L.USETAB 
          SX6    X1+4 
          BX3    X2-X6
          SA6    A1 
          NZ     X3,DFIRST2 
  
          IFEQ   CP#RM,0,3
          SA1    NBLOCKS
          WRITEW B,RELVEC,X1+2
          ELSE   2
          SA3    T6RM1
          PUTP   B,RELVEC,X3
  
  
*         OUTPUT ENTR TABLE.
  
          SA1    L.EPTAB
          SA2    =36000000BS36
          LX1    37 
          BX6    X1+X2
          SA6    BTEMPB 
          MX7    0
          ZR     X1,DFIRST5  IF NO ENTRY POINTS 
          SA7    A6-B1
  
          IFEQ   CP#RM,0,2
          WRITEW B,A6,1 
          ELSE   1
          PUTP   B,BTEMPB,10
  
 DFIRST4  SA1    O.EPTAB
          SA2    BTEMPA 
          IX3    X1+X2
          SA1    X3          FETCH ENTRY POINT NAME 
          MX0    1
          BX1    -X0*X1      CLEAR CONDITIONAL FLAG 
          RJ     TLUSYMT     LOOK UP SYMBOL 
          MX0    -18         EXTRACT SYMBOL DEFINITION
          BX6    -X0*X2      VALUE
          AX2    21 
          MX0    -9 
          BX7    -X0*X2      RELOCATION 
          AX4    X7,B1
          ZR     X4,DFIRST4B  IF ABSOLUTE OR SCM LOCAL
          MX4    -8 
          BX4    -X4*X2 
          LX2    59-31+21 
          SX7    X4+B1       CORRECT COMMON OR NEGATIVE RELOCATION
          MI     X2,DFIRST4B  IF EXTERNAL 
          SA5    O.USETAB 
          SA2    UI 
          IX5    X2+X5       BASE ADDRESS OF BLOCK GROUP
          LX4    24 
          SA5    X5+2 
          LX0    24 
 DFIRST4A BX2    -X0*X5      SEARCH USE TABLE FOR BLOCK 
          BX2    X2-X4       WITH MATCHING RELOCATION 
          SA5    A5+4 
          NZ     X2,DFIRST4A
          SA4    A5-6        GET BLOCK NAME 
          PL     X4,DFIRST4B  IF NOT LCM
          RX2    X3 
          MX0    -21         USE 21-BIT VALUE 
          BX6    -X0*X2 
          LX6    36 
 DFIRST4B LX7    18 
          BX6    X7+X6
          SA6    BINREC+1 
          RJ     LJUST
          SA1    A1 
          BX3    X3-X3
          PL     X1,DFIRST4C  IF NOT CONDITIONAL
          SA2    A6 
          AX2    18          EXTRACT LOAD CONDITION 
          SX4    X2-1 
          AX5    X4,B1
          ZR     X5,DFIRST4C IF NOT A COMMON BLOCK
          SA5    LLB
          LX4    24 
          BX3    X4-X5
          ZR     X3,DFIRST4C IF LCM LOCAL BLOCK 
          AX4    24 
          SX3    X4+B1
 DFIRST4C BX6    X7+X3
          SA6    A6-B1
  
          IFEQ   CP#RM,0,2
          WRITEW B,A6,2 
          ELSE   1
          PUTP   B,BINREC,20
  
          SA1    BTEMPA 
          SA2    L.EPTAB
          SX6    X1+B1
          BX4    X6-X2
          SA6    A1 
          NZ     X4,DFIRST4 
  
*         INITIALIZE CHAIN CELLS. 
  
 DFIRST5  MX6    0
          SA6    L.LNKTAB 
          SA6    L.COMTAB 
          SA6    BINREC 
          SA6    A6+B1
          EQ     DFIRSTX
 DLAST    SPACE  4
**        DLAST - DUMP TERMINAL LOADER TABLES.
*         THIS ROUTINE IS NON-NULL FOR RELOCATABLE ROUTINES ONLY. 
*         DLAST CREATES THE FOLLOWING TABLES: 
*                42 TABLE = FILL FOR COMMON LINKAGE.
*                44 TABLE = LINK FOR EXTERNAL LINKAGE.
*                43 TABLE = REPL FOR ENTRIES IN REPTAB. 
*         THIS ROUTINE ALSO CLEARS OUT THE DUMPED TABLES. 
*         THIS ROUTINE MUST BE CALLABLE FROM MANAGER, SO NO MANAGER 
*         CALLS MAY EXIST IN IT.
  
  
 DLAST    PS                 RETURN EXIT
          SA1    ABSFG
          SA2    B
          NZ     X1,DLAST    IF PP OR ABS CP ASSEMBLY 
          ZR     X2,DLAST20  IF NO BINARY FILE
  
*         DUMP OUT COMMON LINKAGE TABLES. 
  
          SA1    O.COMTAB 
          SA2    L.COMTAB 
          ZR     X2,DLAST10  IF LINKAGE TABLE EMPTY 
          SX6    B1 
          MX0    30 
          SX1    X1+B1       SKIP FIRST WORD
          IX2    X2-X6
          SA6    DLASTT 
          RJ     DSORT       SORT COMMON TABLE
          EQ     DLAST2 
  
 DLAST1   LX1    12          TABLE TYPE (4100B OR 4200B)
          SX5    A6-B5       WORD COUNT 
          BX3    X1+X5
          LX3    36 
          BX6    X3+X7       HEADER WORD
          SX7    B6          COMTAB INDEX 
          SA6    B5 
          SA7    DLASTT 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,B5,X5+B1  WRITE FILL/XFILL TABLE 
 RM       ELSE
          SX1    B5 
          SX3    X5+B1
          IX4    X3+X3
          LX3    3
          IX4    X3+X4
          SA2    B-1
          NZ     X2,DLA1     IF NOT W RECORDS 
          PUT    B,X1,X4
          EQ     DLAST2 
 DLA1     PUTP   B,X1,X4
 RM       ENDIF 
  
 DLAST2   SA1    O.COMTAB 
          SA2    L.COMTAB 
          SA3    DLASTT 
          SB7    X2 
          SB6    X3 
          GE     B6,B7,DLAST10  IF END OF TABLE 
          SA4    X1 
          SA1    X1+B6
          MX5    3
          BX6    X4 
          SB3    B0 
          SA6    A4 
          SB5    A4 
          SX6    B0 
          BX7    X5*X1
          AX5    9
          NZ     X7,DLAST6   IF CONDITIONAL XFILL 
          BX7    X5*X1
          AX5    9
          NZ     X7,DLAST7   IF UNCONDITIONAL XFILL 
          MX0    30 
          BX7    X5*X1
          MX5    -9          FILL (CONDITIONAL OR NOT)
          SB2    30 
          LX5    30 
  
 DLAST3   BX2    -X5*X1      EXTRACT CONTROL BYTE 
          LX3    X2,B3
          SB3    B2-B3
          IX6    X6+X3
          BX2    X0*X1
          NZ     B3,DLAST4   IF FILL WORD NOT FULL
          SA6    A6+B1
          SB0    0
          BX6    X6-X6
 DLAST4   SB3    B2-B3       EXTRACT DATA BYTE
          BX3    -X0*X1 
          LX4    X3,B3
          IX6    X6+X4
          SB6    B6+B1       INCREMENT INDEX INTO COMTAB                 CPSA083
          NZ     B3,DLAST4A  IF FILL WORD NOT FULL                       CPSA083
          SA6    A6+B1
          SX1    A6-B5       PRESENT WORD COUNT OF 4200 TABLE            CPSA083
          SX3    X1-7777B    CHECK IF WORD COUNT AT MAXIMUM              CPSA083
          PL     X3,DLAST5   IF WORD COUNT AT MAX, DUMP THIS TABLE       CPSA083
          BX6    X6-X6
 DLAST4A  SA1    A1+B1       GET NEXT WORD OF COMTAB                     CPSA083
          BX3    X0*X1
          IX4    X3-X2
          GE     B6,B7,DLAST5  IF END OF TABLE
          ZR     X4,DLAST4   IF SAME CONTROL BYTE AND SAME CONDITION
          BX3    X5*X3
          IX4    X3-X7
          ZR     X4,DLAST3   IF SAME CONDITION
 DLAST5   ZR     B3,*+1      IF LAST FILL WORD IS FULL
          SA6    A6+B1
 +        SX1    4200B       WRITE FILL TABLE 
          AX7    39-12
          EQ     DLAST1 
  
 DLAST6   MX0    12          PREPARE TO GENERATE CONDITIONAL XFILL
          BX7    X0*X1
          SB2    60-48
          MX2    9
          LX2    -3 
          SB3    9
          MX3    -42
          EQ     DLAST8 
 DLAST7   MX0    3           PREPARE TO GENERATE UNCONDITIONAL XFILL
          SX7    B0 
          SB2    60-39
          MX2    18 
          LX2    -3 
          SB3    18 
          MX3    -33
 DLAST8   BX4    X0*X1       GENERATE XFILL TABLE 
          BX5    X2*X1
          BX6    -X3*X1 
          IX4    X4-X7
          LX5    X5,B2
          LX6    X6,B3
          NZ     X4,DLAST9   IF NOT SAME CONDITION
          BX6    X6+X5
          SA6    A6+B1       STORE XFILL WORD 
          SB6    B6+B1       INCREMENT INDEX INTO COMTAB
          SX1    A6-B5       PRESENT WORD COUNT OF 4100 TABLE 
          SX1    X1-7777B    CHECK IF WORD COUNT AT MAXIMUM 
          PL     X1,DLAST9   IF WORD COUNT AT MAX, DUMP THIS TABLE
          SA1    A1+B1       GET NEXT WORD OF COMTAB
          LT     B6,B7,DLAST8  IF NOT END OF TABLE
 DLAST9   BX7    X2*X7
          SX1    4100B       WRITE XFILL TABLE
          AX7    48-12
          EQ     DLAST1 
  
*         DUMP OUT EXTERNAL REFERENCES. 
  
 DLAST10  SA1    O.LNKTAB 
          SA2    L.LNKTAB 
          SA3    L.EXTAB
          ZR     X2,DLAST20  IF TABLE IS EMPTY
          MX0    30+9 
          SX6    X3+B1
          IX1    X1+X6       SKIP FIRST (L.EXTAB)+1 WORDS 
          LX0    9
          IX2    X2-X6
          SA6    DLASTT 
          RJ     DSORT       SORT EXTERNAL REFERENCE TABLE
          EQ     DLAST12
  
 DLAST11  LX1    12          TABLE TYPE (4400B OR 4500B)
          SX5    A6-B5       WORD COUNT 
          BX3    X1+X5
          LX3    36 
          BX6    X3+X7       HEADER WORD
          SX7    B6          LNKTAB INDEX 
          SA6    B5 
          SA7    DLASTT 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,B5,X5+B1  WRITE LINK/XLINK TABLE 
 RM       ELSE
          SX1    B5 
          SX3    X5+B1
          IX4    X3+X3
          LX3    3
          IX4    X3+X4
          SA2    B-1
          NZ     X2,DLA2     IF NOT TYPE W RECORDS
          PUT    B,X1,X4
          EQ     DLAST12
 DLA2     PUTP   B,X1,X4
 RM       ENDIF 
  
 DLAST12  SA1    O.LNKTAB 
          SA2    L.LNKTAB 
          SA3    DLASTT 
          SA4    X1 
          SB5    X1 
          SB7    X2 
          SB6    X3 
          SA5    O.EXTAB
          GE     B6,B7,DLAST20  IF END OF TABLE 
          BX6    X4 
          SA1    X1+B6
          SB4    X5-1 
          MX5    3
          SA6    A4 
          SB2    30 
          BX7    X5*X1
          AX5    9
          NZ     X7,DLAST16  IF CONDITIONAL XLINK 
          BX7    X5*X1
          AX5    9
          NZ     X7,DLAST17  IF UNCONDITIONAL XLINK 
          MX0    30 
          BX7    X5*X1
          MX5    -9          LINK (CONDITIONAL OR NOT)
          SB3    30 
          LX5    30 
  
 DLAST13  BX2    -X5*X1      EXTRACT EXTERNAL ORDINAL 
          LX3    X2,B2
          SA4    X3+B4       GET NAME 
          BX6    X4 
          SB3    B2 
          SA6    A6+B1       STORE NAME 
          BX2    X0*X1
          SX6    B0 
 DLAST14  BX3    -X0*X1      EXTRACT DATA BYTE
          LX4    X3,B3
          SB3    B2-B3
          IX6    X6+X4
 +        ZR     B3,*+1      IF LINK WORD NOT FULL
          SA6    A6+B1
          BX6    X6-X6
 +        SA1    A1+B1       GET NEXT WORD OF LNKTAB
          SB6    B6+B1
          BX3    X0*X1
          IX4    X3-X2
          GE     B6,B7,DLAST15  IF END OF TABLE 
          ZR     X4,DLAST14  IF SAME EXTERNAL AND SAME CONDITION
 +        NZ     B3,*+1      IF LINK WORD IS FULL 
          SB3    B2 
          SA6    A6+B1       STORE WORD PADDED WITH ZEROS 
 +        BX3    X5*X3
          IX4    X3-X7
          ZR     X4,DLAST13  IF SAME CONDITION
 DLAST15  AX7    39-12
          NZ     B3,*+1      IF LAST LINK WORD IS FULL
          SA6    A6+B1
 +        SX1    4400B       WRITE LINK TABLE 
          EQ     DLAST11
  
 DLAST16  MX0    12+9        PREPARE TO GENERATE CONDITIONAL XLINK
          LX0    9
          SB2    60-48
          MX2    9
          LX2    -3 
          SB3    9
          MX3    -42+9
          LX3    9
          MX5    -9 
          BX5    -X5*X1 
          EQ     DLAST18
 DLAST17  MX0    9           PREPARE TO GENERATE UNCONDITIONAL XLINK
          LX0    -3 
          SB2    60-39
          MX2    9
          LX2    47-59
          SB3    18 
          MX3    -33
          BX5    X0*X1
          AX5    48 
 DLAST18  SA4    X5+B4       GET EXTERNAL NAME
          LX6    X4 
          BX7    X0*X1
          SA6    A6+B1       GENERATE XLINK TABLE 
 DLAST18A BX4    X0*X1
          BX5    X2*X1
          BX6    -X3*X1 
          IX4    X4-X7
          LX5    X5,B2
          LX6    X6,B3
          NZ     X4,DLAST19  IF NOT SAME EXTERNAL AND SAME CONDITION
          BX6    X6+X5
          SA6    A6+B1       STORE XLINK WORD 
          SB6    B6+B1
          SA1    A1+B1       GET NEXT WORD OF LNKTAB
          LT     B6,B7,DLAST18A  IF NOT END OF TABLE
 DLAST19  BX7    X2*X7
          SX1    4500B       WRITE XLINK TABLE
          AX7    48-12
          EQ     DLAST11
  
 DLAST20  RJ     ASU         ACCUMULATE STORAGE USED
          SX6    B0 
          SA6    L.COMTAB    CLEAR TABLES 
          SA6    L.LNKTAB 
          EQ     DLAST       RETURN 
  
 DLASTT   DATA   0           TEMPORARY STORAGE
 DLT      SPACE  4
**        DLT - DUMP OUT LITERAL TABLE. 
  
  
 DLT      PS                 RETURN EXIT
          SA1    B
          MX6    0
          ZR     X1,DLT      IF NO BINARY FILE
          SA6    DLTA 
          SA1    O.USETAB 
          SA2    UI 
          IX1    X1+X2
          SA1    X1+2*4+2 
          MX0    -21
          BX6    -X0*X1      ORIGIN OF LITERALS BLOCK 
          MX0    -9 
          AX1    24 
          BX7    -X0*X1      RELOCATION 
          AX1    9
          IX2    X6-X1
          PL     X2,DLT      IF NO LITERALS 
          SA2    ORGBASE
          SA3    LPGM 
          IX0    X6-X2
          IX5    X3-X1
          BX2    X0+X5
          MI     X2,DLT      IF LITERALS NOT IN THIS SEGMENT
          SA4    ABSFG
          SA5    MACHINE
          ZR     X4,DLT0     IF RELOCATABLE 
          ZR     X5,DLT2     IF ABSOLUTE CPU ASSEMBLY 
 DLT0     SA2    ORGCTR 
          SA3    A2+B1
          SA4    MINORG 
          SA5    MAXORG 
          SA6    A2          SET ORGCTR = FWA OF LITERALS 
          SA7    A3          RELOCATION 
          SA6    A4          MINORG 
          BX7    X1          LWA+1 OF LITERALS
          SA7    A5          MAXORG 
          BX6    X2 
          LX7    X3 
          SA6    DLTB        SAVE ORGCTR
          SA7    A6+B1       RELOCATION 
          BX6    X4          MINORG 
          LX7    X5          MAXORG 
          SA6    A7+B1
          SA7    A6+B1
          RJ     RESORG      INITIALIZE FOR BINARY OUTPUT 
 DLT1     MX6    0
          SA6    POSCTR 
          SA1    DLTA 
          SA2    O.LITAB
          SA3    LI 
          IX2    X2+X3
          IX3    X1+X2
          SA1    X3 
          SA2    LWORD
          MX3    0
          BX4    X6 
          RJ     BINOUT 
          RJ     ZFOUP
          SA1    DLTA        ADVANCE INDEX
          SX6    X1+B1
          SA6    A1 
          SA1    ORGCTR 
          SA2    MAXORG 
          IX4    X1-X2
          MI     X4,DLT1     LOOP 
          MX6    0           INITIALIZE FOR GENERAL PROCESSING
          SA6    RERR 
          SA1    DLTB 
          SA2    A1+B1
          SA3    A2+B1
          SA4    A3+B1
          BX6    X1 
          LX7    X2 
          SA6    ORGCTR      RESTORE ORGCTR 
          SA7    A6+B1       RELOCATION 
          BX6    X3          MINORG 
          LX7    X4          MAXORG 
          SA6    MINORG 
          SA7    MAXORG 
          EQ     DLT         RETURN 
  
 DLT2     SA3    O.MEMORY    ABSOLUTE CPU ASSEMBLY
          SA2    O.LITAB
          SA4    LI 
          SA5    A4+B1
          IX3    X3+X0       MOVE LITERALS TO MEMORY IMAGE
          IX2    X2+X4
          IX1    X5-X4
          RJ     MOVE 
          JP     DLT         RETURN 
  
 DLTA     CON    0
 DLTB     BSS    4
 DSORT    SPACE  4
**        DSORT - MASKED SORT.
*         DSORT PERFORMS A SINGLE WORD INTERCHANGE SORT.
*         WORD COUNT MAY BE 0, BUT NOT NEGATIVE.
*         MASK DICTATES AMOUNT OF BITS TO LOOK AT FOR TESTING.
*         ENTRY  (X0) = SORT MASK.
*                (X1) = ORIGIN. 
*                (X2) = WORD COUNT. 
  
  
 DSORT    PS                 RETURN EXIT
          SB6    X2 
          LE     B6,B1,DSORT AVOID 0 OR 1 WORD SORTS
 DSORT1   SA2    X1 
          BX6    X2 
          SB7    B6-B1
          MX4    1
 DSORT2   PL     X4,*+1 
          SB2    A2 
          BX7    X0*X2
          SA2    A2+B1
          SB7    B7-B1
          BX3    X0*X2
          IX4    X3-X7
          PL     B7,DSORT2
          SA5    B2 
          BX7    X5 
          SB6    B6-B1
          SA6    B2 
          SA7    X1 
          SX1    X1+B1
          NE     B6,B1,DSORT1 
          EQ     DSORT
 DWORD    SPACE  4
**        DWORD - DUMP WORD.
*         THIS ROUTINE ACTS AS FOLLOWS: 
* 
*         RELOCATABLE ROUTINES... 
*                CREATES RELOCATION CONTROL IN BINREC, AND CALLS RESORG 
*                TO DUMP INFORMATION WHEN CARD IS FULL. 
* 
*         CP ABSOLUTE ROUTINES... 
*                STORES WORD IN "MEMORY". 
* 
*         PP ROUTINES.
*                STORES 12-BIT BYTES INTO MEMORY. 
*                STORES 16-BIT BYTES IF 180 PP ASSEMBLY.
* 
*         BC ROUTINES.
*                STORES TWO 8-BIT BYTES IN MEMORY.
* 
*         BINWORD/BINREL ALWAYS CLEARED OUT.
*         THIS ROUTINE MAKES ENTRIES INTO LNKTAB AND COMTAB.
  
  
 DWORDX   MX6    0
          BX7    X7-X7
          SA6    BINWORD
          SA7    BINREL 
          SA6    A7+B1
          SA7    A6+B1
  
 DWORD    PS                 RETURN EXIT
          SA3    B
          SA1    MACHINE
          SA2    ABSFG
          ZR     X3,DWORDX   IF NO BINARY FILE
          NZ     X1,DWORDP   IF PP CODING 
          NZ     X2,DWORDC   IF CP ABSOLUTE 
          SA1    BINREC      CHECK FOR A PARTIAL CARD 
          AX1    36 
 +        NZ     X1,*+1 
          RJ     RESORG      PRESET EMPTY CARD
 DBW1     SA1    BINREL      PROCESS RELOCATION 
          SX6    X1-1 
          MI     X6,DBW20    IF NO MORE 
          SA6    A1 
          LX6    -1 
          SA1    BINREL+1+X6 FETCH BINREL WORD
          MX0    -6 
          MI     X6,DBW2     IF LOWER HALFWORD
          LX1    30 
 DBW2     BX6    -X0*X1      TEST FIELD WIDTH 
          LX1    -6 
          SB7    X6-18
          NZ     B7,DBW10    IF NOT 18 BITS 
          SA2    =-10000100001B 
          BX6    -X0*X1 
          LX1    -24
          SB2    X6          TEST FOR STANDARD POSITIONS
          AX3    X2,B2
          CX6    X3          IF BIT POSITION IS 0, 15, OR 30
          LX3    -1          (B2) = 0, 1, OR 2 RESPECTIVELY 
          SB2    X6-57
          MI     X3,DBW10    IF NONE OF THE ABOVE 
          AX1    42 
          MI     X1,DBW5     IF EXTERNAL
          SB5    X1-3 
          PL     B5,DBW5     IF COMMON
          SA4    BINREC      PROGRAM RELOCATION (+ OR -)
          AX4    34 
          SB3    X4 
          SB4    56+B2
          SX1    X1+B1
          SB3    B4-B3
          SA4    A4+B1
          LX1    X1,B3
          BX6    X4+X1
          SA6    A4 
          EQ     DBW1 
 DBW5     SA2    ORGCTR 
          MX0    -17
          BX6    X0*X2
          NZ     X6,DBW10    IF ORGCTR NOT LESS THAN 2**17
          BX6    -X0*X1 
          SX4    X1                                                     S005  18
          SA5    ORGCTR+1                                               S005  19
          LX6    30                                                     S005  20
          SA1    A5-B1                                                  S005  21
          SA3    CLF
          SB7    X5                                                     S005  23
          LE     B7,B1,DBW7  CONVERT RELOCATION IF COMMON               S005  24
          SX5    X5+B1
 DBW7     LX5    18                                                     S005  26
          BX6    X6+X5                                                  S005  28
          SX0    B2+4                                                   S005  29
          IX7    X6+X1                                                  S005  30
          LX0    27 
          BX6    X7+X0                                                  S005  32
          LX5    39-18
          NZ     X3,DBW12    IF CONDITIONAL                             S005  35
          MX5    0                                                      S005  36
          EQ     DBW12                                                  S005  37
  
 DBW10    SA1    BINREL      EXTENDED TABLE ENTRY NEEDED
          SA2    ORGCTR 
          SA3    A2+B1
          LX1    -1 
          SA4    BINREL+1+X1 FETCH BINREL WORD
          SB7    X3 
          PL     X1,DBW11    IF UPPER HALFWORD
          LX4    30 
 DBW11    MX0    -12
          AX4    30 
          SA1    CLF         CONDITIONAL LOADING FLAG 
          BX6    -X0*X4 
          AX4    12 
          MX0    -17
          LX2    12 
 +        BX6    X6+X2
          LE     B7,B1,*+1   CONVERT RELOCATION IF COMMON 
          SX3    X3+B1
 +        LX3    39 
          BX6    X6+X3
          BX5    -X0*X4 
          LX5    48 
          SX3    B0 
          ZR     X1,DBW12    IF NOT CONDITIONAL 
          AX5    45 
          SX1    B1 
          LX6    9
          BX5    X5+X1
          LX5    -3 
 DBW12    BX1    X6+X5       TABLE ENTRY
          LX6    X1 
          MI     X4,DBW16    IF EXTERNAL
          SA2    L.COMTAB    PROCESS COMMON RELOCATION
          EQ     DBW18
 DBW16    SA2    L.LNKTAB    PROCESS EXTERNAL LINKAGE 
          SA3    L.EXTAB
 DBW18    SA0    A2-SIZES 
          NZ     X2,DBW19    IF COMTAB/LNKTAB NON-EMPTY 
          SA6    BTEMPA 
          MANAGE A0,X3+B1    MAKE INITIAL ALLOCATION
          SA1    BTEMPA 
 DBW19    ADDWORD A0         ADD TABLE ENTRY
          SA3    A0+SIZES    CHECK TABLE LENGTH                         S005  39
          SX5    X3-1                                                   S005  41
          NZ     X5,DBW1     IF TABLE NOT DUMPED, LOOP TO NEXT RELOC    S005  42
          SX4    A0-LNKTAB
          MX7    0                                                      S005  43
          SX3    B0 
          BX4    -X4
          SA7    A3          CLEAR TABLE SIZE                           S005  44
          EQ     DBW12       AND TRY AGAIN                              S005  45
  
 DBW20    SA1    BINREC      COUNTER
          SA2    BINWORD     DATA 
          LX1    -36
          BX7    X2 
          SA7    BINREC+2+X1 STORE DATA 
          SX2    B1 
          IX6    X1+X2       INCREMENT WORD COUNT 
          LX6    36 
          SA6    A1 
          SB7    X1-14       TEST FOR END OF TABLE
          MI     B7,DWORDX
          RJ     RESORG      DUMP CARD
          EQ     DWORDX 
  
*         OUTPUT CP ABSOLUTE WORD.
  
 DWORDC   SA1    ORGCTR 
          SA2    ORGBASE
          SA3    LPGM 
          IX4    X1-X2
          NG     X4,DWORDX   IGNORE WORD IF OUT OF RANGE
          IX1    X1-X3
          PL     X1,DWORDX
          SA1    O.MEMORY 
          IX0    X1+X4
          SA2    BINWORD
          BX6    X2 
          SA6    X0 
          EQ     DWORDX 
  
*         OUTPUT PP WORD. 
  
 DWORDP   SA2    BINWORD
          SA3    ORGCTR 
          SA1    ORGBASE
          SA5    LPGM 
          IX1    X3-X1
          NG     X1,DWORDX
          IX5    X3-X5
          SA4    PPTYPE 
          PL     X5,DWORDX
 +        SX4    X4+B1
          NZ     X4,*+1      IF NOT BCU 
          LX1    1
 +        SX7    X4+2 
          ZR     X7,DWORDQ   IF 180 PP ASSEMBLY 
          SX0    5
          SB4    X1 
          IX1    X1/X0       WORD INDEX 
          SB6    X1 
          SB5    B6+B6
          SB7    B5+B5
          SB5    B7+B6       5*LOCATION 
          SX7    B4-B5       REMAINDER
          IX6    X7+X7       2*REMAINDER
          IX7    X6+X7       3*REMAINDER
          LX7    2           12*REMAINDER 
          SB7    X7 
          SB5    48 
          SB7    B5-B7
          SX0    7777B
          LX0    X0,B7
          LX2    X2,B7
          SA1    O.MEMORY 
          SA5    X1+B6
          BX6    -X0*X5 
          ZR     X4,DWORDP1  IF BCU ASSEMBLY
          BX2    X0*X2
          BX6    X6+X2
          SA6    A5 
          EQ     DWORDX      RETURN 
 DWORDP1  LX2    -8 
          BX7    X0*X2
          BX6    X6+X7
          SA6    A5 
          LX0    -12
          BX7    X0*X2
 +        PL     X0,*+1      IF NOT ACROSS WORD 
          SA5    A5+B1
          BX6    X5 
 +        LX7    -4 
          BX6    -X0*X6 
          BX6    X6+X7
          SA6    A5 
          EQ     DWORDX      RETURN 
  
*         180 PP ASSEMBLY.  16-BIT PP BYTES ARE PACKED INTO THE BINARY
*         IMAGE LEAVING NO UNUSED BITS.  THE RELATIVE OFFSET INTO THE 
*         PROGRAM IMAGE (*POS*), AND THE SHIFT (*REM*) IS DETERMINED AS 
*         FOLLOWS...
* 
*           POS = (K*16) / 60 
* 
*                WHERE   K = RELATIVE PP BYTE (ORGCTR - ORGBASE)
*                      POS = RELATIVE OFFSET INTO PROGRAM IMAGE 
* 
*           REM = 44 - ( (K*16) - (POS*60) )
* 
*                REM IS USED AS FOLLOWS...
* 
*                      1) FOR PP BYTE FITTING ENTIRELY IN ONE CM WORD...
*                         *REM* IS THE RIGHT-MOST BIT NUMBER OF THE 
*                         BYTE TO BE STORED AT (POS). 
*                         (RIGHT-MOST BIT OF CM WORD = BIT 0) 
* 
*                      2) FOR PP BYTE CROSSING WORD BOUNDARY... 
*                         *REM* IS NEGATIVE.  THE UPPER PART OF THE BYTE
*                         CONSISTS OF (REM+16) BITS AND IS STORED 
*                         RIGHT-JUSTIFIED AT (POS).  THE LOWER PART OF
*                         THE BYTE CONSISTS OF (-REM) BITS AND IS 
*                         STORED LEFT-JUSTIFIED AT (POS+1). 
  
 DWORDQ   LX1    4           K * 16 
          SB3    X1 
          SX0    60 
          IX1    X1/X0       POS = (K*16) / 60
          SB6    X1          (B6) = POS 
          BX3    X1 
          LX3    2           POS * 4
          LX1    6           POS * 64 
          IX1    X1-X3       POS * 60 
          SB4    X1 
          SB5    44 
          SB4    B3-B4       K*16 - POS*60
          SB5    B5-B4       REM = 44 - ( (K*16) - (POS*60) ) 
          SA1    O.MEMORY 
          SA5    X1+B6       RELATIVE WORD AT *POS* 
          MI     B5,DBW30    IF BYTE CROSSES 60-BIT WORD BOUNDARY 
          MX0    -16
          LX2    X2,B5       SHIFT BYTE TO POSITION 
          LX0    X0,B5       SHIFT MASK TO POSITION 
          BX2    -X0*X2      STORE BYTE IN PROGRAM IMAGE
          BX6    X0*X5
          BX6    X6+X2
          SA6    A5 
          EQ     DWORDX      RETURN 
  
 DBW30    SB4    B5+16       REM + 16  (4, 8, OR 12)
          MX0    16          FORM MASKS FOR BOTH UPPER BITS IN (POS)
          LX0    X0,B4        AND LOWER BITS IN (POS+1) 
          MX1    30 
          BX7    X1*X0       MASK FOR LOWER PART IN (POS+1) 
          BX0    -X1*X0      MASK FOR UPPER PART IN (POS) 
          LX2    44          POSITION BYTE
          LX2    X2,B4
          BX3    X7*X2       LOWER PART OF BYTE FOR (POS+1) 
          BX2    X0*X2       UPPER PART OF BYTE FOR (POS) 
          BX6    -X0*X5      MERGE UPPER BITS IN (POS)
          BX6    X6+X2
          SA6    A5 
          SA5    A5+B1       MERGE LOWER BITS IN (POS+1)
          BX6    -X7*X5 
          BX6    X6+X3
          SA6    A5 
          EQ     DWORDX      RETURN 
 RESORG   SPACE  4
**        RESORG - RESET ORIGIN.
*         RESETS ORIGIN FOR RELOCATABLE ROUTINES.  MAY DUMP TEXT
*         TABLE IF BINREC IS NON-EMPTY. 
  
  
 RESORG   PS                 RETURN EXIT
          SA1    ABSFG
          SA2    BINREC 
          SA3    B
          NZ     X1,RESORG   AVOID ANY PROCESSING ON ABSOLUTE PROGRAMS
          ZR     X3,RESORG   IF NO BINARY FILE
          LX2    -36
          SB7    X2+B1
          EQ     B7,B1,RESORG1 IF BINARY RECORD EMPTY 
          SA3    DBTA        APPEND CONTROL WORD
          SA4    CLF
          LX2    36 
          IX6    X2+X3
          LX4    33-59
          BX6    X6+X4       OR IN CONDITIONAL LOAD FLAG
          SA6    A2 
  
 RM       IFEQ   CP#RM,0
          WRITEW B,A2,B7+B1 
 RM       ELSE
          SX4    B7+B1
          IX2    X4+X4
          LX4    3
          SA1    B-1
          IX4    X4+X2
          NZ     X1,RES1     IF NOT *W* RECORDS 
          PUT    B,BINREC,X4
          EQ     RESORG1
 RES1     PUTP   B,BINREC,X4
 RM       ENDIF 
  
 RESORG1  SA1    ORGCTR      RESET FOR NEW CARD 
          SA2    A1+B1
          MX0    -17
 +        SB7    X2 
          LE     B7,B1,*+1   ADJUST RELOCATION FOR COMMON 
          SX2    X2+B1
          BX4    X0*X1
          SA3    DBTB        SET TABLE HEADER WORD
          LX2    18 
          ZR     X4,DBT2     IF ORIGIN LESS THAN 2**17
          LX2    6
          SA3    A3+B1
 DBT2     SX6    B0 
          BX7    X2+X1
          SA6    BINREC+1 
          SA7    A6-B1
          BX6    X3 
          SA6    DBTA 
          EQ     RESORG 
  
 DBTA     DATA   0           TEXT/XTEXT CONTROL WORD
 DBTB     DATA   40000001BS36      TEXT 
          DATA   37000001BS36      XTEXT
 ENDA     SPACE  4,8
**        END OF SECONDARY OVERLAY. 
  
  
          QUAL
 ENDA     BSS    0
 ENDB     BSS    0
 BUFFERS  TITLE  BUFFERS - INPUT/OUTPUT BUFFERS.
****      BUFFERS - INPUT/OUTPUT BUFFERS.                                CPSA097
  
  
          USE    BUFFERS
          SEG    BUFFERS. 
 STYPE    BSS    1           STATEMENT TYPE 
 CARD     BSS    71*NCARDS+30 EXPANDED CARD AREA AND SLOP ROOM
 SEQ      BSS    2*NCARDS    SEQUENCE FIELDS (73-90)
 ENDSEQ   BSS    2*NCARDS    END CARD SEQUENCE FIELDS 
 VALUES   BSS    NLITS       FOR DATA EVALUATION
 RELVEC   BSS    256         RELOCATION VECTOR
 SQIMAGE  BSS    71*NCARDS/10+3 
 BUFFERS  BSS    0           START OF FILE BUFFERS
          IFEQ   OVERLAY,0,1
 GBUF     BSS    0           SYSTEXT LOADING BUFFER 
 EBUF     BSS    EBUFL       ERROR OUTPUT BUFFER
 RBUF     BSS    RBUFL       CROSS-REFERENCE TABLE BUFFER 
 SBUF     BSS    SBUFL       SCRATCH BUFFER 
 DBUF     BSS    DBUFL       SNAPPER BUFFER 
 BBUF     BSS    BBUFL       BINARY BUFFER
 BUCKET   BSS    0           END OF COMPASS 
 MIN.FL   EQU    BUFFERS+SBUFL+DBUFL+BBUFL+NOPCT*2+NSYMT*2+10 
  
****                                                                     CPSA097
  
          ORG    ENDB 
          SPACE  4
**        MINIMUM FIELD LENGTH FOR COMPASS. 
  
 MFL=     EQU    MIN.FL 
  
          END    COMPASS
*CWEOR 14 
