         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 1.4 WORK AREAS'
         OPEN     NAME
*
         REF      CLUSNUM
         REF             DIAG,COMAFLG,SEMIFLG
         REF      PDBT
         REF      SADNOSN,SADNO,SADYES,SADIAG,INTGR
         REF      SCAN,CONTROL,NOSCAN,COLAFLG,HASHNUM,BYTESNWD
         REF      STRING,POINTLOC
         REF      INTAGER,BYTESNLT,WREPF
         REF      PDBCC
         REF      A,ACCT,CCT,COMMA,DCCT,ENDSOUR,INTEGER
         REF      NAME,NONNLIT,NUMBER,SBW,SNC,SNW,SEMICOL
         REF      SYNTABLE,JUMPTBL,SADGO
         REF      PDBK
         REF      CARDOUT
         REF      PDBP
         REF      CARDNO
         REF      WRSPD
         REF      NOYES
         REF      TBLSN
         REF      SKIP
         REF      EXNAME
         REF      HASH
         REF      PRI               PRIORITY SEGMENTATION TABLE
         REF      MNTBL
         REF      UNARYFLG
         REF      FPERD,LIBCPY,REPLC,RNPTR
         REF      SFRPC,SLIBN,WORDR,YDISP
         REF      HLNK14,AHLNK
         REF      PDBDBG            DEBUG SWITCH
         DEF      COB14
         DEF      OUTPTR            ALLOW FOR USE OF MODIFY AND SNAP
*
*
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU       8                                                    COBOL14
R11      EQU      11
*
*
*        PROC TO GENERATE ZERO WORDS
*
GENZ     CNAME
         PROC
         DO       AF
         GEN,32   0
         FIN
         PEND
OUTPTR   GEN,8,8,16      206,X'73',0    PROGRAM TRAILER OUTPUT AREA
LNKTBL   RES      0            BEGINNING OF LINK TABLE
         GENZ     102
FSW      GEN,32   0                 FIRST TIME I/O SWITCH
REPLA    GEN,32   0           INCLUDE REPLACING SWITCH
INCMOV2  GEN,8,24 31,BA(RESTOR)    MBS CTL WORD
INCMOV   GEN,8,24 31,BA(STRING) MBS CONTROL WORD
RESTOR   RES      8             REPLACING NAME STORAGE
RLENG    GEN,32   0             CONTAINS LENGTH OF RESTOR ITEM
PLAST    GEN,32   0        PARAGRAPH LAST ITEM SWITCH
LEVEL    GEN,32   0                LEVEL COUNTER - USED BY CONDITIONAL
*                                  ROUTINES
         BOUND    8
UNRYSPD  DATA     UNRYSPD+2         UNARYFLG STACK POINTER DOUBLEWORD
         GEN,16,16 21,0
         DATA     0                 UNARY FLG STACK
         RES      20
NOTHERE  GEN,32   0                NOT HERE STACK
NOTVAL   GEN,32   0                NOT VALUE INDICATOR
NEXSENT  GEN,32   0                CONTAINS THE LABEL OF NEXT SENTENCE
*                                  OR ZERO
SRLBL    GEN,32   0                CONTAINS A SPECIAL LABEL USED ONLY
*                                  BY THE SEARCH ROUTINE
PRCED    RES,4    8                CONTAINS THE NAME OF THE PRESENT
*                                  PROCEDURE
PRCEDL   GEN,32   0                CONTAINS THE LENGTH IN BYTES OF THE
*                                  ITEM IN PRCED
PREFNO   GEN,32   0               REFERENCE NO. OF NAME IN PRCED
PRESHS   GEN,32   0               HASH NUMBER OF NAME IN PRCED
PREPR    GEN,32   0          PRIORITY NO. OF NAME IN PRCED
PRSEC    RES,4    8                PRESENT SECTION NAME
PRSECL   GEN,32   0                LENGTH OF PRSEC IN BYTES
PRSECNO  GEN,32   0               REFERENCE NO. OF NAME IN PRSEC
PRSECHS  GEN,32   0               HASH NUMBER OF NAME IN PRSEC
PRSPR    GEN,32   0          PRIORITY NO. OF NAME IN PRSEC
DED      GEN,32   0                THE DIAGNOSTIC SWITCH
PARAF    GEN,32   0                FIRST PARAGRAPH SWITCH
*
* FLAGS FOR SETF AND RSTF - MUST BE IN ORDER
*
RELNOTS  DATA     0                 *1 NOT RELATIONAL OPERATOR
NOTNR    DATA     0                 *2 MISSING LOGICAL CONNECTOR
ALFLG    DATA     0                 *3 ALL STRING
NOANDOR  DATA     0                 *4 POSSIBLY MISSING LOGICAL OPERATOR
XTFG     DATA     0                 *5 32K
OPFG     DATA     0                 *6 32K
SRFG     DATA     0                 *7 32K
PNFLAG   DATA     0                 *8
SIFG     DATA     0                 *9 32K
GIVCNT   DATA     0                 *10 DIVIDE GIVING COUNT
INSPF    DATA     0                 *11 INSPECT FLAG
UDBGF    DATA     0                 *12 USE DEBUGGING FLAG
DBSCT    DATA     0
DBTRC    DATA     31                DEBUG-NAME BYTE LENGTH
DBTRH    DATA     X'126C9C1E'       DEBUG NAME CLUSTER
DBTRN    TEXT     '        '
         TEXT     '        '
         TEXT     '        '
         TEXT     '        '
DBTBB    DATA     BA(DBTRN)-1
DBTCB    GEN,8,24 30,BA(DBTRN)
STRNGST  RES,4    33               EXHIBIT ID ASSEMBLY AREA
STRNGCNT GEN,32   131              INDICATES THE AMOUNT OF ROOM LEFT
*                                  IN STRNGST
TRULAB   GEN,32   0                TRUE LABEL STACK
         RES,4    29
FLSLAB   GEN,32   0                FALSE LABEL STACK
         RES,4    29
CONTYPE  RES,1    32               CONDITION TYPE STACK
CONTYPNT GEN,32   0                CONTYPE STACK POINTER
COA      DATA     1                 CLUSTER OUTPUT AREA
         RES      64
MOCOA    GEN,32   0                MISSING OPERATOR OUTPUT AREA
TRUPNT   GEN,32   TRULAB           TRULAB STACKPOINTER
FLSPNT   GEN,32   FLSLAB           FLSLAB STACKPOINTER
STRNGPNT GEN,32   BA(STRING)        STRNGST MBS CONTROL WORDS
         GEN,32   BA(STRNGST)
PRESILB  GEN,32   0                 PRESENT INTERNAL LABEL
PROLBL   GEN,32   X'5B000000'       CONTAINS LABEL OF LAST DUMMY
*                                 PROCEDURE. NOTE THAT ALL DUMMY
*                                 PROCEDURE NAMES BEGIN WITH %
MVWD     GEN,8,24 48,BA(PRSEC)    MBS CONTROL WORD FOR OUTSEC
COASTR   GEN,32   0               WORK AREA USED BY OQUES ETC
AUXADDR  GEN,32   0               USED FOR RETURN ADDRESS STORAGE BY
*                                SEVERAL ROUTINES
MCLADR   GEN,32   0               WORK AREA USED BY MCLRET
FOURSTOR GEN,32   0               R4 AUX STORAGE
THRSTOR  GEN,32   0           R3   STORE
FIVSTOR  GEN,32   0               R5 AUX STORAGE
PRAUX    RES      12         TEMP STORAGE FOR PRCED, ETC
PRAUXO   GEN,32   BA(PRCED)        PRCED TO PRAUX MBS DOUBLEWORD
         GEN,8,24 48,BA(PRAUX)
PRAUXI   GEN,32   BA(PRAUX)        PRAUX TO PRCED MBS DOUBLEWORD
         GEN,8,24 48,BA(PRCED)
PRAUXS   GEN,32   0           PRAUX SWITCH - NON-ZERO IF PRAUX CONTAINS
*                       A STORED PARAGRAPH NAME
SPDSW    GEN,32   0          SPD OUTPUT SWITCH
SPDAR    RES      11         SPD OUTPUT AREA
SPLASH   RES      0                 'GO TO C:ERR' STATEMENT
         DATA     X'06DBA000'
         TEXTC    'C:ERR'
SEGFLG   DATA     0                 FLAG TO SHOW IF PRIORITY NUM THR    COBOL14
         TITLE    'PHASE 1.4 INITIALIZATION'
COB14    LI,R2    TBLSN
         STW,R2   SYNTABLE
         LI,R2    TBLJMP
         STW,R2   JUMPTBL
         LI,R2    HLNK14
         STW,R2   AHLNK
         LI,R4    0
         B        SADGO
         TITLE    'PHASE 1.4 TABLE ROUTINES'
************************************************************************
*    CAND         PROCESS LOGICAL AND
*
CAND     LI,R7    FLSPNT               X
         LW,R2    NOTVAL               X  CHOOSE
         BEZ      CANDLP1              X  STACKPOINTER
         LI,R7    TRUPNT               X
CANDLP1  BAL,11   LBLLEV           X
         STH,R2   COA+1            X
         LI,R2    X'E200'          X
         AWM,R2   COA              X OUTPUT A JT OR JF DEPENDING ON
         LI,R2    1                X  NOTHERE
         AND,R2   NOTHERE          X
         BEZ      CANDLP2          X
         EOR,R2   NOTHERE          X
         STW,R2   NOTHERE          X
         LI,R2    X'300'           X
         EOR,R2   COA              X
         STW,R2   COA              X
CANDLP2  BAL,11   CINTL            X
         LI,R7    FLSPNT               X
         LW,R2    NOTVAL               X CHOOSE ALTERNATE
         BNEZ     CANDLP3              X STACKPOINTER
         LI,R7    TRUPNT               X
CANDLP3  LI,R2    1                X  BUMP LEVEL TO CAUSE INCREASE
         AWM,R2   LEVEL            X  IN BINDING STRENGTH
         BAL,11   LDEFAUX
         LI,R2    -1               X  RESTORE LEVEL BEFORE EXIT
         AWM,R2   LEVEL            X
         LI,R3    X'8'              BIT 4 OF CONTYPE
         B        ORC
************************************************************************
*    CBYTE        SET CONTROL BYTE
*
CBYTE    SLS,R3    16
         STW,R3    COA
         LH,R3    R3
         CI,R3    X'D2'
         BE       CBYT1             ALTER
         CI,R3    X'DB'
         BNE      SADNO             NOT GO TO
CBYT1    LW,R3    SGINIF
         B        COPT
************************************************************************
*    COLA         (TEST FOR) COLUMN A
*
COLA     BAL,11   SCAN
         LW,R2    COLAFLG
         BEZ      SADNOSN           IF NOT IN COLUMN A
         B        NOYES
************************************************************************
*    CONCN        TEST CONTYPE FOR (NOT) NAME OR CONDITION
*
CONCN    LW,R2    CONTYPNT
         LB,R3    CONTYPE,R2        GET TOP OF STACK
         AND,R3   L(X'FC')       IGNORE 'NOT' PRECEDING OPERATOR
         EOR,R3   L(O'200')
         BEZ      POPCY
*
*        FALL INTO CONCON
*
************************************************************************
*    CONCON       (TEST) CONTYPE FOR CONDITION
*
CONCON   LW,R2    CONTYPNT
         LB,R3    CONTYPE,R2        GET CURRENT TOP OF CONTYPE
         AND,R3   L(X'00000008')    ISOLATE BIT 4 OF CONTYPE BYTE
         BNEZ     POPCY             BRANCH IF YES
         B        SADNO
************************************************************************
*    CONFORM      (TEST) CONTYPE FOR FORMULA
*
CONFORM  LW,R2    CONTYPNT          GET STACKPOINTER TO CURRENT TOP
         LB,R3    CONTYPE,R2        GET CURRENT TOP OF CONTYPE
         AND,R3   L(X'00000029')    ISOLATE BITS 2,4,7 OF CONTYPE BYTE
         B        COMCON
************************************************************************
*    CONID        (TEST) CONTYPE FOR IDENTIFIER
*
CONID    LW,R2    CONTYPNT
         LB,R3    CONTYPE,R2
         AND,R3   L(X'FC')      IGNORE 'NOT' PRECEDING OPERATOR
         EOR,R3   L(X'00000080')    FLIP BIT 0 OF CONTYPE BYTE
         B        COMCON
************************************************************************
*    CONLIT       (TEST) CONTYPE FOR LITERAL
*
CONLIT   LW,R2    CONTYPNT          GET STACKPOINT TO CURRENT TOP
         LB,R3    CONTYPE,R2
         AND,R3   L(X'FC')      IGNORE 'NOT' PRECEDING OPERATOR
         EOR,R3   L(X'00000040')    FLIP BIT 1 OF CONTYPE BYTE
         BEZ      POPCY             BRANCH IF BIT 1 ONLY IS ON
         EOR,R3   L(X'00000060')    FLIP BITS 1,2 OF CONTYPE BYTE
COMCON   BEZ      POPCY             BIT 2 ONLY IS ON
         B        POPC
************************************************************************
*    COPT         COPY STATEMENT OPTIONS
*
COPT     OR,R3    COA        X
         STW,R3   COA        X STORE STATEMENT OPTIONS BYTE
         B        SADNO
************************************************************************
*    COR          PROCESS LOGICAL OR
*
COR      LI,R7    FLSPNT           X
         LW,R2    NOTVAL           X  CHOOSE
         BNEZ     CORLP1           X  STACKPOINTER
         LI,R7    TRUPNT           X
CORLP1   BAL,11   LBLLEV         X
         STH,R2   COA+1          X
         LI,R2    X'E100'        X
         AWM,R2   COA            X
         LI,R2    1              X
         AND,R2   NOTHERE        X  OUTPUT JT OR JF TO INTERNAL
         BEZ      CORLP2         X  LABEL DEPENDING ON NOTHERE
         EOR,R2   NOTHERE        X
         STW,R2   NOTHERE        X
         LI,R2    X'300'         X
         EOR,R2   COA            X
         STW,R2   COA            X
CORLP2   BAL,11   CINTL          X
         LI,R7    FLSPNT            X
         LW,R2    NOTVAL            X CHOOSE ALTERNATE STACKPOINTER
         BEZ      CORLP3            X
         LI,R7    TRUPNT            X
CORLP3   BAL,11   LDEFAUX
         LI,R3    X'A'              BITS 4 THRU 6 OF CONTYPE
         B        ORC
************************************************************************
*    DMPST        DUMP STRNGST
*
DMPST    LI,R2    X'B008'
         AWM,R2   COA
         LCW,R3   STRNGCNT           X
         AI,R3    -1
         LI,R2    C'='
         STB,R2   STRNGST+33,R3
         AI,R3    133
         STB,R3   COA+1              X AND STORE IT
         SLS,R3   24               X SET UP STRING MOVE
         OR,R3    L(BA(COA)+5)     X
         LI,R5    131                 X
         STW,R5   STRNGCNT            X RESET STRNGCNT
         BAL,11   OQUES
         LI,R2    BA(STRNGST)
         STW,R2   STRNGPNT+1        RESET STRNGPNT+1
         B        OUTSTX
RSTCNT   LI,R3    131               RESET STRNGCNT
         STW,R3   STRNGCNT
         LI,R2    BA(STRNGST)
         STW,R2   STRNGPNT+1        RESET STRNGPNT+1
         B        SADNO
************************************************************************
*    DX           DISASTER MESSAGE ROUTINE
*
DX       LW,R2    DED
         BNEZ     SADNO      IF DED IS ON, EXIT
         LW,R2    L(X'00FF0000')   X
         AND,R2   COA              X   OUTPUT AN ERROR CLUSTER
         OR,R2    L(X'02007102')   X
         STW,R2   COA              X
         BAL,11   MCLRET           X
         STW,R4   DED           SET DED
         B        SADIAG
************************************************************************
*    ENABLE       RESET DIAGNOSTIC SWITCH
*
ENABLE   LI,R2    0
         STW,R2   DED
         LW,R2    L(X'00FF0000')    X
         AND,R2   COA               X CLEAN BEGINNING OF COA
         STW,R2   COA               X
         B        SADNO
************************************************************************
*    ENDCON       END CONDITION
*
ENDCON   LI,11    SADNO                  SET RETURN TO SADNO
ENDCONE  STW,11   COASTR
         LI,R7    FLSPNT
         BAL,11   LBLLEV
         STH,R2   COA+1            X
         LI,R2    X'E100'          X
         LI,R3    1                X
         AND,R3   NOTHERE          X OUTPUT JT OR JF DEPENDING ON
         B        DITCH,R3         X  NOTHERE
DITCH    LI,R2    X'E200'          X
         AWM,R2   COA              X
ENDCONT  BAL,11   CINTL            X
         LI,R7    TRUPNT              X
         BAL,11   LDEFAUX             X FLUSH TRULAB
         LI,R2    0
         STW,R2   NOTHERE
         B        *COASTR
************************************************************************
*    ENDCONR      END CONDITION - REVERSED SENSE
*
ENDCONR  LW,R2    TRUPNT           X
         XW,R2    FLSPNT           X  EXCHANGE STACKPOINTERS
         STW,R2   TRUPNT           X
         LI,R2    1                    X
         EOR,R2   NOTHERE              X INVERT NOTHERE VALUE
         STW,R2   NOTHERE              X
         BAL,11   ENDCONE
ENDCONRA LW,R2    TRUPNT           X
         XW,R2    FLSPNT           X  RESTORE STACKPOINTERS
         STW,R2   TRUPNT           X
         B        SADNO
************************************************************************
*    ENUFF        END OF SOURCE PROGRAM ROUTINE
*
ENUFF    BAL,11   RNGCLU           OUTPUT RANGE CLUSTER
         MTW,2    CLUSNUM
         BAL,11   SECTRLR          OUTPUT SECTION TRAILER
         STW,R4   FOURSTOR               X
         LI,R4    BA(SPLASH)        OUTPUT
         BAL,11   WREPF              'GO TO C:ERR' STATEMENT
         MTW,-1   CLUSNUM           BUMP CLUSNUM
         LW,R2    CLUSNUM    X SAVE SIZE FOR PHASE 3 I/O
         STW,R2   LNKTBL+100 X
         BAL,10   CARDOUT     OUTPUT AN EXTRA CARD NO CLUSTER
         LI,R2    0                X
         LI,R3    99               X
         LI,R5    0                X
CLPP     CW,R2    LNKTBL,R3        X COUNT NUMBER OF
         BE       CLPPA            X PRIORITY SEGMENTS
         AI,R5    1                X AND SAVE IN PDBT
CLPPA    BDR,R3   CLPP             X
         OR,R5    PDBT             X
         STW,R5   PDBT             X
         LI,R4    X'0020'
         AND,R4   PDBCC
         BEZ      %+3
         LI,R4    BA(OUTPTR)
         BAL,11   WREPF
R15 EQU 15
         REF      F:W4,ABNERR
         LI,R15   X'20'
         CH,R15   F:W4              IF F:W4 OPEN
         BAZ      NOTOPN%           NO..GO ON
         CAL1,1   CLOSRWF           YES...CLOSE RWF
         CAL1,1   OPNRWF%           ...RE-OPEN WITH CONTROLED ABN EXIT
         CAL1,1   CLOSRWF           ...CLOSE IT BACK
         B        NOTOPN%
CLOSRWF  GEN,8,24 X'15',F:W4
         DATA     0
OPNRWF%  GEN,8,24 X'14',F:W4
         GEN,8,24 X'C7',0
         DATA     ABNERR,0,1,1,8
NOTOPN%  RES      0
         LW,R4    FOURSTOR
         B        SADNO
************************************************************************
*    EX           INTERMEDIATE LEVEL DIAGNOSTIC ROUTINE
*
EX       LW,R2    DED
         BNEZ     SADNO           EXIT IF DED IS ON
         STW,R4   DED             SET DED
         B        SADIAG
************************************************************************
*    GENPARA      GENERATE DUMMY PARAGRAPH NAME
*
GENPARA  BAL,11   GENSP
         B        OUTPARA
************************************************************************
*    GENSECT      GENERATE DUMMY SECTION NAME
*
GENSECT  LW,R2    PRAUXO           X
         LW,R3    PRAUXO+1         X SAVE POSSIBLE VALID
         MBS,R2   0                X PARAGRAPH NAME
         STW,R4   PRAUXS           X
         BAL,11   GENSP
         B        OUTSECT
************************************************************************
*    IMPKEYW      (TEST FOR) IMPERATIVE KEYWORD
*
IMPKEYW  BAL,11   SCAN              GET NEXT WORD
         LW,R2    CONTROL           GET WORD TYPE
         AND,R2   L(X'00000380')
         EOR,R2   L(X'00000380')
IMPAUX   BNEZ     SADNOSN
         B        NOYES
************************************************************************
*    INTA         OUTPUT INTEGER CLUSTER
*
INTA     BAL,11   OQUES
         SLS,R3   8
         AWM,R3   COA               STORE OPERAND OPTION BYTE
         LW,R2    INTGR
         STW,R2   COA+1             STORE INTEGER
         LI,R2    5
INTA1    STB,R2   COA               STORE CLUSTER SIZE
         B        MCLOP
************************************************************************
*    LEVBAD       CORRECT LEVEL, BAD
*
LEVBAD   LW,R2    LEVEL            X
         AI,R2    -1               X RESTORE LEVEL NO. TO FORMER VALUE
         STW,R2   LEVEL            X
         LI,R3    0
         STW,R3   NOTVAL
         STW,R3   NOTHERE
         LW,R5    TRUPNT                X
         BAL,11   LEVBAUX               X CLEAN TRULAB TO (LEVEL)
         STW,R5   TRUPNT                X
         LW,R5    FLSPNT              X
         BAL,11   LEVBAUX             X  CLEAN FLSLAB TO (LEVEL)
         STW,R5   FLSPNT              X
         B        SADNO
LEVBAUX  CB,R3    *R5              X
         BE       *R11             X  CLEAN STACK POINTED TO BY R5
         CB,R2    *R5              X  TO LIMIT SPECIFIED BY R2
         BGE      *R11             X  AND RETURN
         AI,R5    -1               X
         B        LEVBAUX          X
************************************************************************
*    LEVDEC       DECREASE LEVEL
*
LEVDEC   LI,R7    FLSPNT            X
         BAL,11   LDEFAUX           X FLUSH FLSLAB
         LI,R2    -1             X
         AWM,R2   LEVEL          X DECREASE LEVEL TO VALUE AT ENTRY
         B        SADNO
************************************************************************
*    LEVDECR      LEVEL DECREASE, REVERSED
*
LEVDECR  LI,R7    TRUPNT          SET UP TO FLUSH TRULAB
         B        LEVDEC+1
************************************************************************
*    LEVINC       INCREASE LEVEL
*
LEVINC   MTW,1    LEVEL
         B        PUSHC
************************************************************************
*    LEVLEV       RESTORE LEVEL
*
LEVLEV   MTW,-1   CONTYPNT
         B        LEVBAD
************************************************************************
*    LEVZERO      RESTORE LEVEL TO ZERO
*
LEVZERO  LW,R2    NEXSENT
         BEZ      NOLABEL      IF NEXT SENTENCE HAS NO INTERNAL LABEL
         STH,R2   COA+1           X
         LW,R2    L(X'04F3E800')  X
         STW,R2   COA             X OUTPUT LABEL DEF FOR NEXT SENTENCE
         BAL,11   MCLRET          X
         LI,R2    0
         STW,R2   NEXSENT
NOLABEL  LI,R2    1                 X
         STW,R2   LEVEL             X
         LI,R7    TRUPNT            X FLUSH TRULAB AND FLSLAB
         BAL,11   LDEFAUX           X
         LI,R7    FLSPNT            X
         BAL,11   LDEFAUX           X
         LI,R2    0
         STW,R2   LEVEL            SET LEVEL TO ZERO
         STW,R2   CONTYPNT         RESET CONTYPE
         B        SADNO
************************************************************************
*    LFTPAR       LEFT PARENTHESIS ROUTINE
*
LFTPAR   LW,R2    CONTYPNT         X
         LB,R3    CONTYPE,R2       X  SET BIT 5 OF CONTYPE BYTE
         OR,R3    L(X'00000004')   X
         STB,R3   CONTYPE,R2       X
         LW,R2    NOTHERE         X
         LI,R3    0               X
         SLD,R2   -1              X  NOTVAL = NOTVAL EOR NOTHERE
         EOR,R3   NOTVAL          X
         STW,R3   NOTVAL          X
         LW,R2    NOTHERE          X
         SLS,R2   1                X PUSH NOTHERE
         STW,R2   NOTHERE          X
         MTW,1    LEVEL
         LW,R2    UNARYFLG          CHECK UNARY FLAG
         BEZ      PUSHC             NO UNARY SIGN
         LW,R2    LEVEL
         PSW,R2   UNRYSPD
         LI,R2    0
         STW,R2   UNARYFLG          RESET UNARYFLG
         B        PUSHC
************************************************************************
*    LIMCON       (TEST FOR) LIMITED CONDITION
*
LIMCON   LW,R2    CONTYPNT
         LB,R3    CONTYPE,R2          GET TOP OF CONTYPE
         EOR,R3   L(X'00000080')    FLIP BIT 0 OF CONTYPE BYTE
         BEZ      POPCY             IF AND ONLY IF BIT 0 IS ON
         AND,R3   L(X'0000000A')    ISOLATE BITS 4 AND 6
         EOR,R3   L(X'00000008')    FLIP BIT 4
         B        COMCON
************************************************************************
*    MPRIOR       MOVE PRIORITY NUMBER
*
PRIOF    DATA     0                 PRIORITY OPTION DIAG FLAG
MPRIOR   LW,R2    PRIOF             CHECK PRIOF
         BCS,3    SADNO             DIAGNOSTIC GIVEN
         LI,R2    X'0020'
         AND,R2   PDBCC             SEG OPTION SPECIFIED?
         BNEZ     EXPRIO            YES
         LI,R2    0                 NO PRIORITY OPTION
         STW,R2   PREPR
         MTW,1    PRIOF             SET DIAGNOSTIC GIVEN FLAG
         LI,R3    99
         B        SADIAG
EXPRIO   RES      0                                                     COBOL14
         MTW,1    SEGFLG            SET SEGMENTATION FLAG               COBOL14
         LW,R2    INTGR             GET NUMBER IN BINARY                COBOL14
         CI,R2    99
         BLE      GDNUM             IF VALID PRIORITY NUMBER GOTO GDNUM
         LI,R3    28
         B        SADIAG
GDNUM    LI,R3    3             X
         LB,R3    PDBP,R3       X  GET SEGMENT LIMIT
         LI,R5    0
         CW,R2    R3
         BL       MBY        GO SET PRIORITY TO 0 IF LESS THAN SEG-LIM
         CI,R2    50
         BL       %+2
         AI,R5    2
         AI,R3    -1       X
         SW,R2    R3       X NEW EQUALS OLD + 1 - SEG-LIMIT
         STB,R2   PRI,R2            FLAG PRIORITY SEGMENTATION TABLE
         B        MBY2
MBY      LI,R2    0
MBY2     STW,R2   PREPR           SAVE PRIORITY NUMBFR
         STW,R5   SGINIF
         B        SADNO
SGINIF   DATA     0
************************************************************************
*    MX           DIAGNOSTIC MESSAGE SUBROUTINE
*
MX       LW,R2    DED
         BNEZ     SADNO      IF DED IS ON, EXIT
         B        SADIAG            GENERATE D
************************************************************************
*    NODNT        IF NEXT STRING IS A NAME, DON'T PUT IT IN DNT
*
NODNT    MTB,1    EXNAME
         B        SADNO
************************************************************************
*    NOT
*
NOT      LW,R2    CONTYPNT         X
         LB,R3    CONTYPE,R2       X SET BITS 7 AND 6 OF CONTYPE
         OR,R3    L(X'00000003')   X
         STB,R3   CONTYPE,R2       X
         LI,R2    9
         STW,R2   RELNOTS   SET RELNOTS TO 'NOT' = 9
         LI,R2    1
         AND,R2   NOTHERE
         BEZ      NOTOK       IF BIT 31 OF NOTHERE IS ZERO
         EOR,R2   NOTHERE         X
         STW,R2   NOTHERE         X  RESET NOTHERE
         LI,R3    62                SET UP DIAGNOSTIC NUMBER
         B        SADIAG
NOTOK    LI,R2    1               X
         AWM,R2   NOTHERE         X  SET NOTHERE
         B        SADNO
************************************************************************
*    OINT         OUTPUT INTERNAL LABEL
*
OINT     BAL,11   OQUES
         OR,R3    L(X'000000E0')   X
         LI,R2    2                X CALC AND STORE OPERAND OPTIONS
         STB,R3   COA,R2           X
         LW,R2    NEXSENT
         BNEZ     ALREADY        IF NEXT SENTENCE IS LABELED
         BAL,11   NEULAB            GET NEXT LABEL
         STW,R2   NEXSENT          SAVE LABEL
ALREADY  STH,R2   COA+1             STORE LABEL
         B        CINTL-1
************************************************************************
*    ONOC         OUTPUT NO OPERAND CLUSTER
*
ONOC     BAL,11   OQUES
         LI,R2    2                X
         STB,R2   COA              X       STORE CLUSTER SIZE
         AW,R3    RELNOTS    BUMP OPTIONS BY RELNOTS
         STB,R3   COA,R2              STORE OPERAND OPTIONS BYTE
         LW,R2    RELNOTS
         BEZ      MCLOP       EXIT IF NORMAL OPERATOR WAS OUTPUT
         LI,R2    0
         STW,R2   RELNOTS     RESET RELNOTS
         LI,R2    1          X
         EOR,R2   NOTHERE    X FLIP NOTHERE SINCE THIS NOT HAS BEEN USED
         STW,R2   NOTHERE    X
         B        MCLOP
************************************************************************
*    OPAR         OUTPUT PARAMETER CLUSTER
*
OPAR     BAL,11   OQUES
         LI,R2    X'8600'           OPERAND OPTIONS BYTE
         AWM,R2   COA
         LB,R3    BYTESNWD          X SET UP J FIELD
         STB,R3   COA+1             X
         B        NMAUX
************************************************************************
*    OPAS         OUTPUT NAME/QUALIFIER CLUSTER
*
OPAS     BAL,11   OQUES
         SLS,R3   8
         AWM,R3   COA               STORE OPERAND OPTION BYTE
OUTNMAUX LW,R2    HASHNUM
         BLZ      NMAUX2            NO DNT ENTRY
         STH,R2   COA+1             STORE REFERANCE NUMBER
         LI,R2    4
         B        INTA1
************************************************************************
*    ORC          OR 1 INTO BIT OF CONTYPE
*
ORC      LW,R2    CONTYPNT
         LB,R5    CONTYPE,R2
         OR,R3    R5
         STB,R3   CONTYPE,R2
         B        SADNO
************************************************************************
*    OSPL         OUTPUT SPECIAL SEARCH INTERNAL LABEL
*
OSPL     BAL,11   OQUES
         LW,R2    L(X'0400E300')   X
         AWM,R2   COA              X STORE OPERAND OPTIONS
         BAL,11   NEULAB      GET A NEW INTERNAL LABEL
         STH,R2   COA+1           STORE INTERNAL LABEL NUMBER
         STW,R2   SRLBL           SAVE LABEL NUMBER
         B        CINTL-1
************************************************************************
*    OSPLDF       OUTPUT SPECIAL SEARCH LABEL DEFINITION
*
OSPLDF   BAL,11   OQUES
         LW,R2    L(X'0400E800')   X
         AWM,R2   COA              X STORE OPERAND OPTIONS
         LW,R2    SRLBL
         BNEZ     %+2               INTERNAL LABEL NUMBER SET ALREADY   COBOL14
         BAL,11   NEULAB            GET NEW LABEL                       COBOL14
         STH,R2   COA+1
         LI,R2    0                                                     COBOL14
         STW,R2   SRLBL             RESET SPECIAL LABEL NUMBER          COBOL14
         B        MCLOP
************************************************************************
*    OSYN         OUTPUT SYNTAX ONLY CLUSTER
*
OSYN     BAL,11   OQUES
         LI,R2    3                X
         STB,R2   COA              X   STORE CLUSTER SIZE
         CI,R3    X'30'
         BCS,1    %+2               STATEMENT OPTION
         SLS,R3   8                 REFERENCE TYPE
         STS,R3   COA
         B        MCLOPI
************************************************************************
*    OUTALY       OUTPUT A DATA NAME CLUSTER REPRESENTING TALLY
*
OUTALY   LI,R2    0                 X
         STW,R2   HASHNUM           X CREATE DUMMY TALLY REFERENCE
         B        OUTNAMC
************************************************************************
*    OUTEXT       OUTPUT EXTERNAL NAME CLUSTER
*
OUTEXT   BAL,11   OQUES            X
         LB,R3    BYTESNWD         X SET UP J FIELD
         STB,R3   COA+1            X
         SLS,R3   24                 X
         OR,R3    L(BA(COA)+5)       X SET UP EXTERNAL NAME
         LW,R2    STRNGPNT           X
         MBS,R2   0                  X
         LB,R2    BYTESNWD         X
         AI,R2    7                X
         SLS,R2   -1               X  CALC AND STORE
         STB,R2   COA              X  CLUSTER SIZE
         LI,R2    X'A000'            X
         B        OUTNUM1
************************************************************************
*    OUTNAMC      OUTPUT NAME CLUSTER
*
OUTNAM   BAL,11   OQUES             FOR CLOSE STATEMENT
         LI,R2    X'8000'
         AWM,R2   COA
         LW,R2    STRING+10
         BCS,1    %+2
         B        OUTNMAUX+2
         LI,R3    X'1000'
         AWM,R3   COA
         STH,R2   COA+1
         LB,R2    STRING+11
         AI,R2    1
         LI,R3    BA(COA)+6
         STB,R2   R3
         LI,R2    BA(STRING+11)
         MBS,R2   0
         LB,R2    STRING+11
         B        NMAUX1
SAVHN    LW,R2    HASHNUM           SAVE FOR CLUSTER OUTPUT
         STW,R2   STRING+10
         LB,R2    BYTESNWD
         STB,R2   STRING+11
         LI,R3    BA(STRING+11)+1
         STB,R2   R3
         LI,R2    BA(STRING)
         MBS,R2   0
         B        SADNO
OUTNAMC  BAL,11   OQUES
         LI,R2    X'8000'          X
         AWM,R2   COA              X STORE OPERAND OPTIONS BYTE
         LW,R2    ALFLG             IS ALL FLAG SET                     COBOL14
         BEZ      OUTNMAUX          NO                                  COBOL14
         LI,R1    30                YES ISSUE DIAG                      COBOL14
         BAL,11   DIAG                                                  COBOL14
         LI,R2    0                                                     COBOL14
         STW,R2   ALFLG             CLEAR ALL FLAG                      COBOL14
         B        OUTNMAUX
************************************************************************
*    OUTNUM       OUTPUT NUMBER CLUSTER
*
OUTNUM   BAL,11   OQUES
         LB,R3    BYTESNLT
         STH,R3   COA+1
         LW,R2    POINTLOC         X
         STB,R2   COA+1            X STORE DECIMAL POINT LOCATION
         LI,R2    BA(INTAGER)
         SLS,R3   24
         OR,R3    L(BA(COA)+6)
         MBS,R2   0                MOVE NUMBER TO OUTPUT AREA
         LB,R2    BYTESNLT
         AI,R2    8               X CALC CLUSTER SIZE IN HALFWORDS
         SLS,R2   -1              X
         STB,R2   COA             X
         LI,R2    X'C000'          X
         LB,R8     BYTESNWD         NUMBER OF DIGITS IN LITERAL         COBOL14
         CI,R8     X'1'             TEST FOR EVEN OR ODD                COBOL14
         BAZ       %+2              EVEN NUMBER                         COBOL14
         OR,R2     L(X'100')        TURN ON REF TYPE FOR ODD NUMBER     COBOL14
OUTNUM1  AWM,R2   COA               STORE OPERAND OPTIONS
         B        MCLOP
************************************************************************
*    OUTPARA      OUTPUT PARAGRAPH DEFINITION
*
OUTPARA  RES      0                                                     COBOL14
         LI,R2    1                 IF                                  COBOL14
         CH,R2    CARDNO,R2          FIRST LINE OF LIBRARY              COBOL14
         BNE      OUTPARA2          NO. GO ON                           COBOL14
         LI,R3    BA(SPDAR)+9       YES.                                COBOL14
         LW,R2    PRCEDL            IF LENGTHS OF LAST PARAGPH NAME     COBOL14
         CB,R2    0,R3               AND CURRENT ARE EQUAL              COBOL14
         BNE      OUTPARA2          NO. GO ON                           COBOL14
         AI,R3    1                 YES.                                COBOL14
         STB,R2   R3                IF LAST AND CURRENT                 COBOL14
         LI,R2    BA(PRCED)          NAMES ARE EQUAL                    COBOL14
         CBS,R2   0                                                     COBOL14
         BE       SADNO             YES. DON'T DEFINE AGAIN             COBOL14
OUTPARA2 RES      0                                                     COBOL14
         LW,R2    PARAF                                                 COBOL14
         BEZ      OUTRBYP           GOTO OUTRBYP IF THIS FIRST PARAGRAPH
         BAL,11   RNGCLU     OTHERWISE OUTPUT RANGE CLUSTER FOR PRIOR 1
OUTRBYP  STW,R4   PARAF             SET FIRST PARAGRAPH SWITCH
         BAL,11   BUMP
         LI,R2    X'900'         REFERENCE TYPE = 9
         BAL,11   PROCLU            OUTPUT PARA DEFINITION CLUSTER
         BAL,R11  ODBSP             OUTPUT DEBUG SECT/PARA CLUSTER
         LI,R2    0                                                     COBOL14
         STW,R2   SEGFLG            RESET SEGMENTATION FLG              COBOL14
         LI,R2    X'96'            X
         STW,R4   PLAST
         BAL,11   SPD              X OUTPUT SPD ENTRY
         B        SADNO
************************************************************************
*    OUTPN        OUTPUT PROCEDURE NAME CLUSTER
*
OUTPN    BAL,11   OQUES
         LI,R2    X'8400'      X
         AWM,R2   COA          X STORE OPERAND OPTIONS BYTE
         LW,R2    REPLA
         BEZ      NMAUX        BRANCH IF NOT REPLACING NAME
         LW,R3    RLENG
         CB,R3    BYTESNWD
         BNE      NMAUX        BRANCH IF NOT REPLACING NAME
         LI,R2    BA(STRING)
         SLS,R3   24
         OR,R3    L(BA(RESTOR))
         CBS,R2   0
         BNE      NMAUX        BRANCH IF NOT REPLACING NAME
         LW,R2    PRSECL           X
         STB,R2   BYTESNWD         X
         LI,R2    BA(PRSEC)        X
         LW,R3    INCMOV           X
         MBS,R2   0                X REPLACE NAME
         LW,R2    PRSECNO          X
         BNEZ     REPLL            X
         LW,R2    PRSECHS          X
         OR,R2    L(X'80000000')   X
REPLL    STW,R2   HASHNUM          X
NMAUX    LW,R2    HASHNUM
         BLZ      NMAUX2      IF NO DNT ENTRY FOR THIS NAME
         LB,R3    BYTESNWD         X
         SLS,R3   8                X STORE J FIELD
         STW,R3   COA+1            X
         STH,R2   COA+1       STORE I FIELD
         SLS,R3   16               X
         OR,R3    L(BA(COA)+7)     X  STORE PROCEDURE NAME
         LW,R2    STRNGPNT         X
         MBS,R2   0                X
         LB,R2    BYTESNWD              X
NMAUX1   AI,R2    9
         SLS,R2   -1                    X
         B        INTA1
NMAUX2   LI,R3    X'1000'
         AWM,R3   COA            X CHANGE OPERAND TYPE TO 9
         B        NMAUX+2
************************************************************************
*    OUTSECT      OUTPUT SECTION DEFINITION
*
OUTSECT  LW,R2    PRSECL
         BEZ      OUTLBYP           GOTO OUTLBYP IF THIS FIRST SECTION
         BAL,11   RNGCLU            OUTPUT A RANGE CLUSTER
         LI,R2    0
         STW,R2   REPLA       CLEAR INCLUDE REPLACING SWITCH
         STW,R2   PARAF             CLEAR PARAF
         BAL,11   SECTRLR     OTHERWISE OUTPUT SECTION TRAILER
         LW,R2    PREPR            X
         CW,R2    PRSPR            X IF PRIORITY HAS CHANGED
         BE       OUTLBYP          X OUTPUT A BRANCH TO NEXT SECTION
         LW,R2    L(X'00DB8400')   X
         BAL,11   GENB             X
         LI,R3    1           X
         LW,R2    PRSPR       X BUMP LINK BY 1
         AWM,R3   LNKTBL,R2   X
OUTLBYP  RES      0                                                     COBOL14
         LI,R2    0                                                     COBOL14
         MTW,0    SEGFLG            SEE IF BEEN TO MPRIOR               COBOL14
         BNEZ     OUTLBY            BEEN THERE                          COBOL14
         STW,R2   PREPR             CLEAR PRIORITY SEG NUM              COBOL14
OUTLBY   RES      0                                                     COBOL14
         LI,R2    X'800'            REFERENCE TYPE = 8                  COBOL14
         BAL,11   PROCLU         OUTPUT SECTION DEF CLUSTER
         BAL,R11  ODBSP             OUTPUT DEBUG SECT/PARA CLUSTER
         LW,R2    L(BA(PRCED))   X
         LW,R3    MVWD           X SET UP MBS CONTROL WORDS
         MBS,R2   0              X  PRCED TO PRSEC
         LW,R2    TALYF             SAVE TALLY SECT FLAG                COBOL14
         STW,R2   STALY                                                 COBOL14
         LI,R2    X'94'            X
         BAL,11   SPD              X OUTPUT SPD ENTRY
         BAL,11   BUMP
         MTH,1    PDBP      BUMP SECTION COUNT
         LW,R2    PRAUXS
         BEZ      SADNO      GOTO SADNO IF NO STORED PARAGRAPH NAME
         LW,R2    PRAUXI          X
         LW,R3    PRAUXI+1        X
         MBS,R2   0               X RESTORE PARA NAME
         LI,R2    0               X
         STW,R2   PRAUXS          X
         B        SADNO
************************************************************************
*    OUTSTRG      OUTPUT STRING CLUSTER
*
OUTSTRG  BAL,11   OQUES
         LW,R2    ALFLG
         BNEZ     ALSTRG            IF ALL STRING GOTO ALSTRG
         LI,R2    X'B000'             SET UP OPERAND OPTIONS
OUTSTAUX AWM,R2   COA               X STORE OPERAND OPTIONS
         LB,R3    BYTESNWD        X STORE J FIELD
         STB,R3   COA+1           X
         SLS,R3   24                X
         OR,R3    L(BA(COA)+5)      X  STORE STRING
         LW,R2    STRNGPNT          X
OUTSTX   MBS,R2   0                 X
         LB,R2    COA+1
         AI,R2    7             X
         SLS,R2   -1            X  CALC AND
         STB,R2   COA           X  STORE SIZE
         B        MCLOPI
ALSTRG   LI,R2    X'B100'       SET UP OPERAND OPTIONS FOR ALL STRING
         B        OUTSTAUX
***********************************************************************
*    PLSTST       TEST PLAST
*
PLSTST   LW,R2    PLAST
         BNEZ     SADNO
         LI,R3    111              INCORRECT GOTO STRUCTURE
         B        SADIAG
********************************************************************************
*    PMETASM      TO BYPASS LANGUAGE-NAME 'METASYM' IN ENTER STMT
*
PMETASM  LI,6     BA(SOURCEST)      LOAD IN SOURCE STRING ADDR
         LW,7     GENMETA           LOAD DEST ADDR
         CBS,6    0
         BNE      SADNO             NO RETURN
         BAL,11   SCAN
         B        SADYES            YES RETURN
GENMETA  GEN,8,24 8,BA(STRING)
SOURCEST TEXT      C'METASYM '      METASYM STRING
************************************************************************
*    PNTEGER      TEST FOR PROC NAME, INTEGER
*
PNTEGER  BAL,11   SCAN
         LW,R2    CONTROL
         CI,R2    3
         BNE      SADNOSN              NOT NUMBER
         LI,R2    X'FF'
         AND,R2    POINTLOC
         BNEZ     SADNOSN              NOT INTEGER
         LI,R2    1              X
         STW,R2   HASHNUM        X ENTER NUMBER INTO DNT
         BAL,10   HASH           X
         B        SADYES
************************************************************************
*    POPC         POP CONTYPE
*
POPC     LI,R5    SADNO
POPCAUX  LW,R2    CONTYPNT         X
         LB,R3    CONTYPE,R2       X  ACTUAL STACK POP ROUTINE
         AI,R2    -1               X  NOTE  THERE IS NO NEED TO CHECK
         LB,R6    CONTYPE,R2       X        FOR EMPTY STACK - THIS
         OR,R3    R6
         STB,R3   CONTYPE,R2       X        ROUTINE ONLY USED FOR
         STW,R2   CONTYPNT         X        UN-NESTING.
         LW,R2    UNARYFLG          CHECK UNARY FLAG
         BEZ      TOBSADNO          NO TO BRANCH SADNO
         LI,R2    0
         STW,R2   UNARYFLG          CLEAR UNARY FLAG
         LI,R3    X'15'             OPERAND OPTION FOR UNARY SIGN
         B        ONOC              TO OUTPUT UNARY CLUSTER
TOBSADNO B        0,R5
************************************************************************
*    POPCY        POP CONTYPE AND YES RETURN
*
POPCY    LI,R5    SADYES
         B        POPCAUX
************************************************************************
*    PROSTA       SCAN A NOTE PARAGRAPH
*
*        READS PAST SOURCE STATEMENTS UNTIL EITHER A PROC DEF OR EOF
*        IS SENSED. IF EOF IS SENSED, GO TO SADNO, OTHERWISE
*    1)  ENTER IT IN THE DNT
*    2)  RESET COLUMN A FLAG
*    3)  CALL PROSTO
*    4)  RETURN TO SADYES - SIMULATED.
*
PROSTA   LI,R3    1
         STB,R3   SKIP,R3             SET SKIP
         LI,R2    0
         STB,R2   NOSCAN      RESET NOSCAN
         BAL,11   SCAN
         EOR,R3   CONTROL           X DIAGNOSE MISSING TERMINAL '.'
         BNEZ     PROSTAN           X
         LI,R3    10                X
         B        SADIAG            X
PROSTAN  MTB,1    EXNAME            SET NO HASH SWITCH
         BAL,11   SCAN
         LI,R2    1
         EOR,R2   CONTROL
         BEZ      SADNO       IF EOF GO TO SADNO
         LW,R2    COLAFLG
         BEZ      PROSTA           LOOP IF NOT COLUMN A
         LW,R2    CONTROL
         BEZ      NAMP            BRANCH IF NAME
         CI,R2    3
         BNE      PROSTA           LOOP IF NOT NUMBER
         LW,R2    POINTLOC
         BNEZ     PROSTA           LOOP IF NOT INTEGER
         LI,R2    1
         STW,R2   HASHNUM         SET UP DUMMY HASH NUMBER
NAMP     BAL,10   HASH              ENTER IT IN THE DNT
         LI,R2    0
         STW,R2   COLAFLG           RESET COLAFLG
         AW,R4    YDISP             FOOL DRIVER INTO SADYES
         AI,R4    1
*        DROP INTO PROSTO
*
************************************************************************
*    PROSTO       STORE PROCEDURE NAME
*
PROSTO   LI,R2    0
         STW,R2   PREFNO
         STW,R2   PRESHS
         STW,R2   TALYF                                                 COBOL14
         LW,R2    HASHNUM
         BLZ      NTREF          GOTO NTREF IF NO DNT REFERENCE NUMBER
         STW,R2   PREFNO
         MTW,1    TALYF             SET TALLY FLAG                      COBOL14
         B        DOREST
NTREF    AND,R2   L(X'7FFFFFFF')    FLIP SIGN OF HASH NUMBER
         STW,R2   PRESHS
DOREST   LB,R3    BYTESNWD          = SIZE OF NAME
         STW,R3   PRCEDL            STORE SIZE
         SLS,R3   24
         OR,R3    L(BA(PRCED))
         LI,R2    BA(STRING)
         MBS,R2   0
         B        SADNO                 EXIT TO SAD
TALYF    DATA     0                 TALLY POSSIBLE FLAG                 COBOL14
STALY    DATA     0                                                     COBOL14
************************************************************************
*    PUSHC        PUSH CONTYPE
*
PUSHC    LW,R2    CONTYPNT         X
         AI,R2    1                X BUMP STACKPOINTER
         STW,R2   CONTYPNT         X
         LI,R3    0
         STB,R3   CONTYPE,R2        ZERO NEW TOP OF STACK
         B        SADNO
*  NOTE   THERE IS NO NEED TO CHECK CONTYPE FOR OVERFLOW SINCE ITS
*        SIZE IS LIMITED BY THE SIZE OF SADSTACK WHICH LIMITS THE
*        DEPTH OF RECURSION.
*
************************************************************************
*    RHTPAR       RIGHT PARENTHESIS
*
RHTPAR   LW,R2    *UNRYSPD          LOAD TOP OF THE STACK
         BEZ      RHTPAR2
         CW,R2    LEVEL
         BNE      RHTPAR2
         STW,R2   UNARYFLG          SET UNARYFLG, OUTPUT ONOC15 IN POPC
         PLW,R2   UNRYSPD           REDUCE ONE LEVEL OF UNARY STACK
RHTPAR2  MTW,-1   LEVEL
         LW,R2    NOTHERE           X
         LI,R3    0                 X
         SLD,R2   -1                X  1. POP NOTHERE 1 LEVEL
         LW,R5    R3                X  2. NOTVAL = NOTVAL EOR NOTHERE
         LI,R3    0
         SLD,R2   -1                X  3. NOTHERE= NOTHERE EOR NOTHERE+1
         EOR,R5   R3                X
         EOR,R3   NOTVAL            X
         STW,R3   NOTVAL            X
         LW,R3    R5                X
         SLD,R2   1                 X
         STW,R2   NOTHERE           X
         B        POPC
************************************************************************
*    RNAME        STORE REPLACABLE NAME
*
RNAME    LI,R2    BA(STRING)
         LW,R3    INCMOV2
         MBS,R2   0               SAVE NAME
         LB,R2    BYTESNWD
         STW,R2   RLENG           SAVE LENGTH
         STW,R2   REPLA           SET REPLACING SWITCH
         B        SADNO
************************************************************************
*    RSTF         RESET VARIOUS FLAGS
*
RSTF     LI,R2    0
         STW,R2   RELNOTS-1,R3
         B        SADNO
************************************************************************
*    SETF         SET VARIOUS FLAGS
*
SETF     STW,R3   RELNOTS-1,R3
         B        SADNO
************************************************************************
*    SIMPKEY      (TEST FOR) SEMI-IMPERATIVE KEYWORD
*
SIMPKEY  BAL,11   SCAN             GET NEXT WORD
         LW,R2    CONTROL          GET WORD TYPE
         AND,R2   SIMASK
         EOR,R2   SIMASK
         B        IMPAUX           GO TO TEST
SIMASK   GEN,32   X'000003C0'      MASK
************************************************************************
*    SRCLAUS      SCAN RIGHT TO BEGINNING OF A CLAUSE
*
SRCLAUS  LI,R2    0
         STW,R2   COMAFLG
         STW,R2   SEMIFLG
         BAL,11   SCAN            GET NEXT WORD
         LI,R3    1
         EOR,R3   CONTROL
         BEZ      SADNOSN          RETURN NO IF EOF
         LI,R3    X'200'
         AND,R3   CONTROL
         BNEZ     NOYES            RETURN YES IF KEYWORD
         B        SRCLAUS
************************************************************************
*    SRPAST       SIMPERA RECOVERY ROUTINE
*
SRPAST   BAL,11   SCAN             GET NEXT WORD
         LI,R2    1
         STB,R2   NOSCAN
         LI,R2    X'200'
         AND,R2   CONTROL
         BEZ      SRCLAUS          EXIT IF NOT KEYWORD
         LI,R2    X'FC0'
         AND,R2   CONTROL
         EOR,R2   L(X'340')
         BEZ      ACOND            BRANCH IF CONDITION
         LI,R2    0
         STB,R2   NOSCAN           BYPASS KEYWORD
         LI,R1    113              POSSIBLE INCORRECT USAGE
         BAL,11   DIAG
         B        SRCLAUS
ACOND    LI,R1    50               ILLEGAL CONDITION
         BAL,11   DIAG
*
*        FALL INTO SRPER
*
************************************************************************
*    SRPER        SCAN RIGHT TO A PERIOD
*
SRPER    LI,R2    1
         STB,R2   SKIP,R2
         LI,R2    0
         STB,R2   NOSCAN           RESET NOSCAN
         BAL,11   SCAN        SCAN TO A PERIOD
         LI,R3    1                 X
         EOR,R3   CONTROL           X
         BNEZ     HAVPER            X DIAGNOSE MISSING TERMINAL '.'
         LI,R3    10                X
         B        SADIAG            X
HAVPER   BAL,11   SCAN
         LI,R3    1
         EOR,R3   CONTROL
         BNEZ     NOYES           YES RETURN IF NOT EOF
         B        SADNOSN
************************************************************************
*    TESNOT       TEST NOTNR
*
TESNOT   LI,R2    0
         STW,R2   NOANDOR           RESET NOANDOR
         XW,R2    NOTNR
         BEZ      SADYES            YES RETURN IF NOTNR IS OFF
         B        SADNO
************************************************************************
*    TESTDI       TEST DIAGNOSTIC SWITCH
*
TESTDI   LW,R2    DED
         BEZ      SADNO             NO RETURN IF DED IS OFF
         B        SADYES
************************************************************************
*    TRANST       TRANSFER STRING
*
TRANST   LB,R2    BYTESNWD
         LI,R3    3                 CHECK IN NUMERIC LITERAL            COBOL14
         CW,R3    CONTROL                                               COBOL14
         BNE      TRANST1           IF YES ADD IF EXHIBIT NAMED         COBOL14
         LH,R3    COA               IF EXHIBIT NAMED ADD 1 TO SIZE      COBOL14
         AND,R3   L(X'007F')        PICK UP CONTROL BYTE                COBOL14
         CI,R3    X'70'                                                 COBOL14
         BNE      TRANST1+1         NOT EXHIBIT NAMED                   COBOL14
         LW,R3    STRNGPNT          BA(STRING)                          COBOL14
         AW,R3    R2                ADD SIZE OF LITERAL                 COBOL14
         LI,R8    X'40'            BLANK                                COBOL14
         STB,R8   0,R3              STORE BLANK IN STRING               COBOL14
TRANST1  RES       0                                                    COBOL14
         AI,R2    1                PROVIDE FOR AFTER BLANK
         CW,R2    STRNGCNT
         BG       STRNGCLP          IF TOO LARGE TO FIT
         LW,R3    STRNGCNT        X
         SW,R3    R2              X CALC AND STORE SIZE REMAINING
         STW,R3   STRNGCNT        X
         STB,R2   STRNGPNT+1         X
STRNGO   LCI      2                  X  MOVE STRING TO STRNGST
         LM,R2    STRNGPNT           X
         MBS,R2   0                  X
         STW,R3   STRNGPNT+1        SAVE DESTINATION FOR NEXT TIME
         B        SADNO
STRNGCLP LW,R3    STRNGCNT         X
         BEZ      SADNO            X
         STB,R3   STRNGPNT+1       X  SET UP MOVE TO TRUNCATE
         LI,R3    0                X  EXCESS CHARACTERS
         STW,R3   STRNGCNT         X
         B        STRNGO           X
************************************************************************
*   TRCFLG        SET TRACE FLAG
*
TRCFLG   RES      0
         LI,R2    X'8000'
         OR,R2    PDBP         PICK TRACE BIT
         STW,R2   PDBP
         B        SADNO
***********************************************************************
*
*   UNARYCK        CHECK THE UNARY FLAG  IF SET SADYES ELSE SADN        O
*
UNARYCK  LI,R2    0
         XW,R2    UNARYFLG          CHECK UNARY SIGN
         BEZ       SADNO
         B         SADYES
************************************************************************
*
*   DSLWUNY    ISSUE DIAG FOR DISALLOWABLE UNARY SIGN
*
DSLWUNY  LI,R2    0
         XW,R2    UNARYFLG
         BEZ      SADNO             NO, TO SADNO
         LI,R3    5
         B        SADIAG
************************************************************************
SAVPN    MTW,0    PDBDBG            SAVE DEBUG-NAME
         BEZ      SADNO             NOT DEBUGGING MODE
         MTW,0    UDBGF
         BEZ      SADNO             NOT USE DEBUGGING STATEMENT
         MTW,-1   DBTRC
         BLEZ     SADNO             NO MORE BUFFER LEFT
         LW,R3    DBTBB
         AI,R3    1
         LB,R2    BYTESNWD          NAME/STRING LENGTH
         CW,R2    DBTRC
         BLE      %+2
         LW,R2    DBTRC             TRUNCATE PART OF STRING
         STB,R2   R3
         LCW,R2   R2
         AWM,R2   DBTRC             FOR NEXT MOVE
         LI,R2    BA(STRING)
         MBS,R2   0                 MOVE TO DBTRN
         STW,R3   DBTBB
         B        SADNO
TRDBG    STW,R4   FOURSTOR          OUTPUT DEBUG-NAME TO EPF
         LI,R4    BA(DBTRH)
         BAL,R11  WREPF             WRITE DEBUG-NAME CLUSTER
         LW,R4    FOURSTOR
         LW,R1    DBTCB
         MBS,0    BA(DBTRN+7)+3     BLANK FILL BUFFER
         LI,R1    31                RECOVER FOR NEXT
         STW,R1   DBTRC
         LI,R1    BA(DBTRN)-1
         STW,R1   DBTBB
         B        SADNO
DRSTF    LI,R3    0
         XW,R3    UDBGF
         BEZ      SADNO             NOT USE DEBUGGING
         B        SADYES            USE DEBUGGING
***********************************************************************
*
*    XTRAF        OUTPUT STRONG ERROR CLUSTER
*
*
XTRAF    LW,R2    L(X'00FF0000')
         AND,R2   COA
         OR,R2    L(X'02007202')
         STW,R2   COA
         B        MCLOP
************************************************************************
*
*        TABLE ROUTINES ADDED FOR COMPRESSED SYNTAX14
*
XTRANST  MTW,0    XTFG
         BEZ      SADNO             NOT EXCUTE TRANST
         B        TRANST
CDX256   MTW,0    OPFG
         BEZ      SADNO             NO DIAG 256
         LI,R3    256
         B        DX
CDX049   MTW,0    SRFG
         BNEZ     SADNO             NO DIAG 049
         LI,R3    49
         B        DX
REFRET   MTW,0    SRFG
         BNEZ     SADYES            YES RETURN
         B        SADNO
CKFRET   LI,R3    0
         XW,R3    SIFG              RESET SIFG
         BEZ      SADNO             NO RETURN
         B        SADYES
CKINS    MTW,0    INSPF
         BEZ      SADNO             EXAMINE
         B        SADYES            INSPECT
CLCOPT   LW,R2    L(X'007F0000')
         AND,R2   COA               CLEAR STATEMENT OPTION
         STW,R2   COA
         B        SADNO
         TITLE    'PHASE 1.4 INTERNAL ROUTINES'
************************************************************************
*   BUMP          BUMP PROC COUNT IN PDB
*
BUMP     LI,R2    1
         MTH,1    PDBK,R2       BUMP PROCEDURE COUNT IN PDB
         B        *11
************************************************************************
*    CINTL        OUTPUT INTERNAL LABEL CLUSTER
*
         LI,11    SADNO
CINTL    LI,R2    4
         STB,R2   COA
         B        MCLRET
************************************************************************
*    GENPAR       GENERATE PARAGRAPH NAME
*
GENPAR   LI,11    SADNO
*
*        FALL INTO GENSP
*
************************************************************************
*    GENSP        GENERATE PROCEDURE NAME
*
GENSP    STW,11   AUXADDR
         LW,R2    PROLBL            GET LAST PROCEDURE LABEL
         AI,R2    1                 CREATE NEW LABEL
         STW,R2   PROLBL            STORE NEW LABEL
         STW,R2   STRING
         STW,R2   PRCED           X
         LI,R2    4               X
         STW,R2   PRCEDL          X  STORE LABEL AND ASSOCIATED
         LI,R2    0               X  INFORMATION IN PRCED ET AL
         STW,R2   PREFNO          X
         STW,R2   PRESHS          X
         LI,R2    2                X
         STW,R2   HASHNUM          X
         LI,R2    4                X ENTER INTO DNT
         STB,R2   BYTESNWD         X
         BAL,10   HASH             X
         LW,R2    HASHNUM
         BLZ      NOTIN
         STW,R2   PREFNO
         B        *AUXADDR
NOTIN    AND,R2   L(X'7FFFFFFF')
         STW,R2   PRESHS
         B        *AUXADDR
************************************************************************
*    LBLLEV       LEVEL LABEL STACK
*
LBLLEV   STW,11   AUXADDR          SAVE RETURN ADDRESS
         LW,R5    *R7              LOAD STACKPOINTER
         LW,R3    LEVEL
         LI,R6    0
LBLAGIN  CB,R6    *R5
         BE       LBLNUF           EXIT IF BOTTOM OF STACK
         CB,R3    *R5
         BGE      LBLNUF           EXIT IF FAR ENOUGH
         STB,R3   *R5              STORE NEW LEVEL
         AI,R5    -1               DROP STACKPOINTER BY 1
         B        LBLAGIN           TRY NEXT LABEL
LBLNUF   LW,R5    *R7         GET STACKPOINTER FOR TOP OF STACK
         CB,R3    *R5
         BE       LBLOK       GOTO LBLOK IF THERE IS LABEL = LEVEL
         BAL,11   NEULAB     OTHERWISE GET NEW LABEL
         AI,R5    1            X
         STW,R5   *R7          X BUMP STACKPOINTER
         STW,R2   *R5        X
         STB,R3   *R5        X STORE NEW LABEL
         B        *AUXADDR       RETURN
LBLOK    LI,R2    X'FFFF'     X
         AND,R2   *R5         X     LABEL IN TOP OF STACK TO R2 AND RET
         B        *AUXADDR    X
************************************************************************
*    LDEFAUX      DEFINE LABELS IN STACK DOWN TO LEVEL
*
LDEFAUX  LW,R5    *R7
         LW,R6    LEVEL
         STW,11   AUXADDR
LDEFLP   LW,R3    *R5
         BEZ      LDEFF         EXIT IF END OF STACK
         CB,R6    R3
         BG       LDEFF      EXIT IF FAR ENOUGH
         STH,R3   COA+1            X
         LI,R2    X'E800'          X
         OR,R2    COA              X OUTPUT DEF FOR THIS LABEL
         STW,R2   COA              X
         BAL,11   CINTL            X
         AI,R5    -1          POP STACK 1 LEVEL
         B        LDEFLP
LDEFF    STW,R5   *R7         STORE NEW STACKPOINTER
         B        *AUXADDR         EXIT
************************************************************************
*    MCLOP        A COMMON CLUSTER OUTPUT ROUTINE
*
MCLOPI   LI,R2    0
         STW,R2   ALFLG             RESET ALFLG
MCLOP    LI,11    SADNO
*
*        FALL INTO MCLRET
*
************************************************************************
*    MCLRET       MAIN CLUSTER OUTPUT ROUTINE
*
MCLRET   STW,11   MCLADR            SAVE RETURN ADDRESS
         STW,R3   THRSTOR
         LW,R3    FSW               X SAVE
         B        %+1,R3            X CLUSTER NUMBER
         LW,R3    CLUSNUM           X OF EPF ITEM PREVIOUS
         AI,R3    -2                X TO FIRST
         STH,R3   LNKTBL+101
         LI,R3    5                 X
         STW,R3   FSW               X
         LI,R2    0
         STW,R2   PLAST          RESET PLAST
         STW,R4   FOURSTOR
         STW,R5   FIVSTOR
         LI,R4    BA(COA)
         BAL,11   WREPF
         LW,R4    FOURSTOR
         MTW,0    DBSCT
         BNEZ     %+4               NOT DEBUG SECT/PARA
         LW,R5    COA               X
         AND,R5   L(X'007F0000')    X SAVE CONTROL BYTE
         STW,R5   COA             RESTORE CONTROL BYTE TO COA
         LW,R3    THRSTOR
         LW,R5    FIVSTOR
         B        *MCLADR        RETURN
************************************************************************
*    NEULAB       GENERATE AN INTERNAL LABEL
*
NEULAB   LW,R2    PRESILB           GET FORMER INTERNAL LABEL
         AI,R2    1                 CREATE NEW LABEL
         STW,R2   PRESILB           STORE NEW LABEL
         B        *11            EXIT WITH LABEL IN R2
************************************************************************
*    OQUES        A COMMON ROUTINE USED BY NORMAL CLUSTER OUTPUT
*                 SUBROUTINES
*
OQUES    LW,R2    DED
         BNEZ     SADNO       EXIT TO SAD IF DED IS ON
         LW,R5    NOANDOR
         BEZ      *11         RETURN NOANDOR IS OFF
         STW,R2   NOANDOR         RESET NOANDOR
         STW,R11  AUXADDR
         LW,R5    COA
         STW,R5   COASTR            SAVE CONTEXTS OF COA
         AND,R5   L(X'00FF0000')   X
         OR,R5    L(X'02002802')   X OUTPUT A MISSING OPERATOR CLUSTER
         STW,R5   COA              X
         BAL,11   MCLRET           X
         LW,R5    COASTR                X RESTORE COA
         STW,R5   COA                   X
         B        *AUXADDR         RETURN
************************************************************************
*    PROCLU       OUTPUT PROCEDURE DEFINITION CLUSTER
*
PROCLU   OR,R2    L(X'00F38000')   CONTROL BYTE =73 OPERAND TYPE = 8
         LW,R3    PDBDBG            SET DEBUGGING MODE FLAG
         STW,R3   DBSCT
         OR,R2    PREPR
GENB     LW,R3    PREFNO
         BNEZ     YESREF       BRANCH IF THERE IS A DNT ENTRY
         LW,R3    PRESHS      OTHERWISE GET HASH NUMBER
         BNEZ     GENB1                                                 COBOL14
         MTW,0    TALYF                                                 COBOL14
         BNEZ     YESREF            TALLY                               COBOL14
GENB1    RES      0                                                     COBOL14
         OR,R2    L(X'00001000')   OPERAND TYPE =9
YESREF   STW,R2   COA          STORE CONTROL BYTE AND OPERAND TYPE
         SLS,R3   8          X
         OR,R3    PRCEDL     X CALC AND STORE J AND I OR L FIELDS
         SLS,R3   8          X
         STW,R3   COA+1      X
         LW,R2    L(BA(PRCED))    X
         LW,R3    PRCEDL          X
         SLS,R3   24              X MOVE PROCEDURE NAME TO OUTPUT AREA
         OR,R3    L(BA(COA)+7)    X
         MBS,R2   0               X
         LW,R2    PRCEDL             X
         AI,R2    9                  X
         SLS,R2   -1                 X CALC AND STORE CLUSTER LENGTH
         STB,R2   COA                X
         B        MCLRET
ODBSP    MTW,0    DBSCT
         BEZ      *R11              NO DEBUGGING MODE
         STW,R11  MCLADR
         STW,R4   FOURSTOR
         LW,R4    COA
         AND,R4   L(X'FF7F00FF')
         AI,R4    X'9B00'
         STW,R4   COA
         LI,R4    BA(COA)
         BAL,R11  WREPF             OUTPUT DEBUG SECT/PARA TO EPF
         LW,R4    L(X'007F0000')
         AND,R4   COA
         STW,R4   COA
         STH,R4   DBSCT             CLEAR DEBUGGING MODE FLAG
         LW,R4    FOURSTOR
         B        *MCLADR
ALTFLG   RES      0
         LW,R3    PDBDBG
         STW,R3   DBSCT
         B        SADNO
ALTNAM   RES      0                                                     COBOL14
         LW,R3    PDBDBG            PICK UP DEBUG MODE FLAG             COBOL14
         STW,R3   DBSCT                                                 COBOL14
         BAL,R11  ODBSP             WRITE NAME CLUSTER IF DEBUG         COBOL14
         B        SADNO                                                 COBOL14
************************************************************************
*    RNGCLU       OUTPUT A RANGE CLUSTER
*
RNGCLU   LW,R2    PRESILB
         STH,R2   COA+1             STORE RANGE NUMBER
         LH,R3    PDBK         X
         CW,R3    R2           X  UPDATE MAX RANGE IF NECESSARY
         BGE      NOUPDATE     X
         STH,R2   PDBK         X
NOUPDATE LI,R2    0
         STW,R2   PRESILB           CLEAR PRESILB
         LW,R2    L(X'04F3E900')
         STW,R2   COA         X SET OPERAND OPTIONS TO E9
         B        MCLRET          OUTPUT AND RETURN
************************************************************************
*    SECTRLR      OUTPUT SECTION TRAILER
*
SECTRLR  RES      0
         LW,R5    PRSPR           GET PRIORITY NO.
         LW,R2    LNKTBL,R5       GET ASSOCIATED LINK
         LI,R3    0
         SLD,R2   -16
         STW,R2   COA+1           X STORE LINK
         STW,R3   COA+2           X IN OUTPUT
         LW,R2    CLUSNUM
         STW,R2   LNKTBL,R5        STORE NEW LINK
         LW,R2    PRSECNO
         BNEZ     SECTRR1           CHECK TALLY                         COBOL14
         MTW,0    STALY                                                 COBOL14
         BEZ      OTSECLU      BRANCH IF NO DNT ENTRY
SECTRR1  STH,R2   COA+1                                                 COBOL14
         LW,R2    L(X'06F38A00')  X STORE SIZE, CONTROL BYTE, OPERAND
         STW,R2   COA             X OPTIONS BYTE
         B        MCLRET
OTSECLU  LW,R2    PRSECHS       X
         STH,R2   COA+1            STORE HASH NUMBER
         LW,R2    PRSECL
         LI,R3    10
         STB,R2   COA,R3     STORE NAME LENGTH
         LI,R2    BA(PRSEC)       X
         LW,R3    PRSECL          X
         SLS,R3   24              X MOVE PROCNAME TO OUTPUT AREA
         OR,R3    L(BA(COA)+11)   X
         MBS,R2   0               X
         LW,R3    L(X'00F39A00')
         STW,R3   COA
         LW,R2    PRSECL            X
         AI,R2    13                X CALC AND STORE CLUSTER LENGTH
         SLS,R2   -1                X
         STB,R2    COA              X
         B        MCLRET
************************************************************************
*   SPD           OUTPUT AN SPD ENTRY IF DNT HAS NOT OVERFLOWED
*
SPD      LW,R3    SPDSW
         BNEZ     *11        RETURN IF DNT HAS OFLO-ED
         STH,R2   SPDAR         STORE CONTROL BYTE
         LW,R2    PREFNO       GET REF NO
         BNEZ     SPDCON
         MTW,0    TALYF                                                 COBOL14
         BNEZ     SPDCON            TALLY                               COBOL14
         STW,R4   SPDSW       X
         B        *11         X ABORT SPD CONSTRUCTION
SPDCON   LI,R3    1
         STH,R2   SPDAR+1,R3         STORE REF NO
         LW,R2    CARDNO
         STH,R2   SPDAR+1       STORE COPYLINE NO
         LH,R2    CARDNO
         STH,R2   SPDAR,R3        STORE SOURCE LINE NO
         LW,R2    PREPR
         STB,R2   SPDAR+2        STORE PRIORITY
         LW,R2    PRCEDL
         STB,R2   SPDAR+2,R3           STORE NAME LENGTH
         AI,R2    12
         SLS,R2   -1
         STB,R2   SPDAR         STORE CLUSTER LENGTH
         LI,R2    BA(PRCED)        X
         LW,R3    PRCEDL           X
         SLS,R3   24               X MOVE PROC NAME
         OR,R3    L(BA(SPDAR)+10)  X
         MBS,R2   0                X
         STW,R4   FOURSTOR
         STW,11   MCLADR
         LI,R4    BA(SPDAR)        X
         BAL,11   WRSPD            X CALL OUTPUT ROUTINE
         LW,R4    FOURSTOR
         B        *MCLADR        EXIT
ZROCOA   LI,R2    0                 RESET COA FOR NON-DECLARATIVE
         STW,R2   COA
         B        SADNO
************************************************************************
*
*   CONTEST       CHECK FOR 'CONSOLE' FOLLOWING 'FROM' IN 'ACCEPT' STMNT
*
************************************************************************
CONTEST  BAL,R11  SCAN              SKIP OVER PREVIOUS RESERVED WORD
         BAL,R11  MTCONS            MATCH CONSOLE
         B        SADNO             YES
         BAL,R11  MTMNT             MATCH MNTBL
         B        CONTEST1
         MTW,0    R2
         BEZ      SADNO
CONTEST1 LI,R3    230               DIAGNOSTICS
         B        SADIAG
MTCONS   LW,R3    DESTREG           COMPARE CONSOLE
         LI,R2    BA(CONSOLIT)
         CBS,R2   0
         BE       *R11
         AI,R11   1
         B        *R11
MTMNT    LW,R3    MNTBL             COMPARE MNTBL
         BLEZ     *R11
         LW,R2    HASHNUM
         AND,R2   L(X'FFFF')
         SLS,R3   1
MTMNT0   CH,R2    MNTBL,R3
         BE       MTMNT1
         AI,R3    -2
         BLEZ     *R11              NOT MATCHED
         B        MTMNT0
MTMNT1   AI,R3    1
         LH,R2    MNTBL,R3          GET FLAG
         AI,R11   1
         B        *R11
************************************************************************
*
*   PRINTST       CHECK FOR DEVICE FOLLOWING 'UPON' IN DISPLAY STATEMENT
*
************************************************************************
PRINLIT  TEXT     C'PRINTER '       8-BYTE LITERAL TO TEST VS. STRING
CONSOLIT TEXT     C'CONSOLE '       8-BYTE LITERAL TO TEST VS. STRING
PREPF    DATA     X'03550003'
DESTREG  GEN,8,24  8,BA(STRING)     COUNT AND DESTINATION ADDR FOR CBS
         SPACE    2
PRINTST  BAL,R11  SCAN
         LW,R3    DESTREG           SET UP R|1 WITH COUNT AND DEST ADDR
         LI,R2    BA(PRINLIT)       SET UP R WITH SOURCE ADDRESS
         CBS,R2   0                 COMPARE
         BE       PRINTST1
         BAL,R11  MTCONS            MATCH CONSOLE
         B        SADNO
         BAL,R11  MTMNT             MATCH MNTBL
         B        CONTEST1
         MTW,0    R2
         BEZ      SADNO             CONSOLE
PRINTST1 STW,4    FOURSTOR
         LI,4     BA(PREPF)
         BAL,11   WREPF             OUTPUT EPF FOR PRINTER
         LW,4     FOURSTOR
         B        SADNO
* DIVIDE - RECEIVING FIELD COUNT
CMCNT    LW,3     GIVCNT            CHECK MULTIPLE RECEIVING FIELD
         BEZ      SADNO
         LI,R3    236
         B        SADIAG
SETPN    RES      0                                                     COBOL14
         MTW,1    PNFLAG                                                COBOL14
         B        COLA
SETPNF   RES      0                                                     COBOL14
         MTW,-1   PNFLAG                                                COBOL14
         B        SADNO                                                 COBOL14
         TITLE    'PHASE 1.4 JUMP TABLE'
TBLJMP   EQU      %
         B          CBYTE                                               00000000
         B          COPT                                                00000001
         B          DX                                                  00000002
         B          EX                                                  00000003
         B          INTA                                                00000004
         B          MX                                                  00000005
         B          OINT                                                00000006
         B          ONOC                                                00000007
         B          OPAS                                                00000008
         B          ORC                                                 00000009
         B          OSYN                                                00000010
         B          RSTF                                                00000011
         B          SETF                                                00000012
         B          A                                                   00000013
         B          ACCT                                                00000014
         B          ALTFLG                                              00000015
         B          ALTNAM                                              00000016
         B          CAND                                                00000017
         B          CCT                                                 00000018
         B          CDX049                                              00000019
         B          CDX256                                              00000020
         B          CKFRET                                              00000021
         B          CKINS                                               00000022
         B          CLCOPT                                              00000023
         B          CMCNT                                               00000024
         B          COLA                                                00000025
         B          COMMA                                               00000026
         B          CONCN                                               00000027
         B          CONCON                                              00000028
         B          CONFORM                                             00000029
         B          CONID                                               00000030
         B          CONLIT                                              00000031
         B          CONTEST                                             00000032
         B          COR                                                 00000033
         B          DCCT                                                00000034
         B          DMPST                                               00000035
         B          DRSTF                                               00000036
         B          DSLWUNY                                             00000037
         B          ENABLE                                              00000038
         B          ENDCON                                              00000039
         B          ENDCONR                                             00000040
         B          ENDSOUR                                             00000041
         B          ENUFF                                               00000042
         B          FPERD                                               00000043
         B          GENPAR                                              00000044
         B          GENPARA                                             00000045
         B          GENSECT                                             00000046
         B          IMPKEYW                                             00000047
         B          INTEGER                                             00000048
         B          LEVBAD                                              00000049
         B          LEVDEC                                              00000050
         B          LEVDECR                                             00000051
         B          LEVINC                                              00000052
         B          LEVLEV                                              00000053
         B          LEVZERO                                             00000054
         B          LFTPAR                                              00000055
         B          LIBCPY                                              00000056
         B          LIMCON                                              00000057
         B          MPRIOR                                              00000058
         B          NAME                                                00000059
         B          NODNT                                               00000060
         B          NONNLIT                                             00000061
         B          NOT                                                 00000062
         B          NUMBER                                              00000063
         B          OPAR                                                00000064
         B          OSPL                                                00000065
         B          OSPLDF                                              00000066
         B          OUTALY                                              00000067
         B          OUTEXT                                              00000068
         B          OUTNAM                                              00000069
         B          OUTNAMC                                             00000070
         B          OUTNUM                                              00000071
         B          OUTPARA                                             00000072
         B          OUTPN                                               00000073
         B          OUTSECT                                             00000074
         B          OUTSTRG                                             00000075
         B          PLSTST                                              00000076
         B          PMETASM                                             00000077
         B          PNTEGER                                             00000078
         B          POPC                                                00000079
         B          POPCY                                               00000080
         B          PRINTST                                             00000081
         B          PROSTA                                              00000082
         B          PROSTO                                              00000083
         B          PUSHC                                               00000084
         B          REFRET                                              00000085
         B          REPLC                                               00000086
         B          RHTPAR                                              00000087
         B          RNAME                                               00000088
         B          RNPTR                                               00000089
         B          RSTCNT                                              00000090
         B          SAVHN                                               00000091
         B          SAVPN                                               00000092
         B          SBW                                                 00000093
         B          SEMICOL                                             00000094
         B          SETPN                                               00000095
         B          SETPNF                                              00000096
         B          SFRPC                                               00000097
         B          SIMPKEY                                             00000098
         B          SLIBN                                               00000099
         B          SNC                                                 00000100
         B          SNW                                                 00000101
         B          SRCLAUS                                             00000102
         B          SRPAST                                              00000103
         B          SRPER                                               00000104
         B          TESNOT                                              00000105
         B          TESTDI                                              00000106
         B          TRANST                                              00000107
         B          TRCFLG                                              00000108
         B          TRDBG                                               00000109
         B          UNARYCK                                             00000110
         B          WORDR                                               00000111
         B          XTRAF                                               00000112
         B          XTRANST                                             00000113
         B          ZROCOA                                              00000114
         END
