         SYSTEM   SIG7FDP                                               COBOL35
         TITLE    'PHASE 3.5'                                           COBOL35
         DEF      COB35                                                 COBOL35
         REF      PDBDBG                                                COBOL35
         REF      PDBDBGC                                               COBOL35
         REF      DIAG                                                  COBOL35
         REF      RDCRF                                                 COBOL35
         REF      WRCRFS                                                COBOL35
         REF      PH35E                                                 COBOL35
         REF      PDBXA                                                 COBOL35
         REF      CARDNO                                                COBOL35
         REF      PDBXB                                                 COBOL35
         REF      PDBZ                                                  COBOL35
         REF      DBSIZE                                                COBOL35
         REF      NXTSTRNG                                              COBOL35
         REF      TBLSIZE                                               COBOL35
R1       EQU      1                                                     COBOL35
R2       EQU      2                                                     COBOL35
R3       EQU      3                                                     COBOL35
R4       EQU      4                                                     COBOL35
R5       EQU      5                                                     COBOL35
R6       EQU      6                                                     COBOL35
R7       EQU      7                                                     COBOL35
R8       EQU      8                                                     COBOL35
R9       EQU      9                                                     COBOL35
R10      EQU      10                                                    COBOL35
R11      EQU      11                                                    COBOL35
R12      EQU      12                                                    COBOL35
R13      EQU      13                                                    COBOL35
R14      EQU      14                                                    COBOL35
R15      EQU      15                                                    COBOL35
*        R2 = BA CLUSTER                                                COBOL35
*        R7 = CONTROL BYTE                                              COBOL35
*        R6 = OPERAND OPTIONS                                           COBOL35
*        R10 = INTERNAL BAL'S                                           COBOL35
COB35    RES      0                                                     COBOL35
*        INSERT CODE TO SET DYNAMIC HERE                                COBOL35
         LW,R5    DBPTR                                                 COBOL35
         STW,R5   DBPTRE            INITIALIZE POINTER                  COBOL35
         LW,R5    CRFPTR            INITIALIZE POINTER
         STW,R5   CRFPTR2
START    LI,R10   SETUP                                                 COBOL35
RDCLUS   RES      0                                                     COBOL35
         LCI      4                                                     COBOL35
         STM,R10  SAVREG3           SAVE R10-R13                        COBOL35
RDCLUS1  BAL,R11  RDCRF                                                 COBOL35
         BLZ      COB35%EX          END OF FILE                         COBOL35
         LW,R1    R2                                                    COBOL35
         AI,R1    1                                                     COBOL35
         LB,R7    0,R1              PICK UP CONTROL                     COBOL35
         BNEZ     RDCLUS2                                               COBOL35
         LI,R13   BA(CARDNO)        MUST BE LINE NO CLUSTER             COBOL35
         OR,R13   COUNT4                                                COBOL35
         LW,R12   R2                                                    COBOL35
         AI,R12   2                                                     COBOL35
         MBS,R12  0                 SAVE LINE NO AND SUBLINE NO         COBOL35
         LW,R8    CRFPTR                                                COBOL35
         CW,R8    CRFPTR2           IS STACK EMPTY                      COBOL35
         BE       %+3               YES                                 COBOL35
         BAL,R10  STK%CRF           NO--PUT LINE NUMBER IN STACK        COBOL35
         B        RDCLUS1           GET NEXT CRF                        COBOL35
         LW,R4    R2                BYTE ADDR OF CLUSTER
         BAL,R11  WRCRFS            WRITE LINE NO CLUSTER               COBOL35
         B        RDCLUS1                                               COBOL35
RDCLUS2  RES      0                 PICK UP OPERAND OPTIONS             COBOL35
         LW,R6    R7                                                    COBOL35
         AND,R6   MSK1              REMOVE HIGH ORDER BIT               COBOL35
         STW,R6   CBYTE2            SAVE CONTROL BYTE
         AI,R1    1                                                     COBOL35
         LB,R6    0,R1                                                  COBOL35
         LCI      4                                                     COBOL35
         LM,R10   SAVREG3                                               COBOL35
         B        *R10                                                  COBOL35
SETUP    RES      0                                                     COBOL35
         LW,R1    R7                CONTROL BYTE                        COBOL35
         AND,R1   MSK1
         AI,R1    -X'4A'
         CI,R1     X'35'
         BG       CBERR             CONTROL BYTE ERROR                  COBOL35
         EXU      JMPTBL,R1                                             COBOL35
JMPTBL   RES      0                                                     COBOL35
         B        DONOTHNG          EXIT PROGRAM
         B        DONOTHNG          USING (PROCEDURE DIV)
         B        IFF               CALL
         B        DISP              INSPECT
         B        DISP              STRING
         B        DISP              UNSTRING
         B        ACPT              ACCEPT                              COBOL35
         B        ARITH             ADD                                 COBOL35
         B        ALTR              ALTER                               COBOL35
         B        OPN%CLS           CLOSE                               COBOL35
         B        COMP              COMPUTE                             COBOL35
         B        DISP              DISPLAY                             COBOL35
         B        ARITH             DIVIDE                              COBOL35
         B        ENT               ENTER                               COBOL35
         B        DONOTHNG          ENTER COBOL                         COBOL35
         B        DISP              EXAMINE                             COBOL35
         B        DONOTHNG          GENERATE                            COBOL35
         B        ENT               GO TO
         B        IFF               IF                                  COBOL35
         B        DONOTHNG          INITIATE                            COBOL35
         B        ARITH             MOVE                                COBOL35
         B        ARITH             MULT                                COBOL35
         B        OPN%CLS           OPEN                                COBOL35
         B        PERF              PERFORM                             COBOL35
         B        READ              READ                                COBOL35
         B        WRITE             RELEASE                             COBOL35
         B        READ              RETURN                              COBOL35
         B        DONOTHNG          SEARCH                              COBOL35
         B        DONOTHNG          SEEK                                COBOL35
         B        SETT              SET                                 COBOL35
         B        DONOTHNG          SORT                                COBOL35
         B        DONOTHNG          STOP                                COBOL35
         B        ARITH             SUBTRACT                            COBOL35
         B        DONOTHNG          TERMINATE                           COBOL35
         B        P:USE             USE                                 COBOL35
         B        WRITE             WRITE                               COBOL35
         B        DONOTHNG          READY                               COBOL35
         B        DONOTHNG          RESET                               COBOL35
         B        DONOTHNG          EXHIBIT                             COBOL35
         B        IFF               WHEN                                COBOL35
         B        P:DCL             DECLARATIVE/END DECL                COBOL35
         B        PROCNAM           PROCEDURE DEF                       COBOL35
         B        CORR              ADD CORR                            COBOL35
         B        CORR              SUB CORR                            COBOL35
         B        CORR              MOVE CORR                           COBOL35
         B        DONOTHNG          SOURCE SELECTED                     COBOL35
         B        DONOTHNG          REPORT REF                          COBOL35
         B        DONOTHNG          DATA RECORD                         COBOL35
         B        DONOTHNG          REPORT RECORDS                      COBOL35
         B        DONOTHNG          ACTUAL KEY                          COBOL35
         B        DONOTHNG          OCCURS DEPENDING ON                 COBOL35
         B        DONOTHNG          7D
         B        DONOTHNG          7E
         B        DONOTHNG          7F
CBERR    RES      0                                                     COBOL35
         LI,R1    510               COMPILER ERROR 10 (A)               COBOL35
         BAL,R11  DIAG                                                  COBOL35
         B        START                                                 COBOL35
*        THIS ROUTINE REMOVES THE REFERGNCE NUMBER BEFORE WRITING OUT   COBOL35
*        THE CRF ALL CRF'S READ MAY USE THIS ROUTINE                    COBOL35
CMPRS    RES      0                                                     COBOL35
         CI,R6    X'9B'            SEE IF NAME CLUSTER                  COBOL35
         BE       *R10
         CI,R6    X'9C'                                                 "3!3635
         BE       *R10
         LCI      15                                                    COBOL35
         STM,R1   SAVREG2                                               COBOL35
         STW,R10  CMEXT                                                 COBOL35
         LW,R13   CRFCMB            BA CLUSTER AREA                     COBOL35
         LW,R1    R2                                                    COBOL35
         AI,R1    1                                                     COBOL35
         LB,R7    0,R1                                                  COBOL35
         BE       CMPRS2            LINE# CLUSTER                       COBOL35
         LB,R1    0,R2              SIZE IN HALFWORDS                   COBOL35
         SLS,R1   1                 BYTES                               COBOL35
         CI,R6    X'93'             CHECK OPERAND OPT FOR FILE REF      COBOL35
         BNE      NOTFILE                                               COBOL35
         OR,R13   COUNT4                                                COBOL35
         LW,R12   R2                SOURCE ADDRESS OF CRF CLUSTER       COBOL35
         MBS,R12  0                                                     COBOL35
         AI,R12   2                 SKIP REF NO                         COBOL35
         OR,R13   COUNT2                                                COBOL35
         MBS,R12  0                 MOVE N,A FIELDS                     COBOL35
         LI,R12   3                                                     COBOL35
         STB,R12  CRFCM             CHANGE SIZE TO 3 HALFWORDS          COBOL35
         B        CMPRS1            SET UP FOR WRITE CLUSTER            COBOL35
NOTFILE  RES      0                                                     COBOL35
         CI,R6    X'92'                                                 COBOL35
         BG       CMPRS2            WRITE FROM R2 ADDRESS               COBOL35
         CI,R6    X'89'                                                 COBOL35
         BLE      CMPRS2                                                COBOL35
         OR,R13   COUNT6            MOVE FIELDS A--E                    COBOL35
         LW,R12   R2                SOURCE ADDRESS                      COBOL35
         MBS,R12  0                 MOVE                                COBOL35
         AI,R12   2                 SKIP REF NO                         COBOL35
         AI,R1    -8                ADJUST SIZE OF CLUSTER
         STB,R1   R13               STORE FOR MOVE REST OF CLUSTER      COBOL35
         MBS,R12  0                                                     COBOL35
         AI,R1    6                 SIZE OF CLUSTER
         SLS,R1   -1                CHANGE SIZE TO HALFWORDS
         STB,R1   CRFCM             STORE                               COBOL35
CMPRS1   RES      0                                                     COBOL35
         LW,R4    CRFCMB            BYTE ADDR OF CLUSTER
         B        %+2                                                   COBOL35
CMPRS2   RES      0                                                     COBOL35
         LW,R4    R2                BYTE ADDR OF CLUSTER
         BAL,R11  WRCRFS                                                COBOL35
         LCI      15                                                    COBOL35
         LM,R1    SAVREG2                                               COBOL35
         B        *CMEXT            RETURN                              COBOL35
WT%CRF   RES      0                                                     COBOL35
         LCI      15                                                    COBOL35
         STM,R1   SAVREG4           SAVE REGISTERS                      COBOL35
         STW,R10  CRF%EX                                                COBOL35
         LW,R2    CRFPTR            FIRST CLUSTER                       COBOL35
         LW,R8    CRFPTR2           NEXT AVAILABLE ADDRESS              COBOL35
         CW,R2    R8                                                    COBOL35
         BE       WT%CRF2                                               COBOL35
WT%CRF1  RES      0                                                     COBOL35
         LW,R1    R2
         AI,R1    2                                                     COBOL35
         LB,R6    0,R1              PICK UP OPRND OPT,REF TYPE
         BAL,R10  CMPRS             COMPRESS AND WRITE CLUSTER          COBOL35
         LB,R9    0,R2              H.W. SIZE OF CLUSTER                COBOL35
         SLS,R9   1                 BYTE SIZE                           COBOL35
         AW,R2    R9                POINT AT NEXT ENTRY                 COBOL35
         CW,R2    R8                                                    COBOL35
         BL       WT%CRF1           WRITE NEXT CLUSTER                  COBOL35
WT%CRF2  RES      0
         LW,R5    CRFPTR
         STW,R5   CRFPTR2
         LCI      15                                                    COBOL35
         LM,R1    SAVREG4                                               COBOL35
         B        *CRF%EX                                               COBOL35
PROCNAM  RES      0
         LI,R5    START
         STW,R5   PROC%EX                                               COBOL35
         LW,R5    R7
         AND,R5   MSK1
         STW,R5   CBYTE             SAVE CONTROL BYTE
         CI,R6    X'E8'                                                 COBOL35
         BE       PROC7             SEE IF THIS IS FOR AT END ON READ   COBOL35
         CI,R6    X'9A'             SECTION TRAILER                     COBOL35
         BE       %+3               BYPASS                              COBOL35
         CI,R6    X'E0'             IS THIS AN INTERNAL LABEL           COBOL35
         BL       PROC2             NO                                  COBOL35
         BAL,R10  CMPRS                                                 C626335
         B        START             GET NEXT CLUSTER                    COBOL35
PROC1    BAL,R10  CMPRS             YES--BYPASS                         COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER                    COBOL35
         CI,R6    X'9B'             SEE IN NAME CLUSTER                 COBOL35
         BE       *PROC%EX          YES BYPASS IT                       COBOL35
         B        SETUP             NO PROCESS IT                       COBOL35
PROC2    RES      0                                                     COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    5                                                     COBOL35
         LB,R5    0,R3              PRIORITY NUMBER                     COBOL35
         AI,R3    1                                                     COBOL35
         SLS,R3   -1                HALFWORD ADDRESS OK PROC NO         COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                                                    COBOL35
         OR,R4    PROCNT                                                COBOL35
         BAL,R10  CKPROC            CHECK IF DEBUG                      COBOL35
         B        PROC1             INVALID REFERENCE                   COBOL35
ENT%PROC RES      0                                                     COBOL35
         BAL,R10  STK%CRF                                               COBOL35
         LW,R4    CBYTE                                                 COBOL35
         CI,R4    X'73'             SEE IF PROC STATEMENT               COBOL35
         BE       %+3               YES                                 COBOL35
         LW,R4    MOVE10            SET SIZE = 30 (MAX SIZE OF NAME)    COBOL35
         B        %+2                                                   COBOL35
         LI,R4    12                SIZE OF DB-CONTENTS                 COBOL35
         LI,R10   PROC3                                                 COBOL35
PROC2A   RES      0                                                     COBOL35
         STW,R4   SIZE2                                                 COBOL35
         CW,R4    DBSIZE           IS SIZE > THAN OLD SIZE              COBOL35
         BL       *R10              NO                                  COBOL35
         STW,R4   DBSIZE           YES--CHANGE                          COBOL35
         B        *R10              RETURN (IF USED AS SUBROUTINE)      COBOL35
PROC3    RES      0                                                     COBOL35
         LI,R10   PROC5                                                 COBOL35
*        MOVE LINE NUMBER                                               COBOL35
PROC4    RES      0                                                     COBOL35
         LI,R12   0                                                     COBOL35
         STW,R12  R13               CLEAR DECA                          COBOL35
         LH,R14   PDBXA             LINE NUMBER                         COBOL35
         CVS,R14  CVRTBL            CONVERT TO PACFED                   COBOL35
         BAL,R11  CVREBCD           CONVERT TO EBCDIC                   COBOL35
         LW,R4    MOVE3             STRING CLUSTER                      COBOL35
         STW,R4   DBBUILD                                               COBOL35
         LW,R4    BCDLIN1           BUILD STRING                        COBOL35
         STW,R4   DBBUILD+1                                             COBOL35
         LW,R4    BCDLIN2           BUILD STRING                        COBOL35
         STW,R4   DBBUILD+2                                             COBOL35
         LI,R12   BA(DBBUILD)                                           COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT12           SIZE FOR MBS                        COBOL35
         MBS,R12  0                 MOVE TO STACK SFLD                  COBOL35
         LW,R4    PDBDBG                                                COBOL35
         STW,R4   MOVE7                                                 COBOL35
         LI,R4    6                                                     COBOL35
         STW,R4   MOVE8             RFLD SIZE                           COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE            UPDATE POINTER                      COBOL35
         B        *R10              RETURN (IF USED AS SUBROUTINE)      COBOL35
PROC5    RES      0                                                     COBOL35
         LW,R4    CBYTE                                                 COBOL35
         CI,R4    X'73'             IF NOT PROC DEF LEAVE CONTENTS BLK  COBOL35
         BNE      PROC6                                                 COBOL35
         BAL,R10  RDCLUS            READ NAME CLUSTER                   COBOL35
         CI,R6    X'9B'             MAKE SURE THIS IS STRING CLUSTER    COBOL35
         BNE      PROC6                                                 COBOL35
*        MOVE  'FALL THROUGH' TO DEBUG-CONTENTS                         COBOL35
         LW,R4    MOVE3             SET UP SFLD                         COBOL35
         STW,R4   DBBUILD                                               COBOL35
         LI,R13   BA(DBBUILD+1)                                         COBOL35
         OR,R13   COUNT13                                               COBOL35
         LI,R12   BA(FALL)                                              COBOL35
         MBS,R12  0                 MOVE TO WORK AREA                   COBOL35
         LI,R12   9                                                     COBOL35
         STB,R12  DBBUILD           HALF WORD SIZE OF SFLD              COBOL35
         SLS,R12  1                                                     COBOL35
         LW,R13   DBPTRE                                                COBOL35
         STB,R12  R13                                                   COBOL35
         LI,R12   BA(DBBUILD)                                           COBOL35
         MBS,R12  0                                                     COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP6             DISPLACEMENT FOR DB-CONTENTS        COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LI,R5    12                                                    COBOL35
         STW,R5   MOVE8             SIZE OF RFLD ITEM                   COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
*  NOTE STACK IS WRITTEN BEFORE PROCEDURE DEF SO THAT BOTH FALL THRU    COBOL35
*  AND BRANCHES TO LABEL WILL BE CORRECT                                COBOL35
         BAL,R10  WRT%DBSK                                              COBOL35
*  BUILD NAME CLUSTERS                                                  COBOL35
         LW,R4    MOVE3
         STW,R4   DBBUILD
         LW,R4    R2
         AI,R4    6
         LB,R5    0,R4              SIZE OF STRING
         AI,R5    1
         LI,R13   BA(DBBUILD+1)
         STB,R5   R13
         STW,R4   R12
         MBS,R12  0
         AI,R5    6                 ADJUST  SIZE OF  CLUSTER
         SLS,R5   -1                H.W. SIZE
         STB,R5   DBBUILD
         LI,R12   BA(DBBUILD)
         LW,R13   DBPTRE
         SLS,R5   1
         STB,R5   R13
         MBS,R12  0
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP2             DISPLACEMENT FOR NAME RFLD          COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LW,R5    MOVE10                                                COBOL35
         STW,R5   MOVE8                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 MOVE TO STACK                       COBOL35
         STW,R13  DBPTRE                                                COBOL35
PROC6    RES      0                                                     COBOL35
         LW,R3    CBYTE                                                 COBOL35
         CI,R3    X'5B'            GO TO
         BE       *PROC%EX
         CI,R3    X'57'             ENTER STATEMENT                     COBOL35
         BE       *PROC%EX                                              COBOL35
         CI,R3    X'52'             ALTER STATEMENT                     COBOL35
         BE       *PROC%EX                                              COBOL35
         CI,R3    X'61'             PERFORM                             COBOL35
         BE       *PROC%EX                                              COBOL35
         CI,R3    X'73'                                                 COBOL35
         BE       PROC6A
         BAL,R10  WRT%DBSK
         BAL,R10  WT%CRF            WRITE SAVED CLUSTER                 COBOL35
         B        *PROC%EX          RETURN                              COBOL35
PROC6A   RES      0
         LW,2     CRFPTR            SET CLUSTER PTR FOR CMPRS
         LI,R6    X'94'             SET OPERAND OP FOR CMPRS            COBOL35
         BAL,R10  WT%CRF            WRITE OUT PROC CLUSTER              COBOL35
*        GENERATE CODE FOR DECLARATIVE                                  COBOL35
         CI,R3    X'73'                                                 COBOL35
         BNE      *PROC%EX                                              COBOL35
         BAL,R10  PERFUSE                                               COBOL35
         BAL,R10  WRT%DBSK          WRITE OUT DEBUG STACK               COBOL35
         B        *PROC%EX          RETURN                              COBOL35
PROC7    RES      0                                                     COBOL35
         MTW,0    LABL#             CHECK FOR POSSIBLE INT LAB FOR READ COBOL35
         BEZ      DONOTHNG          BYPASS                              COBOL35
         LW,R4    R2                                                    COBOL35
         SLS,R4   -1                                                    COBOL35
         AI,R4    2                                                     COBOL35
         LH,R5    0,R4                                                  COBOL35
         CW,R5    LABL#                                                 COBOL35
         BNE      DONOTHNG          BYPASS                              COBOL35
         BAL,R10  CMPRS                                                 COBOL35
         B        RDSTAT7           GO TO READ CLUSTER ROUTINE TO PROCESCOBOL35
STK%CRF  RES      0                                                     COBOL35
         LW,R13   CRFPTR2                                               COBOL35
*        SAVE CLUSTER THEN SET UP LINE & COUNT THEN READ                COBOL35
         LB,R12   0,R2                                                  COBOL35
         SLS,R12  1                                                     COBOL35
         STB,R12  R13                                                   COBOL35
         LW,R12   R2                                                    COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  CRFPTR2           POINTER TO NEXT ENTRY IN STACK      COBOL35
         B        *R10                                                  COBOL35
WRT%DBSK RES      0                                                     COBOL35
         LCI      10                                                    COBOL35
         STM,R1   SAVREG4                                               COBOL35
         LW,R3    DBPTRE            LAST ENTRY IN STACK                 COBOL35
         LW,R4    DBPTR                                                 COBOL35
         CW,R4    R3                                                    COBOL35
         BE       WRT%EX                                                COBOL35
         LW,R5    R4                SAVE IN R5                          COBOL35
         LB,R1    0,R4              HALFWORD SIZE
WRT1     RES      0                                                     COBOL35
         BAL,R11  WRCRFS            WRITE CLUSTER                       COBOL35
         SLS,R1   1                 SIZE OF LAST CLUSTER IN BYTES
         AW,R5    R1
         CW,R5    R3                COMPARE WITH LAST ENTRY             COBOL35
         BGE      WRT%EX            GREATER--FINISHED                   COBOL35
         LB,R1    0,R5
         LW,R4    R5                POINTER FOR WRCRF                   COBOL35
         B        WRT1                                                  COBOL35
WRT%EX   RES      0                                                     COBOL35
         LW,R5    DBPTR                                                 COBOL35
         STW,R5   DBPTRE                                                COBOL35
         LCI      10                                                    COBOL35
         LM,R1    SAVREG4                                               COBOL35
         B        *R10              RETURN                              COBOL35
CVREBCD  RES      0                                                     COBOL35
         STW,R3   SAV3                                                  COBOL35
         LI,R3    BA(BCDLIN1)                                           COBO335
         UNPK,4   0,R3                                                  COBO335
         LI,R3    6                                                     COBOL35
         STB,R3   BCDLIN1           PUT SIZE IN                         COBOL35
         LW,R3    BCDLIN2                                               COBO335
         OR,R3    MSK3                                                  COBO335
         STW,R3   BCDLIN2                                               COBOL35
         LW,R3    SAV3                                                  COBOL35
         B        *R11              RETURN                              COBOL35
CVRTBL   DATA     8000000           CONVERSION TABLE                    COBOL35
         DATA     4000000                                               COBOL35
         DATA     2000000                                               COBOL35
         DATA     1000000                                               COBOL35
         DATA     800000                                                COBOL35
         DATA     400000                                                COBOL35
         DATA     200000                                                COBOL35
         DATA     100000                                                COBOL35
         DATA     80000                                                 COBOL35
         DATA     40000                                                 COBOL35
         DATA     20000                                                 COBOL35
         DATA     10000                                                 COBOL35
         DATA     8000                                                  COBOL35
         DATA     4000                                                  COBOL35
         DATA     2000                                                  COBOL35
         DATA     1000                                                  COBOL35
         DATA     800                                                   COBOL35
         DATA     400                                                   COBOL35
         DATA     200                                                   COBOL35
         DATA     100                                                   COBOL35
         DATA     80                                                    COBOL35
         DATA     40                                                    COBOL35
         DATA     20                                                    COBOL35
         DATA     10                                                    COBOL35
         DATA     8                                                     COBOL35
         DATA     4                                                     COBOL35
         DATA     2                                                     COBOL35
         DATA     1                                                     COBOL35
         DATA     0                                                     COBOL35
         DATA     0                                                     COBOL35
         DATA     0                                                     COBOL35
         DATA     0                                                     COBOL35
         RES      0                                                     COBOL35
* WRITE  PERFORM USE CLUSTER                                            COBOL35
PERFUSE  RES      0                                                     COBOL35
         LCI      10                                                    COBOL35
         STM,R1   SAVREG4                                               COBOL35
         LI,R1    1                                                     COBOL35
         LW,R4    T:ENTRY           TABLE ENTRY POINTER                 COBOL35
         AI,R4    3                                                     COBOL35
         SLS,R4   1                 H.W.                                COBOL35
         LH,R5    0,R4              PNO                                 COBOL35
         STH,R5   PERFCRF1,R1                                           COBOL35
         AI,R4    1                                                     COBOL35
         LH,R5    0,R4              XNO                                 COBOL35
         STH,R5   PERFCRF2                                              COBOL35
         LI,R12   BA(PERFCRF)       MOVE PERFORM CLUSTER TO STACK       COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT12                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE            UPDATE POINTER                      COBOL35
         LCI      10                                                    COBOL35
         LM,R1    SAVREG4                                               COBOL35
         B        *R10              RETURN                              COBOL35
DONOTHNG RES      0                                                     COBOL35
         BAL,R10  CMPRS             WRITE CLUSTER OUT                   COBOL35
         BAL,R10  RDCLUS            READ NEXT                           COBOL35
         CI,R7    X'80'             IS THIS NEW STATEMENT               COBOL35
         BAZ      DONOTHNG          NO                                  COBOL35
         B        SETUP             RETURN                              COBOL35
READ     RES      0                                                     COBOL35
         LI,R10   RDSTATA                                               COBOL35
         STW,R10  RDEX                                                  COBOL35
         LI,R10   DONOTHNG                                              COBOL35
         STW,R10  RDNOT                                                 COBOL35
RD%WRT1  RES      0                                                     COBOL35
*        CHECK CLUSTER FOR VALIDITY                                     COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    6                 POINT TO FIELD N (DDB BLOCK POINTER)COBOL35
         LB,R5    0,R3                                                  COBOL35
         STW,R5   DDB#                                                  COBOL35
         AI,R3    -2                                                    COBOL35
         SLS,R3   -1                HALFWORD ADD OF REF# FIELD          COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                                                    COBOL35
         OR,R4    FILECNT           FIELD A,B,K OF TABLE ENTRY          COBOL35
         BAL,R10  CKFILE            VALIDATE FOR DEBUG                  COBOL35
         B        *RDNOT            NOT DEBUG--PASS CLUSTER             COBOL35
         LW,R4    DBPTR             INITIALIZE POINTER FOR PROC4        COBOL35
         STW,R4   DBPTRE                                                COBOL35
         BAL,R10  PROC4             SET UP LINE NUMBER MOVES IN STACK   COBOL35
         LW,R3    DDB#                                                  COBOL35
         LH,R14   *PDBZ+4,R3        RELATIVE ADDR OF DDB                COBOL35
         AW,R14   PDBZ+3            DDB AREA ADDR                       COBOL35
         SLS,R14  -2                R14 = W.A. OF DESCR. BLOCK          COBOL35
         STW,R14  DDBPTR            SAVE W.A. OF DDB                    COBOL35
* DO SIZE MOVE AND LOGICAL RECORD MOVE TO DEBUG-CONTENTS                COBOL35
         AI,R14   2                                                     COBOL35
         LI,R3    1                                                     COBOL35
         LH,R4    *R14,R3           PICK UP A FIELD (SIZE OF RECORD)    COBOL35
         BAL,R10  PROC2A            PUT SIZE CLUSTERS IN STACK          COBOL35
         LW,R5    MOVE1                                                 COBOL35
         OR,R5    COUNT10           H.W. SIZE OF CLUSTER                COBOL35
         STW,R5   DBBUILD                                               COBOL35
         LI,R5    X'8000'           SET FIELD H TO 8 (FILE SECTION) I=0 COBOL35
         STW,R5   DBBUILD+1                                             COBOL35
         LW,R3    DDB#                                                  COBOL35
         LW,R5    SIZE2             SIZE OF ITEM (STORED BY PROC2A)     COBOL35
         STB,R3   R5                MAKE FIELDS N & P                   COBOL35
         STW,R5   DBBUILD+3                                             COBOL35
         LW,R14   DDBPTR                                                COBOL35
         AI,R14   9                                                     COBOL35
         LB,R5    *R14              PICK UP P FIELD FROM DDB            COBOL35
         SLS,R5   24                                                    COBOL35
         STW,R5   DBBUILD+2         BASE DISP OF RECORD                 COBOL35
         LI,R5    X'FF0A'                                               COBOL35
         STW,R5   DBBUILD+4         FILLER FOR CLUSTER                  COBOL35
         LI,R12   BA(DBBUILD)                                           COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 MOVE SFLD TO STACK                  COBOL35
*  SET UP RFLD FOR DEBUG-CONTENTS                                       COBOL35
         LW,R5    SIZE2                                                 COBOL35
         STW,R5   MOVE8             SIZE TO RFLD CLUSTER                COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP6             OFFSET FOR DEBUG-CONTENTS           COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 PUT IN STACK                        COBOL35
         STW,R13  DBPTRE            SAVE POINTER                        COBOL35
*    MOVE NAME TO NAME FIELDS BY USING DBNAME                           COBOL35
*    NOTE COULD PICK UP NAME FROM DDB ALSO                              COBOL35
         BAL,R10  DBNAME                                                COBOL35
         B        *RDEX                                                 COBOL35
RDSTATA  RES      0                                                     COBOL35
         BAL,R10  PERFUSE                                               COBOL35
RDSTAT   RES      0                                                     COBOL35
         BAL,R10  CMPRS             WRITE OUT FIRST READ STATEMENT CRF  COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER                    COBOL35
         CI,R7    X'62'             IS THIS A READ CLUSTER              COBOL35
         BNE      RDSTAT1           NO--CHECK IF GO TO                  COBOL35
         CI,R6    X'E3'                                                 COBOL35
         BE       RDSTAT2           AT END CLUSTER                      COBOL35
         CI,R6    X'E4'             INVALID KEY CLUSTER                 COBOL35
         BE       RDSTAT2                                               COBOL35
         CI,R6    X'90'             READ INTO CLUSTER                   COBOL35
         BE       RDSTAT9           YES                                 COBOL35
RDSTAT1  RES      0                                                     COBOL35
         CI,R7    X'DB'             IS IT THE GO TO CLUSTER             COBOL35
         BE       RDSTAT5           YES                                 COBOL35
         CI,R7    X'F3'                                                 COBOL35
         BE       RDSTAT7                                               COBOL35
*  IF CONTROL COMES HERE THEN THE AT END IS NOT A GO TO TYPE STATEMENT  COBOL35
*  THEREFORE CLUSTERS IN STACK MUST BE HELD UNTIL THIS STATEMENT        COBOL35
*  IS EVALUATED FOR DEBUG--THE STACK POINTERS ARE SAVED AND ADJUSTED    COBOL35
*  ACCORDINGLY                                                          COBOL35
         LW,R13   DBPTR                                                 COBOL35
         STW,R13  ORIG%PTR          SAVE FOR RESTORING LATER            COBOL35
         LW,R13   DBPTRE                                                COBOL35
         STW,R13  RD%PTRE                                               COBOL35
         STW,R13  DBPTR             CHANGE FIRST POINTER TO DBPTRE      COBOL35
         B        SETUP                                                 COBOL35
RDSTAT2  RES      0                                                     COBOL35
         LW,R4    R2                                                    COBOL35
         SLS,R4   -1                H.W. ADDRESS OF CLUSTER             COBOL35
         AI,R4    2                                                     COBOL35
         LH,R5    0,R4              PICK UP INTERNAL LABEL NUMBER       COBOL35
         STW,R5   LABL#             AND SAVE                            COBOL35
         B        RDSTAT                                                COBOL35
RDSTAT5  RES      0                                                     COBOL35
         LW,R13   DBPTR             CHANGE POINTERS TO EXTEND STACK     COBOL35
         STW,R13  ORIG%PTR                                              COBOL35
         LW,R13   DBPTRE                                                COBOL35
         STW,R13  RD%PTRE                                               COBOL35
         STW,R13  DBPTR                                                 COBOL35
         LI,R10   RDSTAT6           SET RETURN ADDRESS FOR PROCNAM      COBOL35
         STW,R10  PROC%EX                                               COBOL35
         LW,R5    R7                                                    COBOL35
         AND,R5   MSK1                                                  COBOL35
         STW,R5   CBYTE                                                 COBOL35
         BAL,R10  PROC2             PROCESS CLUSTER                     COBOL35
RDSTAT6  RES      0                                                     COBOL35
         CI,R7    X'F3'             CHECK IF WE HAVE REACHED INT LABEL  COBOL35
         BE       %+3                                                   COBOL35
         BAL,R10  RDCLUS            SKIP CLUSTER & GET NEXT             COBOL35
         B        RDSTAT6                                               COBOL35
         CI,R6    X'E8'             MAKE SURE THIS IS LABEL DEF         COBOL35
         BNE      RDSTAT5                                               COBOL35
         LW,R4    R2                POINTER TO CLUSTER                  COBOL35
         SLS,R4   -1                                                    COBOL35
         AI,R4    2                                                     COBOL35
         LH,R5    0,R4              PICK UP LABEL NUMBER                COBOL35
         BAL,R10  CMPRS             WRITE OUT CLUSTER                   COBOL35
         CW,R5    LABL#                                                 COBOL35
         BE       %+2                                                   COBOL35
         B        START             UNKNOWN CLUSTER GO TO MAIN LOGIC    COBOL35
RDSTAT7  LW,R5    ORIG%PTR          RESTORE POINTERS                    COBOL35
         STW,R5   DBPTR                                                 COBOL35
         LW,R5    RD%PTRE                                               COBOL35
         STW,R5   DBPTRE                                                COBOL35
         BAL,R10  WRT%DBSK          WRITE OUT STACK                     COBOL35
         LI,R13   0                                                     COBOL35
         STW,R13  LABL#             RESET LABEL NUMBER SAVE FIELD       COBOL35
         B        START             CONTINUE PROCESSING                 COBOL35
RDSTAT9  RES      0                                                     COBOL35
         LW,R3    R2                                                    COBOL35
         SLS,R3   -1                H.W. ADDRESS                        COBOL35
         AI,R3    3                 POINT TO REF#                       COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                SETUP REF# ( REF FLGE TABLE=0)      COBOL35
         AI,R3    2                                                     COBOL35
         LH,R8    0,R3              PICK UP L                           COBOL35
         AI,R3    1                                                     COBOL35
         LH,R5    0,R3              PICK UP M                           COBOL35
         STH,R8   R5                R5 = BASE DISPLACEMENT              COBOL35
         BAL,R10  CKDATA                                                COBOL35
         B        RDSTAT            NO DEBUG REQUIRED                   COBOL35
* SET UP MOVES FOR DATA NAME OF 'INTO' OPTION                           COBOL35
         BAL,R10  DATNAM                                                COBOL35
RDSTAT10 RES      0                                                     COBOL35
         BAL,R10  WT%CRF                                                COBOL35
         B        RDSTAT+1                                              COBOL35
DATNAM   RES      0                                                     COBOL35
         LCI      9                                                     COBOL35
         STM,R3   SAVREG                                                COBOL35
         STW,R10  DAT%EX            EXIT                                COBOL35
         BAL,R10  STK%CRF                                               COBOL35
         LW,R5    R2                                                    COBOL35
         SLS,R5   -1                                                    COBOL35
         AI,R5    8                 POINT AT P (SIZE OF ITEM)           COBOL35
         LH,R4    0,R5              SET UP FOR BUILDING SIZE CLUSTER    COBOL35
         BAL,R10  PROC2A            PUT IN STACK,NOTE SIZE2 = SIZE      COBOL35
* MOVE CLUSTER TO DBSTACK WHILE REMOVING REF# AND CHANGE TO MOVE TYPE   COBOL35
* CLUSTER AFTER DOING LINE NUMBER CLUSTERS                              COBOL35
         BAL,R10  PROC4             DO LINE NUMBER CLUSTER8             COBOL35
         BAL,R10  DBNAME            DO NAME CLUSTERS                    COBOL35
         BAL,R10  DATNAM20                                              COBOL35
         AI,R3    1                 POINT AT CTRL BYTE                  COBOL35
         LI,R4    X'DE'                                                 COBOL35
         STB,R4   0,R3              STORE MOVE CTRL BYTE                COBOL35
         AI,R3    2                 POINT AT STATEMENT OPTIONS          COBOL35
         LB,R4    0,R3                                                  COBOL35
         AND,R4   MSK1              REMOVE HIGH ORDER BIT               COBOL35
         STB,R4   0,R3                                                  COBOL35
         MTW,0    CORRFLG                                               COBOL35
         BNEZ     %+2                                                   COBOL35
         LB,R4    1,R2              SUBSCRIPT/INDEX COUNT               COBOL35
         CI,R4    X'20'                                                 COBOL35
         BGE      DATNAM3           SUBSCRIPTED ITEM                    COBOL35
*  GENERATE RFLD FOR DEBUG CONTENTS                                     COBOL35
DATNAM1  RES      0                                                     COBOL35
         LW,R5    SIZE2             PROC2A STORED SIZE HERE             COBOL35
         STW,R5   MOVE8                                                 COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP6             OFFSET FOR DEBUG-CONTENTS           COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
         B        DATNAM12          BUILD OTHER CLUSTERS (ALSO DB-SUB)  COBOL35
*  PROCESS SUBSCRIPTS THEN GO TO DATNAM1                                COBOL35
DATNAM3  RES      0                                                     COBOL35
         SLS,R4   -5                                                    COBOL35
         STW,R4   SUBCNT            SAVE SUBSCRIPT COUNT                COBOL35
         STW,R4   SUBCNT2                                               COBOL35
DATNAM4  RES      0                                                     COBOL35
         BAL,R10  RDCLUS            GET SUBSCRIPT CLUSTER               COBOL35
         BAL,R10  STK%CRF                                               COBOL35
         CI,R6    X'92'                                                 COBOL35
         BE       DATNAM6           DATA NAME SUBSCRIPT                 COBOL35
         CI,R6    X'D2'                                                 COBOL35
         BE       DATNAM5                                               COBOL35
         CI,R6    X'D3'                                                 COBOL35
         BE       DATNAM5A                                              COBOL35
*  THIS  MUST BE A NUMERIC SUBSCRIPT (R6= X'D1') OR INDEX INC X'D2'     COBOL35
*  FIRST  PUT IN DBSTACK WITH MOVE CONTROL BYTE                         COBOL35
DATNAM5  RES      0                                                     COBOL35
         LW,R13   DBPTRE                                                COBOL35
         LW,R1    R2                CLUSTER ADDRESS (B.A.)              COBOL35
         AI,R1    1                                                     COBOL35
         LI,R4    X'5E'             MOVE CONTROL BYTE                   COBOL35
         STB,R4   0,R1              STORE IN CLUSTER                    COBOL35
         LB,R12   0,R2              H.W. SIZE                           COBOL35
         SLS,R12  1                 BYTE SIZE                           COBOL35
         STB,R12  R13                                                   COBOL35
         LW,R12   R2                                                    COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
* NOW SAVE VALUE IN APPROPRIATE PLACE                                   COBOL35
         LW,R1    R2                                                    COBOL35
         SLS,R1   -1                MAKE H.A.                           COBOL35
         AI,R1    3                 POINT TO VALUE OF SUBSCRIPT         COBOL35
         LH,R4    0,R1              PICK UP VALUE (< X'270F')           CFKO335
         MTW,0    INDX%DEC                                              COBOL35
         BEZ      DATNAM5B                                              COBOL35
         MTW,-1   INDX%DEC          TURN FLAG OFF                       COBOL35
         LCW,R5   R4                                                    COBOL35
         STW,R5   R4                                                    COBOL35
DATNAM5B RES      0                                                     COBOL35
         LB,R3    SUBCNT2           =0,1,2                              COBOL35
         STW,R4   NSUB1,R3          STORE IN APPROPRIATE SAVE FIELD     COBOL35
         LW,R4    SUBCNT2                                               COBOL35
         AI,R4    -1                                                    COBOL35
         STW,R4   SUBCNT2                                               COBOL35
         CI,R4    3                                                     COBOL35
         BAZ      DATNAM1           NO MORE  SUBSCRIPTS                 COBOL35
         AI,R3    1                                                     COBOL35
         STB,R3   SUBCNT2           INCREMENT INDEX                     COBOL35
         B        DATNAM4           DO OTHERS                           COBOL35
DATNAM5A RES      0                                                     COBOL35
         MTW,1    INDX%DEC          SET DECREMENT FLAG                  COBOL35
         B        DATNAM5                                               COBOL35
DATNAM6  RES      0                                                     COBOL35
         BAL,R10  DATNAM20                                              COBOL35
         LI,R4    X'5E'                                                 COBOL35
         AI,R3    1                                                     COBOL35
         STB,R4   0,R3              STORE MOVE CONTROL BYTE             COBOL35
         LB,R3    SUBCNT2                                               C626335
         MTB,1    TYPE,R3           TURN ON APPROPRITE BYTE FLAG        COBOL35
         EXU      DATNAM7,R3                                            COBOL35
         B        DATNAM8                                               COBOL35
DATNAM7  LI,R13   BA(DSUB1)                                             COBOL35
         LI,R13   BA(DSUB2)                                             COBOL35
         LI,R13   BA(DSUB3)                                             COBOL35
DATNAM8  RES      0                                                     COBOL35
         LW,R4    R2
         AI,R4    2                 CHANGE OPT-REF TO DATA NAME         COBOL35
         LI,R12   X'90'             CHANGE OPT-REF TO DATA NAME         COBOL35
         STB,R12  0,R4              STORE IN CLUSTER                    COBOL35
         LW,R12   R2                MOVE UNCOMPRESSED CLUSTER TO HOLD   COBOL35
         LB,R4    0,R2                                                  CO26335
         SLS,R4   1                                                     COBOL35
         STB,R4   R13                                                   COBOL35
         MBS,R12  0                 MOVE CLUSTER TO SAVE AREA           COBOL35
         LW,R4    SUBCNT2                                               COBOL35
         AI,R4    -1                                                    COBOL35
         STW,R4   SUBCNT2                                               COBOL35
         CI,R4    3                                                     COBOL35
         BAZ      DATNAM1           NO MORE SUBSCRIPTS/INDEX            COBOL35
         AI,R3    1                                                     COBOL35
         STB,R3   SUBCNT2           INCREMENT INDEX                     COBOL35
         B        DATNAM4                                               COBOL35
DATNAM12 RES      0                                                     COBOL35
         MTW,0    SUBCNT            SEE IF THERE WERE ANY SUBSCRIPTS    COBOL35
         BEZ      DATNAM30          NO--DO PERFUSE AND EXIT             COBOL35
         B        DATNAM15                                              COBOL35
DATNAM13 RES      0                                                     COBOL35
         LI,R4    2                                                     COBOL35
DATNAM14 LW,R14   NSUB1,R3          CONVERT NUMBER TO PACKED            COBOL35
         LI,R12   0                                                     COBOL35
         STW,R12  R13               CLEAR DECA                          COBOL35
         CVS,R14  CVRTBL              DECIMAL                           COBOL35
         OR,R15   =X'C'             PUT SIGN IN                         COBOL35
         DST,3    MOVNUM1,R4                                            COBOL35
         LI,R12   BA(MOVNUM)                                            COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT10                                               COBOL35
         MBS,R12  0                 MOVE SFLD                           COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP3,R3                                              COBOL35
         STW,R5   MOVSUB1                                               COBOL35
         LI,R12   BA(MOVSUB)        MOVE RFLD TO STACK                  COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
         AI,R3    -1                SUBTRACT 1 FROM INDEX               COBOL35
         CI,R3    -1                                                    COBOL35
         BLE      DATNAM30          FINISH ROUTINE                      COBOL35
         B        DATEXU                                                COBOL35
DATNAM15 RES      0                                                     COBOL35
*  R5 IS B.A. OF CLUSTER IN HOLD AREA                                   COBOL35
*  R3 IS INDEX FOR SUBSCRIPT/INDEX IN HOLD AREA                         COBOL35
         LB,R3    SUBCNT2           LOAD INDEX (SHOULD BE REVERSE ORDER)COBOL35
DATEXU   RES      0                                                     COBOL35
         MTB,0    TYPE,R3                                               COBOL35
         BEZ      DATNAM13          NUMERIC--GO TO PROCESS              COBOL35
         EXU      DAT%JMP,R3                                            COBOL35
         B        DATNAM16                                              COBOL35
DAT%JMP  RES      0                                                     COBOL35
         LI,R5    BA(DSUB1)                                             COBOL35
         LI,R5    BA(DSUB2)                                             COBOL35
         LI,R5    BA(DSUB3)                                             COBOL35
DATNAM16 RES      0                                                     COBOL35
         LW,R1    R5                                                    COBOL35
         AI,R1    8                 POINT AT FIELDS H,I                 COBOL35
         LB,R4    0,R1              LOAD                                COBOL35
         AND,R4   MSK2                                                  COBOL35
         CI,R4    X'0C'                                                 COBOL35
         BE       DAT%INX           INDEX DATA NAME                     COBOL35
         LW,R4    R5                CLUSTER ADDRESS                     COBOL35
         AI,R4    1                 POINT AT CONTROL BYTE               COBOL35
         LI,R8    X'DE'                                                 COBOL35
         STB,R8   0,R4              CHANGE CONTROL BYTE TO MOVE         COBOL35
         LW,R2    R5                SET CLUSTER ADDRESS FOR DATNAM20    COBOL35
         STW,R3   SAV3                                                  COBOL35
         BAL,R10  DATNAM20          MOVE SFLD TO STACK                  COBOL35
         LW,R3    SAV3                                                  COBOL35
*  DO RFLD FOR SUBSCRIPT                                                COBOL35
         LW,R9    PDBDBG                                                COBOL35
         AW,R9    DISP3,R3                                              COBOL35
         STW,R9   MOVSUB1           SET BASE DISPLACEMENT               COBOL35
         LI,R12   BA(MOVSUB)                                            COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 MOVE RFLD TO STACK                  COBOL35
         STW,R13  DBPTRE                                                COBOL35
*  NOTE  IT IS INCORRECT TO HAVE AN INCREMENT/DECREMENT WHEN            COBOL35
*  USING SUBSCRIPTS, HOWEVER TO BE CONSISTENT WITH COMPILER WHICH       COBOL35
*  NOW HANDLES IT PROPERLY, THE FOLLOWING BRANCH IS TAKEN               COBOL35
         B        INXADDS                                               COBOL35
DAT%INX  RES      0                                                     COBOL35
*  INDEX NAMES ARE PROCESSED HERE BY DOING SET STATEMENTS               COBOL35
         LW,R9    PDBDBG                                                COBOL35
         AW,R9    DISP3,R3                                              COBOL35
         STW,R9   SET1              STORE BASE DISPLACEMENT             COBOL35
         LI,R12   BA(SET)                                               COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 MOVE RFLD FOR SET                   COBOL35
         STW,R13  DBPTRE            UPDATE POINTER                      COBOL35
         LI,R8    X'67'             CHANGE CONTROL BYTE                 COBOL35
         LW,R4    R5                                                    COBOL35
         AI,R4    1                                                     COBOL35
         STB,R8   0,R4                                                  COBOL35
         LW,R2    R5                                                    COBOL35
         STW,R3   SAV3                                                  COBOL35
         BAL,R10  DATNAM20          PUT SFLD IN STACK                   COBOL35
         AI,R3    3
         LI,R8    X'81'             CHG ST OPT TO LAST OPRND & 'TO'
         STB,R8   0,R3
         LW,R3    SAV3                                                  COBOL35
INXADDS  RES      0                                                     COBOL35
         MTW,0    NSUB1,R3          SEE IF NUMERIC INC/DEC FIELDS       COBOL35
         BNEZ     INXADD1           ARE PRESENT                         COBOL35
         B        INXADD2           NONE FOR THIS ITEM, CHECK IF FINISH COBOL35
INXADD1  RES      0                                                     COBOL35
         LW,R8    NSUB1,R3          LEAVE NUMBER IN BINARY FORMAT       COBOL35
         STW,R8   ADD1                                                  COBOL35
         LI,R12   BA(ADD)                                               COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT10                                               COBOL35
         MBS,R12  0                 PUT IN STACK                        COBOL35
         LW,R9    PDBDBG                                                COBOL35
         AW,R9    DISP3,R3                                              COBOL35
         STW,R9   ADD2                                                  COBOL35
         LI,R12   BA(ADDRFLD)                                           COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 PUT RFLD FOR ADD IN STACK           COBOL35
         STW,R13  DBPTRE                                                COBOL35
INXADD2  RES      0                                                     COBOL35
         AI,R3    -1                DECREMENT INDEX                     COBOL35
         CI,R3    -1                HAVE WE FINISHED                    COBOL35
         BLE      DATNAM30          YES                                 COBOL35
         B        DATEXU            RETURN FOR NEXT ITEM                COBOL35
DATNAM30 RES      0                                                     COBOL35
         BAL,R10  PERFUSE           PERFORM DECLARATIVE SECTION         COBOL35
         MTW,0    TYPE              SEE IF THERE WERE ANY DATA-NAME SUBSCOBOL35
         BEZ      DATNAM34                                              COBOL35
         LI,R3    2                                                     COBOL35
DATLOP   RES      0                                                     COBOL35
         LB,R1    TYPE,R3           FIND OUT WHICH SUBSCRIPT WAS A      COBOL35
         BNEZ     DATFND                DATA ITEM                       COBOL35
         AI,R3    -1                                                    COBOL35
         BGEZ     DATLOP            NOT FOUND YET                       COBOL35
         B        DATNAM34          NONE EXIST                          COBOL35
DATFND   RES      0                 R3 = INDEX OF ITEM FOUND            COBOL35
         LI,R10   DATNAM37                                              COBOL35
         STW,R10  DATSET                                                COBOL35
DATNAM31 EXU      DAT%JMP,R3                                            COBOL35
         LW,R2    R5                                                    COBOL35
         LW,R1    R5                                                    COBOL35
         SLS,R1   -1                                                    COBOL35
         AI,R1    3                                                     COBOL35
         LH,R4    0,R1              LOAD REF #                          COBOL35
         SLS,R4   16                SETUP REF# (REF FLAG, TABLE = 0)    COBOL35
         AI,R1    2                                                     COBOL35
         LH,R8    0,R1                                                  COBOL35
         AI,R1    1                                                     COBOL35
         LH,R5    0,R1                                                  COBOL35
         STH,R8   R5                                                    COBOL35
         STW,R3   SAV3                                                  COBOL35
         BAL,R10  CKDATA            SEE IF THIS IS A DEBUG ITEM         COBOL35
         B        DATNAM32          NO                                  COBOL35
         B        DATNAM33                                              COBOL35
DATNAM32 RES      0                                                     COBOL35
         LW,R3    SAV3              RESTORE REG 3                       COBOL35
         AI,R3    -1                                                    COBOL35
         CI,R3    -1                                                    COBOL35
         BLE      DATNAM34          EXIT                                COBOL35
         LB,R1    TYPE,R3           SEE IF NEXT ITEM IS DATA SUBSCRIPT  COBOL35
         BNEZ     DATNAM31          YES                                 COBOL35
         B        DATNAM32+1        CHECK NEXT ITEM                     COBOL35
DATNAM33 RES      0                                                     COBOL35
         LW,R1    R2                                                    COBOL35
         SLS,R1   -1                                                    COBOL35
         AI,R1    8                                                     COBOL35
         LH,R4    0,R1              P FIELD (SIZE OF ITEM)              COBOL35
         BAL,R10  PROC2A            PUT SIZE CLUSTERS IN STACK          COBOL35
         BAL,R10  PROC4             PUT LINE CLUSTERS IN STACK          COBOL35
         BAL,R10  DBNAME            DO NAME CLUSTERS                    COBOL35
         LW,R1    R2                                                    COBOL35
         AI,R1    8                                                     COBOL35
         LB,R4    0,R1              FIELDS  H,I                         COBOL35
         CI,R4    X'CC'             COMPILER GENERATED                  COBOL35
         BE       DATNAM35          INDEX ITEM                          COBOL35
         AI,R1    -7                                                    COBOL35
         LI,R8    X'DE'                                                 COBOL35
         STB,R8   0,R1              CHG CTRL TO MOVE                    COBOL35
         BAL,R10  DATNAM20                                              COBOL35
         LW,R9    PDBDBG            DO RFLD FOR DEBUG-CONTENTS          COBOL35
         AW,R9    DISP6                                                 COBOL35
         STW,R9   MOVE7                                                 COBOL35
         LW,R9    SIZE2                                                 COBOL35
         STW,R9   MOVE8                                                 COBOL35
         LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT20                                               COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
         B        DATNAM36                                              COBOL35
DATNAM35 RES      0                                                     COBOL35
*   MOVE 'COMPILER GENERATED INDEX' TO DB-CONTENTS                      COBOL35
         LW,R4    MOVE3             SET UP SFLD                         COBOL35
         STW,R4   DBBUILD                                               COBOL35
         LI,R13   BA(DBBUILD+1)                                         COBOL35
         OR,R13   COUNT25                                               COBOL35
         LI,R12   BA(COMPIL)                                            COBOL35
         MBS,R12  0                                                     COBOL35
         LI,R12   15                H.W. SIZE OF SFLD                   COBOL35
         STB,R12  DBBUILD                                               COBOL35
         SLS,R12  1                                                     COBOL35
         LW,R13   DBPTRE                                                COBOL35
         STB,R12  R13                                                   COBOL35
         LI,R12   BA(DBBUILD)                                           COBOL35
         MBS,R12  0                                                     COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP6             DISPLACEMENT FOR DB-CONTENTS        COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LI,R5    24                                                    COBOL35
         STW,R5   MOVE8                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
DATNAM36 RES      0                                                     COBOL35
         B        *DATSET           RETURN / FALL THRU                  COBOL35
DATNAM37 RES      0                                                     COBOL35
         BAL,R10  PERFUSE                                               COBOL35
         LW,R3    SAV3                                                  COBOL35
         AI,R3    -1                                                    COBOL35
         CI,R3    -1                                                    COBOL35
         BLE      DATNAM34                                              COBOL35
         B        DATLOP
DATNAM34 RES      0                                                     COBOL35
         LI,R3    0                 CLEAR FIELDS FOR NEXT TIME          COBOL35
         STW,R3   TYPE                                                  COBOL35
         STW,R3   NSUB1                                                 COBOL35
         STW,R3   NSUB2                                                 COBOL35
         STW,R3   NSUB3                                                 COBOL35
         STW,R3   SUBCNT                                                COBOL35
         STW,R3   SUBCNT2                                               COBOL35
         LCI      9                                                     COBOL35
         LM,R3    SAVREG                                                COBOL35
         B        *DAT%EX           RETURN                              COBOL35
DBNAME   RES      0                                                     COBOL35
*  PUT DEBUG NAME IN STACK                                              COBOL35
         LW,R5    T:ENTRY                                               COBOL35
         AI,R5    2                 POINT AT FLD E  (POINTER TO NAME)   COBOL35
         LW,R12   *R5                                                   COBOL35
DBNAME1  RES      0                                                     COBOL35
         LW,R4    MOVE3                                                 COBOL35
         STW,R4   DBBUILD                                               COBOL35
         LI,R13   BA(DBBUILD+1)                                         COBOL35
         LW,R1    R12                                                   COBOL35
         LB,R4    0,R1                                                  COBOL35
         AI,R4     1                                                    COBOL35
         STB,R4   R13                                                   COBOL35
         MBS,R12  0                                                     COBOL35
         SLS,R4   -1                                                    COBOL35
         AI,R4     3                   H.W. SIZE +3
         STB,R4   DBBUILD                                               COBOL35
         LW,R13   DBPTRE                                                COBOL35
         LI,R12   BA(DBBUILD)                                           COBOL35
         SLS,R4   1                                                     COBOL35
         STB,R4   R13                                                   COBOL35
         MBS,R12  0                 PUT SFLD IN STACK                   COBOL35
         LW,R5    PDBDBG            PUT RFLD FOR NAME IN STACK          COBOL35
         AW,R5    DISP2                                                 COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LW,R5    MOVE10                                                COBOL35
         STW,R5   MOVE8                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                                                     COBOL35
         STW,R13  DBPTRE                                                COBOL35
         B        *R10                                                  COBOL35
DATNAM20 LW,R13   DBPTRE                                                COBOL35
         OR,R13   COUNT6            MOVE FIELDS A--E                    COBOL35
         LW,R12   R2                SOURCE ADDRESS                      COBOL35
         MBS,R12  0                 MOVE                                COBOL35
         AI,R12   2                 SKIP REF #                          COBOL35
         LB,R1    0,R2              ADJUST SIZE OF CLUSTER              COBOL35
         SLS,R1   1                                                     COBOL35
         AI,R1    -8                NO OF BYTES -2(REF#) -6(FLDS A-E)   COBOL35
         STB,R1   R13               STORE FOR MOVING REST OF CLUSTER    COBOL35
         MBS,R12  0                                                     COBOL35
         AI,R1    6                 ADD 6 FOR ACTUAL CLUSTER SIZE       COBOL35
         SLS,R1   -1                CHANGE SIZE TO HALFWORDS            COBOL35
         LW,R3    DBPTRE            STORE IN CLUSTER                    COBOL35
         STB,R1   0,R3                                                  COBOL35
         LW,R4    DBPTRE            SAVE POINTER
         LW,R1    DBPTR
         AI,R1    3
         LB,R12   0,R1
         AND,R12  =X'F0'
         STB,R12  0,R1              CLEAR ST OPT (SAVE SUBSCRIPT)
         STW,R13  DBPTRE            UPDATE POINTER                      COBOL35
         SLS,R4   -1                H.W.  ADDRESS
         AI,R4    3                 FLDS H-J
         LH,R1    0,R4
         AND,R1   =X'0F00'          I  FIELD
         CI,R1    X'0600'
         BL       *R10              NOT NUMERIC
         CI,R1    X'0A00'
         BGE      *R10
         LH,R1    0,R4
         AND,R1   =X'3'
         AI,R4    5                 POINT AT Q/EDITING
         AW,R4    R1
         LI,R12   0
         STH,R12  0,R4              CLEAR DECIMAL POINTS
         B        *R10                                                  COBOL35
DB%DATA  RES      0
*  CHECK  DATA REF FOR VALID DEBUG ITEM
*  R9 CONTAINS REF FLAG AND TABLE TYPE
         STW,R10  DATAOT
         LW,R3    R2
         SLS,R3   -1                H.A. OF CLUSTER
         AI,R3    3                 POINT AT REF#
         LH,R4    0,R3
         SLS,R4   16                SETUP REF# (WITH TABLE# AND FLAG)
         OR,R4    R9
         AI,R3    2
         LH,R8    0,R3              PICK UP L (BASE#)
         AI,R3    1
         LH,R5    0,R3              PICK UP M (DISP)
         STH,R8   R5
         BAL,R10  CKDATA            CHECK FOR DEBUG
         MTW,1    DATAOT            NO DEBUG--RETURN TO RETURN+1
         B        *DATAOT           RETURN
WRITE    RES      0
         LW,R9    DATACNT1
         BAL,R10  DB%DATA           SEE IF THIS IS A DEBUG ITEM
         B        %+2               VALID RETURN
         B        WRITE2            INVALID RETURN
         BAL,R10  DATNAM            PROCESS
WRITE1   RES      0
         BAL,R10  RDCLUS                                                COBOL35
         CI,R7    X'6D'                                                 COBOL35
         BNE      WRITE3            FINISHED WITH WRITE CLUSTERS        COBOL35
         CI,R6    X'90'             SEE IF THIS IS A 'WRITE X FROM'     COBOL35
         BE       WRITE             YES--SEE IF IT IS A DEBUG ITEM      COBOL35
WRITE2   RES      0                                                     COBOL35
*  NOTE  INVALID KEY CLUSTERS WILL COME HERE ALSO                       COBOL35
         BAL,R10  STK%CRF           SAVE CLUSTER IN STACK AND CONTINUE  COBOL35
         B        WRITE1                                                COBOL35
WRITE3   RES      0                                                     COBOL35
         BAL,R10  WRT%DBSK                                              COBOL35
         BAL,R10  WT%CRF                                                COBOL35
         B        SETUP                                                 COBOL35
OPN%CLS  RES      0                                                     COBOL35
         LI,R10   OPNRTN                                                COBOL35
         STW,R10  RDEX                                                  COBOL35
         LI,R10   OPNRTN2           RETURN FOR NO DEBUG ITEM            COBOL35
         STW,R10  RDNOT                                                 COBOL35
         BAL,R10  RD%WRT1           DO ALL NECESSARY MOVES OR DONOTHNG  COBOL35
OPNRTN   RES      0                                                     COBOL35
         BAL,R10  PERFUSE                                               COBOL35
OPNRTN2  RES      0                                                     COBOL35
         BAL,R10  CMPRS             WRITE OUT OPEN/CLOSE CLUSTER        COBOL35
         LW,R4    R7                CTRL BYTE                           COBOL35
         AND,R4   MSK1              REMOVE HIGH ORDER BIT               COBOL35
         STW,R4   CBYTE             SAVE                                COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER                    COBOL35
         CW,R7    CBYTE             SEE IF ANOTHER OPEN/CLOSE           COBOL35
         BE       OPN%CLS           YES-SEE IF DEBUG ITEM               COBOL35
         BAL,R10  WRT%DBSK          WRITE OUT STACK                     COBOL35
         B        SETUP             PROCESS CLUSTER                     COBOL35
CORR     RES      0                                                     COBOL35
         MTW,1    CORRFLG           TURN ON CORR FLG                    COBOL35
         CI,R7    X'80'                                                 COBOL35
         BAZ      CORR1             NOT FIRST CLUSTER, MUST BE RFLD     COBOL35
         LW,R9    DATACNT2                                              COBOL35
         BAL,R10  DB%DATA           SEE IF DEBUG ITEM                   COBOL35
         B        CORR2             VALID                               COBOL35
         B        CORR3             INVALID--COMPRESS AND WRITE         COBOL35
CORR1    RES      0                                                     COBOL35
         LW,R9    DATACNT1                                              COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        CORR2             VALID                               COBOL35
         B        CORR3             INVALID                             COBOL35
CORR2    RES      0                                                     COBOL35
         BAL,R10  DATNAM                                                COBOL35
         MTW,-1   CORRFLG           RESET FLG                           COBOL35
         CI,R7    X'80'                                                 COBOL35
         BANZ     START             GET NEXT CLUSTER FOR STATEMENT      COBOL35
         BAL,R10  WT%CRF            WRITE STACK (CORR CLUSTERS)         COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG STACK                   COBOL35
         B        START             CONTINUE PROCESSING                 COBOL35
CORR3    RES      0                                                     COBOL35
         BAL,R10  CMPRS             BYPASS CLUSTER                      COBOL35
         MTW,-1   CORRFLG           RESET FLG
         B        START             CONTINUE                            COBOL35
ARITH    RES      0                                                     COBOL35
         CI,R6    X'C0'             CHECK FOR NUMERIC LITERALS          COBOL35
         BGE      ARITH4            NO NEED TO CHECK FOR DEBUG          COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    3                                                     COBOL35
         LB,R8    0,R3              PICH UP STATEMENT OPTIONS           COBOL35
         AND,R8   MSK1                                                  COBOL35
         CI,R8    X'03'             TO, INTO, BY, OR FROM OPTION        COBOL35
         BANZ     ARITH2                                                COBOL35
         CI,R8    X'10'             REMAINDER OPTION                    COBOL35
         BE       ARITH2                                                COBOL35
         MTW,0    ARTSW             FOR MULTIPLE RFLD
         BGZ      ARITH2
         LW,R9    DATACNT2          USE ALL REF FLAG                    COBOL35
         B        %+2                                                   COBOL35
ARITH2   RES      0                                                     COBOL35
         MTW,1    ARTSW             SET MULT  F RFLD SWITCH
         LW,R9    DATACNT1          USE NOT ALL REF FLAG                COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        %+2               VALID                               COBOL35
         B        ARITH4            INVALID--STACK THEN READ CLUSTER    COBOL35
         BAL,R10  DATNAM                                                COBOL35
ARITH3   RES      0                                                     COBOL35
         BAL,R10  RDCLUS                                                COBOL35
         CI,R7    X'80'             SEE IF NEW STATEMENT                COBOL35
         BANZ     %+2               YES--WRITE OUT STACK                COBOL35
         B        ARITH
         BAL,R10  WT%CRF            WRITE CRF OUT FIRST                 COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG CRFS OUT                COBOL35
         LI,R1    0
         STW,R1   ARTSW             RESET SWITCH
         B        SETUP                                                 COBOL35
ARITH4   RES      0                                                     COBOL35
         BAL,R10  STK%CRF           PUT IN STACK                        COBOL35
         B        ARITH3            GET NEXT CLUSTER                    COBOL35
ACPT     RES      0                                                     COBOL35
         LW,R9    DATACNT1          (NOT ALL REF)                       COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        %+2               VALID                               COBOL35
         B        DONOTHNG          INVALID                             COBOL35
         BAL,R10  DATNAM            PROCESS ITEM                        COBOL35
         BAL,R10  WT%CRF            WRITE OUT ORIG CLUSTER              COBOL35
         BAL,R10  WRT%DBSK          WRITE STACK                         COBOL35
         B        START             RETURN                              COBOL35
DISP     RES      0                                                     COBOL35
*  MUST CHECK TO SEE IF ITEM IS A DATA NAME--ALL OTHERS ARE PASSED      COBOL35
         CI,R6    X'90'                                                 COBOL35
         BNE      DISP11            NOT DATA NAME, STACK & READ         COBOL35
         LW,R3    R2
         AI,R3    3
         LB,R8    0,R3              PICK UP STM OPT
         CI,R8    X'44'             ALLOW FOR STRING/ UNSTRING  OPTS
         BANZ     DISP9             USE  NOT ALL
         CI,R8    X'20'             INSPECT
         BE       DISP9
         LW,R9    DATACNT2          ALL REF                             COBOL35
         B        %+2
DISP9    RES      0
         LW,R9    DATACNT1          USE NOT ALL
         BAL,R10  DB%DATA                                               COBOL35
         B        DISP13            VALID                               COBOL35
DISP11   RES      0                 INVALID--STACK & READ               COBOL35
         BAL,R10  STK%CRF                                               COBOL35
         B        DISP15                                                COBOL35
DISP13   RES      0                                                     COBOL35
         BAL,R10  DATNAM                                                COBOL35
DISP15   RES      0                                                     COBOL35
         BAL,R10  RDCLUS                                                COBOL35
         CI,R7    X'80'             SEE IF NEXT STATEMENT               3FKO335
         BANZ     %+2                                                   COBOL35
         B        DISP                                                  COBOL35
         MTW,0    IFFLG             SEE IF THIS IS A CONDITIONAL        COBOL35
         BEZ      DISP16                                                C626335
         BAL,R10  WRT%DBSK          WRITE DEBUG CLUSTERS                COBOL35
         BAL,R10  WT%CRF            WRITE CONDITIONAL CLUSTERS          COBOL35
         LI,R3    0                                                     COBOL35
         STW,R3   IFFLG             RESET FLAG                          COBOL35
         B        SETUP             CONTINUE                            COBOL35
DISP16   RES      0                                                     CFK6335
         BAL,R10  WT%CRF                                                COBOL35
         BAL,R10  WRT%DBSK                                              COBOL35
         B        SETUP             RETURN                              COBOL35
COMP     RES      0                                                     COBOL35
         CI,R6    X'90'                                                 COBOL35
         BE       COMP1                                                 COBOL35
         CI,R6    X'20'             EQUAL SIGN                          COBOL35
         BE       %+2                                                   COBOL35
         B        %+2                                                   COBOL35
         STW,R6   COMPSGN                                               COBOL35
         BAL,R10  STK%CRF           STACK CLUSTER AND CONTINUE          COBOL35
         B        COMP5                                                 COBOL35
COMP1    RES      0                                                     COBOL35
         MTW,0    COMPSGN                                               COBOL35
         BEZ      COMP2                                                 COBOL35
         LW,R9    DATACNT2          USE ALL REF BECAUSE = SIGN PASSED   COBOL35
         B        %+2                                                   COBOL35
COMP2    RES      0                                                     COBOL35
         LW,R9    DATACNT1          USE NOT ALL REF                     COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        COMP3             VALID                               COBOL35
         BAL,R10  STK%CRF           INVALID--STACK THEN READ            COBOL35
         B        COMP5                                                 COBOL35
COMP3    RES      0                                                     COBOL35
         BAL,R10  DATNAM            PROCESS                             COBOL35
COMP5    RES      0                                                     COBOL35
         BAL,R10  RDCLUS            READ NEXT CLUSTER                   COBOL35
         CI,R7    X'80'                                                 COBOL35
         BANZ     %+2                                                   COBOL35
         B        COMP                                                  COBOL35
         BAL,R10  WT%CRF                                                COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG CLUSTERS                COBOL35
         LI,R9    0                                                     COBOL35
         STW,R9   COMPSGN           CLEAR OPERATOR FLAG                 COBOL35
         B        SETUP                                                 COBOL35
SETT     RES      0                                                     COBOL35
         BAL,R10  STK%CRF           SAVE CLUSTER                        COBOL35
         CI,R6    X'90'             IF NOT DATA NAME BYPASS             COBOL35
         BNE      SETT3                                                 COBOL35
         LW,R5    R2                                                    COBOL35
         AI,R5    3                                                     COBOL35
         LB,R4    0,R5              LOOK AT STATEMENT OPTION            COBOL35
         CI,R4    0                                                     COBOL35
         BE       SETT1             RFLD FOR SET                        COBOL35
         LW,R9    DATACNT2          ALL REF FLAG                        COBOL35
         B        %+2                                                   COBOL35
SETT1    RES      0                                                     COBOL35
         LW,R9    DATACNT1          USE NOT ALL REF FLAG                COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        %+2               VALID                               COBOL35
         B        SETT3             INVALID                             COBOL35
*  SET UP LINKAGE FOR PROCESSING ITEM AT DATWAM33                       COBOL35
         LI,R10   SETT2                                                 COBOL35
         STW,R10  DATSET            SET RETURN ADDRESS                  COBOL35
         BAL,R10  DATNAM33                                              COBOL35
SETT2    RES      0                                                     COBOL35
         BAL,R10  PERFUSE           WRITE 'USE' LINKAGE                 COBOL35
SETT3    RES      0                                                     COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER                    COBOL35
         CI,R7    X'80'                                                 COBOL35
         BANZ     %+2               IS IT A NEW STATEMENT               COBOL35
         B        SETT              NO                                  COBOL35
         BAL,R10  WT%CRF            WRITE CRF STACK                     COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG STACK                   COBOL35
         B        SETUP             RETURN                              COBOL35
ENT      RES      0                                                     COBOL35
         CI,R6    X'90'                                                 COBOL35
         BE       ENT2              DATA NAME                           COBOL35
         CI,R6    X'93'                                                 COBOL35
         BE       ENT3              FILE NAME                           COBOL35
         CI,R6    X'94'                                                 COBOL35
         BE       ENT4              SECTION NAME                        COBOL35
         CI,R6    X'96'                                                 COBOL35
         BE       ENT4              PARAMETER NAME                      COBOL35
ENT1     RES      0                                                     COBOL35
         BAL,R10  STK%CRF           SAVE CLUSTER                        COBOL35
ENTRD    BAL,R10  RDCLUS                                                COBOL35
         CI,R7    X'80'                                                 COBOL35
         BANZ     ENT6              EXIT ROUTINE                        COBOL35
         CI,R6    X'9B'             SEE IF THIS IS A NAME CLUSTER       COBOL35
         BE       ENTRD             YES---BYPASS                        COBOL35
         B        ENT                                                   COBOL35
ENT2     RES      0                                                     COBOL35
         LW,R9    DATACNT1                                              COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        %+2               VALID                               COBOL35
         B        ENT1              INVALID                             COBOL35
         BAL,R10  DATNAM                                                COBOL35
         B        ENTRD                                                 COBOL35
ENT3     RES      0                                                     COBOL35
         LI,R10   ENT7              RETURN FOR DEBUG FILE CLUSTER       COBOL35
         STW,R10  RDEX                                                  COBOL35
         LI,R10   ENT1                                                  COBOL35
         STW,R10  RDNOT             SETUP RETURN FOR NOT DEBUG CLUSTER  COBOL35
         BAL,R10  RD%WRT1           CHECK AND PROCESS CLUSTER           COBOL35
         B        ENT1              (CONTROL SHOULD NOT RETURN HERE)    COBOL35
ENT4     RES      0                                                     COBOL35
         LW,R3    CBYTE2
         CI,R3    X'5B'
         BE       ENT5              ALWAYS DEBUG GO TO STATEMENTS
         LW,R3    R2                                                    COBOL35
         AI,R3    5                                                     COBOL35
         LB,R5    0,R3              PRIORITY NUMBER                     COBOL35
         AI,R3    1                                                     COBOL35
         SLS,R3   -1                                                    COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                                                    COBOL35
         OR,R4    PROCNT                                                COBOL35
         BAL,R10  CKPROC            CHECK IF VALID DEBUG                COBOL35
         B        ENT1              INVALID REFERENCE
ENT5     RES      0
         LW,R10   CBYTE2
         STW,R10  CBYTE             SET CBYTE FOR PROCNAM
         LI,R10   ENTRD             SET UP RETURN                       COBOL35
         STW,R10  PROC%EX
         B        ENT%PROC          GO TO PROCNAM (SECONDARY ENTRY)
ENT6     RES      0                                                     COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG CLUSTERS                COBOL35
         BAL,R10  WT%CRF            WRITE CRF ENTER CLUSTERS            COBOL35
         B        SETUP                                                 COBOL35
ENT7     RES      0
         BAL,R10  PERFUSE
         B        ENT1
ALTR     RES      0                                                     COBOL35
*        PROCESS ALTER IN GROUPS OF FOUR                                COBOL35
*        1ST CLUSTER IS 'TO PROCEED TO'                                 COBOL35
*        2ND CLUSTER IS 'ALTER'                                         COBOL35
*        3RD CLUSTER IS 'ALTER'PROCEDURE-NAME                           COBOL35
*        4TH CLUSTER IS 'TO PROCEED TO'  PROCEDURE-NAME                 COBOL35
         LI,R3    0                                                     COBOL35
ALTR1    RES      0                                                     COBOL35
         EXU      ALTR2,R3          PICK UP DEST FLD ADDRESS            COBOL35
         CI,R6    X'9B'             SEE IF STRING                       COBOL35
         BNE       ALTR1A                                               COBOL35
         AI,R2    6                 MOVE STRING AND COUNT ONLY          C626335
         LW,R12    R2                                                   COBOL35
         LB,R4     0,R2                                                 COBOL35
         AI,R4     1                   MOVE STRING AND COUNT            COBOL35
         STB,R4    R13                                                  COBOL35
         B         ALTR1B                                               COBOL35
ALTR1A   RES       0                                                    COBOL35
         LW,R12   R2                                                    COBOL35
         LB,R4    0,R2                                                  COBOL35
         SLS,R4   1                 SIZE OF CLUSTER IN BYTES            COBOL35
         STB,R4   R13                                                   COBOL35
ALTR1B   RES       0                                                    COBOL35
         MBS,R12  0                 MOVE CLUSTER TO SAVE AREA           COBOL35
         B        ALTR3                                                 COBOL35
ALTR2    RES      0                                                     COBOL35
         LI,R13   BA(ALTCLS1)                                           COBOL35
         LI,R13   BA(ALTCLS2)                                           COBOL35
         LI,R13   BA(ALTNAM1)                                           COBOL35
         LI,R13   BA(ALTNAM2)                                           COBOL35
ALTR3    RES      0                                                     COBOL35
         AI,R3    1                                                     COBOL35
         CI,R3    4                                                     COBOL35
         BE       ALTR4                                                 COBOL35
         BAL,R10  RDCLUS                                                COBOL35
         B        ALTR1                                                 COBOL35
ALTR4    RES      0                                                     COBOL35
         LI,R2    BA(ALTCLS1)                                           COBOL35
ALTR5    RES      0                                                     COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    5                                                     COBOL35
         LB,R5    0,R3              PRIORITY NUMBER                     COBOL35
         AI,R3    1                                                     COBOL35
         SLS,R3   -1                HALFWORD ADDRESS                    COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                                                    COBOL35
         OR,R4    PROCNT                                                COBOL35
         BAL,R10  CKPROC            CHECK IF DEBUG                      COBOL35
         B        ALTR6             NOT DEBUG                           COBOL35
         LW,R10   CBYTE2
         STW,R10  CBYTE             SET CBYTE FOR PROCNAM
         LI,R10   ALTR8             RETURN ADDRESS FOR PROCNAM          COBOL35
         STW,R10  PROC%EX                                               COBOL35
         B        ENT%PROC                                              COBOL35
ALTR6    RES      0                                                     COBOL35
         BAL,R10  STK%CRF           SAVE CLUSTER                        COBOL35
ALTR7    RES      0                                                     COBOL35
         LW,R3    ALTFLG                                                COBOL35
         AI,R3    1                                                     COBOL35
         CI,R3    2                 HAVE BOTH CLUSTERS BEEN EXAMINED    COBOL35
         BE       ALTR9             WRITE CLUSTERS AND GO TO READ       COBOL35
         STW,R3   ALTFLG                                                COBOL35
         LI,R2    BA(ALTCLS2)                                           COBOL35
         B        ALTR5             CHECK FOR DEBUG                     COBOL35
ALTR8    RES      0                                                     COBOL35
         MTW,0    ALTFLG                                                COBOL35
         BEZ      %+3                                                   COBOL35
         LI,R12   BA(ALTNAM1)       NOW PROCESSING THE 'ALTER' CLUSTER  COBOL35
         B        %+2                                                   COBOL35
         LI,R12   BA(ALTNAM2)       'TO PROCEED TO' NAME                COBOL35
         BAL,R10  DBNAME1           BUILD NAME CLUSTER                  COBOL35
*  IT IS NOW NECESSARY TO GENERATE THE DB-NAME, DB-CONTENTS, AND        COBOL35
*  PERFORM DECLARATIVE CODE                                             COBOL35
*  BUILD DEBUG-CONTENT CLUSTERS                                         COBOL35
         LI,R12    BA(ALTNAM2)                                          COBOL35
         BAL,R10   DBNAME1             BUILD SFLD FOR DB-CONTENTS       COBOL35
         LW,R5    PDBDBG                                                COBOL35
         AW,R5    DISP6             DISPLACEMENT FOR DB-CONTENTS RFLD   COBOL35
         STW,R5   MOVE7                                                 COBOL35
         LW,R5    MOVE10            SIZE OF CONTENTS = MAX NAME SIZE    COBOL35
         STW,R5   MOVE8                                                 COBOL35
         LI,R12   BA(MOVE5)                                             COBOL35
         OR,R13   COUNT20                                               COBOL35
         MBS,R12  0                 MOVE RFLD TO STACK                  COBOL35
         STW,R13  DBPTRE                                                COBOL35
         BAL,R10  PERFUSE           WRITE PERFORM DECLARATIVE SECTION   COBOL35
         LW,R3    ALTFLG                                                COBOL35
         AI,R3    1                                                     COBOL35
         CI,R3    2                                                     COBOL35
         BE       ALTR9             FINISHED                            COBOL35
         STW,R3   ALTFLG                                                COBOL35
         LI,R2    BA(ALTCLS2)       DO SECOND CLUSTER                   COBOL35
         B        ALTR5                                                 COBOL35
ALTR9    RES      0                                                     COBOL35
         BAL,R10  WT%CRF            WRITE ALTER CLUSTERS                COBOL35
         BAL,R10  WRT%DBSK          WRITE DEBUG CLUSTERS                COBOL35
         LI,R3    0                                                     COBOL35
         STW,R3   ALTFLG            RESET FLAG                          COBOL35
         B        START             CONTINUE PROCESSING                 COBOL35
IFF      RES      0                                                     COBOL35
*  ONLY DATA NAMES ARE DEBUGGED                                         COBOL35
*  DEBUG STAMENTS ARE WRITTEN OUT IN FRONT OF IF CLUSTERS               COBOL35
*  THIS IS ACCOMPLISHED BY SETTING IFFLG AND USING THE CODE AT DISP     COBOL35
         MTW,1    IFFLG             SET IF FLAG                         COBOL35
         B        DISP              AND GO TO DISP                      COBOL35
PERF     RES      0                                                     COBOL35
         CI,R6    X'90'                                                 COBOL35
         BE       PERF2             DATA NAME                           COBOL35
         CI,R6    X'96'                                                 COBOL35
         BE       PERF4             PARAGRAPH NAME                      COBOL35
         CI,R6    X'94'                                                 COBOL35
         BE       PERF4             SECTION NAME                        COBOL35
PERF1    RES      0                                                     COBOL35
         BAL,R10  STK%CRF           SAVE CLUSTER                        COBOL35
PERFRD   RES      0                                                     COBOL35
         BAL,R10  RDCLUS            READ NEXT CLUSTER                   COBOL35
         CI,R7    X'80'                                                 COBOL35
         BAZ      PERF              NOT NEXT STATEMENT YET              COBOL35
         CI,R7    X'C1'             ALLOW FOR 'UNTIL' CLUSTER           COBOL35
         BE       PERF              SEE WHAT TYPE CLUSTER THIS IS       COBOL35
         B        PERF11            FINISHED                            COBOL35
PERF2    RES                                                            COBOL35
         LW,R9    DATACNT1          ALL REF                             COBOL35
         BAL,R10  DB%DATA                                               COBOL35
         B        %+2               VALID                               COBOL35
         B        PERF1             INVALID                             COBOL35
         BAL,R10  DATNAM                                                COBOL35
         B        PERFRD                                                COBOL35
PERF4    RES      0                                                     COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    5                                                     COBOL35
         LB,R5    0,R3              PRIORITY NUMBER                     COBOL35
         AI,R3    1                                                     COBOL35
         SLS,R3   -1                                                    COBOL35
         LH,R4    0,R3                                                  COBOL35
         SLS,R4   16                                                    COBOL35
         OR,R4    PROCNT                                                COBOL35
         BAL,R10  CKPROC            CHECK IF THIS SHOULD BE DEBUGGED    COBOL35
         B        PERF5             NO                                  COBOL35
         LW,R10   CBYTE2
         STW,R10  CBYTE             SET CBYTE FOR PROCNAM
         LI,R10   PERF6                                                 COBOL35
         STW,R10  PROC%EX           RETURN ADDRESS                      COBOL35
         B        ENT%PROC          GO TO PROCNAM (SECONDARY ENTRY)     COBOL35
PERF5    RES      0
         BAL,R10  STK%CRF
PERF6    RES      0
         BAL,R10  RDCLUS
         CI,R7    X'80'                                                 COBOL35
         BAZ      PERF6A            NOT NEXT STATEMENT
         CI,R7    X'C1'             UNTIL CLUSTER
         BE       PERF9             WRITE DB STACK AND CONTINUE LOOKING COBOL35
         BAL,R10  WRT%DBSK          NEXT STAMENT REACHED, WRITE STACKS  COBOL35
         BAL,R10  WT%CRF                                                COBOL35
         B        SETUP             RETURN                              COBOL35
PERF6A   RES      0                                                     COBOL35
         CI,R6    X'96'                                                 COBOL35
         BE       PERF4                                                 COBOL35
         CI,R6    X'94'                                                 COBOL35
         BE       PERF4                                                 COBOL35
         B        PERF9                                                 COBOL35
PERF9    RES      0                                                     COBOL35
         BAL,R10  WRT%DBSK          WRITE ANY DEBUG PROCEDURE NAME CLUS COBOL35
         B        PERF              PROCESS NEXT                        COBOL35
PERF11   RES      0                                                     COBOL35
         BAL,R10  WT%CRF                                                COBOL35
         BAL,R10  WRT%DBSK                                              COBOL35
         B        SETUP                                                 COBOL35
COB35%EX RES      0                                                     COBOL35
*  SEE WHAT THE LAST CONTROL BYTE WAS AND WRITE STACKS ACCORDINGLYY     COBOL35
*   THEN PUT DATA TABLE IN DYNAMIC FOR REPORT WRITER CLAUSES ONLY       COBOL35
*  THEN RETURN TO COBOL30                                               COBOL35
         LW,R7    CBYTE2            LOAD LAST CONTROL BYTE
         LI,R3    8
         CB,R7    BTBL,R3
         BE       EX35A
         BDR,R3   %-2
         BAL,R10  WT%CRF
         BAL,R10  WRT%DBSK                                              COBOL35
         B        %+3                                                   COBOL35
EX35A    RES      0                                                     COBOL35
         BAL,R10  WRT%DBSK                                              COBOL35
         BAL,R10  WT%CRF
*        MOVE REPORT TABLE ITEMS TO WORKING STORAGE IN ANY              COBOL35
         LW,R13   PDBZ              LOW  MEMORY WA                      COBOL35
         SLS,R13  2                 BYTE ADDRESS DYNAMIC                COBOL35
         LI,R12   BA(TABLE)                                             COBOL35
         LI,R1    0                                                     COBOL35
EX35B    RES      0                                                     COBOL35
         LW,R8    TABLE,R1          LOOK AT 2ND TABLE WORD FOR REPORT   COBOL35
         AND,R8   =X'FF'            MASK OFF BASE NUMBER                COBOL35
         CI,R8    0                                                     COBOL35
         BE       EX35D                                                 COBOL35
         AI,R12   16                16 BYTES                            COBOL35
EX35C    RES      0                                                     COBOL35
         AI,R1    4                 4  WORDS                            COBOL35
         CW,R1    TBL:SIZ                                               COBOL35
         BLE      EX35B                                                 COBOL35
         B        EX35E                                                 COBOL35
EX35D    RES      0                                                     COBOL35
         OR,R13   COUNT16                                               COBOL35
         MBS,R12  0                 MOVE TO DYNAMIC                     COBOL35
         MTW,4    TBLSIZE                                               COBOL35
         B        EX35C                                                 COBOL35
EX35E    RES      0                                                     COBOL35
         AND,R13  =X'00FFFFFF'                                          COBOL35
         SLS,R13  -2                                                    COBOL35
         STW,R13  PDBZ              CHG PCBZ FOR COBOL34B               COBOL35
         B        PH35E             RETURN                              COBOL35
SAVREG   RES      15                SAVE REGISTERS                      COBOL35
SAVREG2  RES      15                                                    COBOL35
SAVREG3  RES      4                                                     COBOL35
SAVREG4  RES      15                                                    COBOL35
SAV3     RES      1                 SAVE REG 3                          COBOL35
DATAOT   RES      1                                                     COBOL35
DATSET   RES      1                                                     COBOL35
RDEX     RES      1                                                     COBOL35
RDNOT    RES      1                                                     COBOL35
COMPSGN  DATA     0                                                     COBOL35
ALTFLG   DATA     0                                                     COBOL35
ALTCLS1  RES      3                 SAVE 'TO PROCEED TO'                COBOL35
ALTCLS2  RES      3                 SAVE 'ALTER'                        COBOL35
ALTNAM1  RES      9                 SAVE 'ALTER' NAME                   COBOL35
ALTNAM2  RES      9                 SAVE 'TO PROCEED TO' NAME           COBOL35
CORRFLG  DATA     0                 CORR FLG FOR SUBSCRIPT INDICATOR    COBOL35
IFFLG    DATA     0                 CONDITIONAL FLAG                    COBOL35
CMEXT    DATA     0                                                     COBOL35
CRFCM    RES      75                                                    COBOL35
CRFCMB   DATA     BA(CRFCM)                                             COBOL35
FALL     TEXTC    'FALL THROUGH'                                        COBOL35
COMPIL   TEXTC    'COMPILER GENERATED INDEX'                            COBOL35
SAVCRF   RES      600                                                   COBOL35
CRFPTR   DATA     BA(SAVCRF)                                            COBOL35
CRFPTR2  DATA     0                                                     COBOL35
DBBUILD  RES      10                                                    COBOL35
BCDLIN1  DATA     0                 FIRST 3 POS OF LINE NUMBER WITH CNT COBOL35
BCDLIN2  DATA     0                 NEXT 3 POS (LINE NO = 6 POS)        COBOL35
T:ENTRY  DATA     0                 POINTER TO TABLE ENTRY              COBOL35
DBSTACK  RES      900                                                   COBOL35
DBPTR    DATA     BA(DBSTACK)       STACK POINTER                       COBOL35
DBPTRE   DATA     0                 LAST ENTRY IN STACK                 COBOL35
CBYTE    DATA     0                                                     COBOL35
CBYTE2   DATA     0
PERFCRF  DATA     X'06E19480'                                           COBOL35
PERFCRF1 DATA     X'00000000'                                           COBOL35
PERFCRF2 DATA     X'0000FF06'                                           COBOL35
MOVE1    DATA     X'00DE9000'                                           COBOL35
MOVE2    DATA     X'005E9000'                                           COBOL35
MOVE3    DATA     X'06DEB000'       FOR LINE NO                         COBOL35
MOVE5    DATA     X'0A5E9081'       A,B,C,D  FIELDS FOR MOVE TO         COBOL35
MOVE6    DATA     X'0000A100'       E,H,I,J (COMMON STO,ALPHA)          COBOL35
MOVE7    DATA     X'0A000000'       BASE DISP (CHANGES PER ITEM)        COBOL35
MOVE8    DATA     X'00000006'       P (SIZE OF ITEM--RFLD)              COBOL35
MOVE9    DATA     X'FF0A'           FILLER                              COBOL35
MOVNUM   DATA     X'05DEC000'                                           COBOL35
MOVNUM1  DATA     X'00030000'                                           COBOL35
MOVNUM2  DATA     X'00050000'                                           COBOL35
MOVSUB   DATA     X'0A5E9081'       RFLD FOR MOVE SUBSCRIPT             COBOL35
         DATA     X'0000A700'                                           COBOL35
MOVSUB1  DATA     X'0A000000'                                           COBOL35
         DATA     X'00000004'                                           COBOL35
         DATA     X'FF0A'                                               COBOL35
SET      DATA     X'0AE79000'       SFLD FOR SET INDEX                  COBOL35
         DATA     X'0000A700'                                           COBOL35
SET1     DATA     X'0A000000'                                           COBOL35
         DATA     X'00000004'                                           COBOL35
         DATA     X'FF0A'                                               COBOL35
SETCN    DATA     X'0AE79000'       SFLD FOR DEBUG-CONTENTS TO INDEX    COBOL35
         DATA     X'0000A100'                                           COBOL35
SET2     DATA     X'0A000000'                                           COBOL35
SET3     DATA     X'00000004'                                           COBOL35
         DATA     X'FF0A'                                               COBOL35
ADD      DATA     X'05D1D000'                                           COBOL35
ADD1     DATA     0                                                     COBOL35
ADDRFLD  DATA     X'0A519081'       RFLD FOR ADD (INTO DB-SUB)          COBOL35
         DATA     X'0000A700'                                           COBOL35
ADD2     DATA     X'0A000000'                                           COBOL35
         DATA     X'00000004'                                           COBOL35
         DATA     X'FF0A'                                               COBOL35
MOVE10   DATA     X'0000001E'       SIZE FOR P FIELD OF NAME FILED      COBOL35
BLK      DATA     X'01400004'
SIZE2    DATA     0                                                     COBOL35
PROC%EX  DATA     0                                                     COBOL35
INDX%DEC DATA     0                                                     COBOL35
COUNT2   DATA     X'02000000'                                           COBOL35
COUNT4   DATA     X'04000000'                                           COBOL35
COUNT6   DATA     X'06000000'                                           COBOL35
COUNT10  DATA     X'0A000000'                                           COBOL35
COUNT12  DATA     X'0C000000'                                           COBOL35
COUNT13  DATA     X'0D000000'                                           COBOL35
COUNT20  DATA     X'14000000'                                           COBOL35
COUNT16  DATA     X'10000000'                                           COBOL35
COUNT25  DATA     X'19000000'                                           COBOL35
DISP2    DATA     7                 AW FOR DISP OF DEBUG-NAME           COBOL35
DISP3    DATA     38                AW FOR DISP OF SUB-1                COBOL35
DISP4    DATA     43                AW FOR DISP OF SUB-2                COBOL35
DISP5    DATA     48                AW FOR DISP OF SUB-3                COBOL35
DISP6    DATA     53                AW FOR DISP OF CONTENTS             COBOL35
ARTSW    DATA     0
DDBPTR   DATA     0                                                     COBOL35
DDB#     DATA     0                 SAVE DDB POINTER                    COBOL35
DATACNT1 DATA     X'0000'           ALL FLAG (= NOT ALL) AND TABLE NO   COBOL35
FILECNT  DATA     X'0002'           ALL FLAG (= NOT ALL) AND TABLE NO   COBOL35
DATACNT2 DATA     X'FF00'           ALL FLAG ( = ALL) AND TABLE NO      COBOL35
PROCNT   DATA     X'0001'           NOT ALL FLG AND TABLE NO            COBOL35
CRF%EX   DATA     0                                                     COBOL35
ORIG%PTR DATA     0                 SAVE DBPTR                          COBOL35
RD%PTRE  DATA     0                 LAST AVAILABLE ADDRESS AFTER READ   COBOL35
LABL#    DATA     0                 INTERNAL LABEL # FOR READ STATEMENT COBOL35
DAT%EX   DATA     0                                                     COBOL35
SUBCNT   DATA     0                 NUMBER OF SUBS. BYTE 0 USED AS INDEXCOBOL35
SUBCNT2  DATA     0                 NUMBER OF SUBSCRIPT                 COBOL35
NSUB1    DATA     0                 NUMERIC VALUE SUBSCRIPT 1           COBOL35
NSUB2    DATA     0                 NUMERIC VALUE SUBSCRIPT 2           COBOL35
NSUB3    DATA     0                 NUMERIC VALUE SUBSCRIPT 3           COBOL35
DSUB1    RES      10                SUBSCRIPT CLUSTER 1                 COBOL35
DSUB2    RES      10                SUBSCRIPT CLUSTER 2                 COBOL35
DSUB3    RES      10                SUBSCRIPT CLUSTER 3                 COBOL35
TYPE     DATA     0                                                     COBOL35
MSK1     DATA     X'7F'                                                 COBOL35
MSK2     DATA     X'0F'                                                 COBOL35
MSK3     DATA     X'F000'                                               COBOL35
BTBL     GEN,8,8,8,8  X'57',X'5B',X'5C',X'61'
         GEN,8,8,8,8  X'63',X'6D',X'71',X'4C'
*
* P:DCL -- ROUTINE TO HANDLE THE DECLARATIVES AND END DECLARATIVE
*                 STATEMENTS
*
*        EXPECTS:   R6 = OPERAND OPTIONS
*                   R7 = CONTROL BYTE
*                   R2 = CRF POINTER
*
*        EXITS BY BRANCHING TO SETUP
*
P:DCL    RES      0
         MTW,-1   DECL%FLG
         BLZ      DECL%ERR          3 OR MORE DECLARATIVE CLUSTERS
         BGZ      PASS
         BAL,R10  GEN%CLR
         B        DECL%KILL
DECL%ST  RES      0
         BAL,R10  RDCLUS            READ NEXT CLUSTER
         AND,R7   =X'7F'
         CI,R7    X'6C'             USE STATEMENT
         BE       P:USE             YES
         CI,R7    X'73'             PROCEDURE DEFINITION
         BE       P:PROCDF          YES
         CI,R7    X'72'
         BE       P:DCL
PASS     BAL,10   CMPRS             PASS CLUSTER ON
         B        DECL%ST
DECL%ERR RES      0
         LI,R1    220               *** USE FOR DEBUGGING ERROR ***
         BAL,R11  DIAG              ISSUE DIAG
DECL%KILL RES     0                                                     COBOL35
         BAL,R10  CMPRS                                                 COBOL35
         B        START             BACK TO NORMAL                      COBOL35
GEN%CLR  RES      0
         LCI      15
         STM,R1   SAVREG
         LW,R4    MOVE3
         AI,R4    X'100'            MAKE MOVE ALL LITERAL CLUSTER
         STW,R4   DBBUILD
         LI,R4    4
         STB,R4   DBBUILD
         LW,R4    BLK
         STW,R4   DBBUILD+1
         LI,R2    BA(DBBUILD)
         LI,R6    X'94'             SETUP R6 FOR CMPRS
         BAL,R10  CMPRS             PUT SFLD ON CRFS
         LW,R4    PDBDBG
         STW,R4   MOVE7
         LI,R4    185               SIZE OF DEBUG-ITEM
         STW,R4   MOVE8
         LI,R2    BA(MOVE5)
         LI,R6    X'94'
         BAL,R10  CMPRS
         LCI      15
         LM,R1    SAVREG
         B        *R10              RETURN
*
P:PROCDF RES      0
         LW,R1    R2
         AI,R1    2
         LB,R3    0,R1
         CI,R3    X'9A'             SECTION TRAILER?
         BNE      %+2
         BAL,R10  GEN%CLR
         LI,R1    3                                                     COBOL35
         AW,R1    R2                                                    COBOL35
         LB,R3    0,R1              TYPE OF ENTRY                       COBOL35
         CI,R3    DECLSECT          DECLARATIVE SECTION HEADER          COBOL35
         BNE      PASS              GO BYPASS MORE CLUSTERS
         MTW,1    PDBDBGC           ADD 1 TO COUNT FIELD                COBOL35
         LW,R1    R2
         SLS,R1   -1                HA(CLUSTER)
         AI,R1    1                 RIGT HW
         LH,R4    2,R1              GET EXIT # FROM CLUSTER             COBOL35
         STW,R4   PNO:XNO
         LH,R4    1,R1              GET  PROCEDURE #                    COBOL35
         STH,R4   PNO:XNO           COMBINE WITH PNO
         BAL,R10  CMPRS             PASS CLUSTER ON                     COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER
         AND,R7   =X'7F'
         CI,R6    X'9B'                                                 COBOL35
         BNE      DECL%ERR            BUG OUT
         BAL,R10  STRINGER                                              COBOL35
         B        DECL%ST                                               COBOL35
P:USE    RES      0
         AI,R2    3                                                     COBOL35
         LB,R1    0,R2
         AI,R2    -3                                                    COBOL35
         CI,R1    USE%DBG           IF USE FOR DEBUGGING
         BANZ     P:DBG1            GO PROCESS                          COBOL35
         MTW,1    DBG%ENDD          SET END OF DEBUGGING FLAG           COBOL35
         BAL,R10  CMPRS             BYPASS CLUSTER                      COBOL35
         B        START             GET NEXT                            COBOL35
*
* P:DBG -- PROCESS USE FOR DEBUGGING CLUSTERS
*
P:DBG1   RES      0                                                     COBOL35
         MTW,0    DBG%ENDD          IF NON-DEBUGGING USE ALREADY
         BNEZ     DECL%ERR           PROCESSED  GO DIE.
         B        DBG%OK                                                COBOL35
P:DBG    RES      0                                                     COBOL35
         BAL,R10  RDCLUS            GET NEXT CLUSTER                    COBOL35
         AND,R7   MSK1                                                  COBOL35
         CI,R7    USECLS            SEE IF USE CLUSTER                  COBOL35
         BE       DBG%OK                                                COBOL35
         BAL,R10  CMPRS             PASS CLUSTER                        COBOL35
         LW,R3    R2                                                    COBOL35
         AI,R3    3                                                     COBOL35
         LB,R1    0,R3              ST OPT                              COBOL35
         CI,R1    LAST%CL           SEE IF LAST STAMENT                 COBOL35
         BANZ     DECL%ST                                               COBOL35
         B        P:DBG                                                 COBOL35
DBG%OK   RES      0
         CI,R6    X'9B'                                                 COBOL35
         BE       DBG%OK1                                               COBOL35
         CI,R6    X'9C'                                                 COBOL35
         BNE      %+3
DBG%OK1  RES      0                                                     COBOL35
         BAL,R10  STRINGER                                              COBOL35
         B        P:DBG            GET NEXT CLUSTER
         LW,R1    R2                                                    COBOL35
         AI,R1    3                                                     COBOL35
         LB,R3    0,R1                                                  COBOL35
         STB,R3   STOP              SAVE STATEMENT OPTIONS              COBOL35
         CI,R3    ALL%FLG           SEE IF ALL FLAG SET                 COBOL35
         BANZ     DBG%ALL           YES                                 COBOL35
         CI,R6    FNAME             FILE                                COBOL35
         BE       P:FNAM                                                COBOL35
         CI,R3    CDNAME            CDNAME                              COBOL35
         BANZ     P:FNAM                                                COBOL35
         CI,R6    PROCDUR           LOOK AT REF TYPE FOR PROCEDURE NAME COBOL35
         BE       P:PNAME                                               COBOL35
         B        P:DNAME                                               COBOL35
DBG%ALL  RES      0                                                     COBOL35
         CI,R3    PROCED            SEE IF PROCEDURE OR DATA NAME       COBOL35
         BANZ     P:ALLP            PROCEDURE                           COBOL35
         B        P:ALLR            DATA NAME                           COBOL35
         B        DECL%ERR
*
P:ALLP   RES      0
         MTW,0    PNAM%CNT          IF ANY DEBUGS FOR PROCEDURES YES
         BNEZ     DECL%ERR          GO  DIE
         MTW,-1   PNAM%CNT          SET ALL PROCEDURES FLAG
         LW,R1    PNO:XNO
         STW,R1   ALL:PRC           SET XNO, PNO FOR ALL PROCEDURES
         LB,R1    STOP                                                  COBOL35
         CI,R1    LAST%CL                                               COBOL35
         BANZ     DECL%ST           LAST STATEMENT RETURN               COBOL35
         B        P:DBG             NORMAL RETURN                       COBOL35
*
*
*
*                 R4 = 1ST WORD OF SCH ARG
*                 R5 = 2ND WORD OF SCH ARG
*
CKDATA   RES      0
CKFILE   RES      0
CKPROC   RES      0
         STD,R4   T:ARG             SAVE ARGUMENT
         LI,R1    0
         LI,R5    -1               SET COMPARISON MASK                  COBOL35
         AND,R4   =X'FF00'          BASED ON  'ALL'
         BNEZ     CKPROC1           OR
         EOR,R5   =X'FF00'          NOT 'ALL'
CKPROC1  RES      0
         MTW,0    PNAM%CNT          ALL PROCEDURES SET
         BLZ      P:SCHALP
P:SCH00  RES      0
P:SCH01  RES      0
         LW,R4    *TBL:ARG,R1       GET TABLE ENTRY WORD 1
         CS,R4    T:ARG              COMPARE TO ARGUMENT WORD 1
         BE       P:FOUND1
P:SCH02  RES      0
         AI,R1    4                 NO MATCH TRY NEXT
         CW,R1    TBL:SIZ
         BLE      P:SCH01
         B        *R10              TABLE ENDED GO BACK
P:FOUND1 RES      0
         STW,R1   T:ENTRY           SET ADDRESS OF 'FOUND' ITEM
         AI,R1    1
         LW,R4    *TBL:ARG,R1
         CW,R4    T:ARG+1           COMPARE 2ND WORD
         BE       P:FOUND2
         AI,R1    -1
         B        P:SCH02           NO MATCH, GO TRY AGAIN
P:FOUND2 RES      0
         LW,R4    TBL:ARG
         AWM,R4   T:ENTRY           RETURN TABLE ADDRESS
P:FOUND3 RES      0
         AI,R10   1                 ** ENTRY FOUND **
         B        *R10              EXIT TO BAL + 2
P:SCHALP RES      0
         LI,R3    3                 ALL PROC. SET
         LB,R3    T:ARG,R3                                              COBOL35
         CI,R3    1                 IS THIS A PROC. REF
         BNE      P:SCH00           NO. GO BACK
         LI,R1    ALL:PRC-3         POINT AT 3 WDS BACK FROM PROC NOS   COBOL35
         STW,R1   T:ENTRY           SET TABLE ADDRESS
         B        P:FOUND3          RETURN TO CALLER
*
*
*
P:PNAME  RES      0
         LW,R1    R2
         AI,R1    5                                                     COBOL35
         LB,R13   0,R1              PRIORITY NUMBER                     COBOL35
         AI,R1    1                                                     COBOL35
         SLS,R1   -1                H.A. OF PROC NUMBER                 COBOL35
         LH,R12   0,R1                                                  COBOL35
         SLS,R12  16                                                    COBOL35
         OR,R12   PROCNT            SET NOT ALL REF & TABLE 1           COBOL35
         BAL,R10  RDCLUS            GET STRING CLUSTER                  COBOL35
         CI,R6    X'9C'             VALIDATE
         BNE      DECL%ERR          NOT STRING                          COBOL35
         BAL,R10  STRINGER          STUFF STRING                        COBOL35
P:SETBLE RES      0
*  COMMON CODE TO SET NEXT TABLE ENTRY
*        TABLE ENTRY IS IN R12, R13, R14
*
         LW,R15   PNO:XNO           SET LAST WORD OF TABLE
         LCI      4
         STM,R12  *T:NXT            STORE TABLE ENTRY
         MTW,4    T:NXT
         LI,R15   0
         STW,R15  ALL%SET           RESET 'ALL' FLAG
         MTW,4    TBL:SIZ           UPDATE TABLE SIZE                   COBOL35
         LB,R1    STOP                                                  COBOL35
         CI,R1    LAST%CL                                               COBOL35
         BANZ     DECL%ST                                               COBOL35
         B        P:DBG                                                 COBOL35
*
*
*
P:FNAM   RES      0
         LW,R1    R2                                                    COBOL35
         SLS,R1   -1                H.A. OF CLUSTER                     COBOL35
         AI,R1    2                 POINT AT REF#                       COBOL35
         LH,R12   0,R1                                                  COBOL35
         SLS,R12  16                                                    COBOL35
         OR,R12   FILECNT          SET FILE INDICATOR                   COBOL35
         SLS,R1   1                 B.A.  REF#                          COBOL35
         AI,R1    2                 B.A.  DB NUMBER                     COBOL35
         LB,R13   0,R1              SET DB NUMBER
SET%STR  RES      0                                                     COBOL35
         BAL,R10  RDCLUS            GET 'STRING' CLUSTER
         CI,R6    X'9C'             VERIFY STRING                       COBOL35
         BNE      DECL%ERR          INVALID...DIE
         BAL,R10  STRINGER          STUFF THE STRING
         B        P:SETBLE          GO STORE TABLE ENTRY
*
*
*
P:DNAME  RES      0
         LW,R1    R2
         SLS,R1   -1
         AI,R1    5
         LH,R8    0,R1              BASE
         AI,R1    1
         LH,R13   0,R1              DISPL
         STH,R8   R13               ..RECOMBINED
         AI,R1    -3
         LH,R12   0,R1              REF #
         SLS,R12  16
         OR,R12   ALL%SET           SET ALL FLAG IF NEEDED
         B        SET%STR
*
* P:ALLR -- PROCESS 'ALL REFERENCES'
*
P:ALLR   RES      0
         LI,R1    X'FF00'           SET FOR ALL REF
         STW,R1   ALL%SET
         B        P:DNAME           GO TO DATA NAME PROCESSING
*
* STRINGER -- STORE NAME STRING IN TABELE, RETURN ADDRESS IN R15
*
STRINGER RES      0
         LW,R4    R2                SOURCE IS INPUT CLUSTER
         AI,R4    3                 3 BYTES FOR 9C                      COBOL35
         CI,R6    X'9C'                                                 COBOL35
         BE       %+2                                                   COBOL35
         AI,R4    3                 6 BYTES FOR 9B                      COBOL35
         LW,R5    NXTSTRNG          DEST NEXT TABLE ENTRY
         STW,R5   R14                                                   COBOL35
         LB,R1    0,R4
         AI,R1    1
         STB,R1   R5                SIZE IS IN CLUSTER
         MBS,R4   0
         STW,R5   NXTSTRNG
         B        *R10
*
ALL%SET  DATA     0
DECL%FLG DATA     2                 DECLARATIVES FLAG
PNO:XNO  RES      1                 HOLD AREA PROC#, XIT#
DBG%ENDD DATA     0                 USE..DEBUG ENDED FLG
RSTR%RD  RES      1                 SAVE FOR 1ST INST OF RDCLUS
T:NXT    DATA     TABLE
TABLE    RES      400
         BOUND    8
T:ARG    RES      2
TBL:SIZ  DATA     0
TBL:ARG  DATA     TABLE
STOP     DATA     0                 STATEMENT OPTIONS                   COBOL35
ALL:PRC  DATA     0
PNAM%CNT DATA     0
*
*
DECLSECT EQU      X'95'             DECLARATIVE SECTION ID              COBOL35
STRNGCLS EQU      X'73'             STRING CLUSTER ID
USECLS   EQU      X'6C'             USE CLUSTER ID
USE%DBG  EQU      X'40'             USE..DEBUGGING ID
ALL%FLG  EQU      X'08'             ALL INDICATOR                       COBOL35
PROCED   EQU      X'01'             ALL PROCEDURE                       COBOL35
LAST%CL  EQU      X'80'             LAST CLUSTER INDICATOR              COBOL35
CDNAME   EQU      X'04'             CD                                  COBOL35
FNAME    EQU      X'93'             FILE                                COBOL35
PROCDUR  EQU      X'96'      PROCDURE NAME (PARAGRAPH)                  COBOL35
         END      COB35                                                 COBOL35
