*                 CATALOG NO. 704898 - M:SYSMOD (SYSGEN MODIFY)
         SYSTEM   SIG7FDP
         DEF      MODIFY
         CSECT    1
SN       EQU      0                 LEFT BYTE OF R0
R0       EQU      0
I        EQU      1
R1       EQU      1
K        EQU      2
R2       EQU      2
A        EQU      3
R3       EQU      3
R4       EQU      4
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
LO       EQU      4
LO1      EQU      LO+1
J        EQU      5
R5       EQU      5
T        EQU      6
P        EQU      7
X        EQU      8
Y        EQU      9
R        EQU      10
SR4      EQU      11
C        EQU      12
N        EQU      13                N = C+1
V        EQU      14
M        EQU      15                M = V+1
         PAGE
*  TABLE PARAMETERS
*
PRLH     EQU      6
PELH     EQU      7
PRULH    EQU      14
PEULH    EQU      15
PCW      EQU      0
PSW      EQU      1
PTLW     EQU      2
P0LW     EQU      4
TRSH     EQU      12
TESH     EQU      16
T0SLW    EQU      5
T2SLW    EQU      9
RTB      EQU      1
RNCB     EQU      12
RVW      EQU      1
RRW      EQU      2
EPRW     EQU      -1
ECB1B    EQU      2
EDPW     EQU      2
         PAGE
*  CONSTANTS
*
DEFBIT   EQU      X'80'
CORDEST  EQU      X'40'
XDEFBIT  DATA     DEFBIT
M2       DATA     3
M3       DATA     7
M6       DATA     X'3F'
M7       DATA     X'7F'
M16      DATA     X'FFFF'
M17      DATA     X'1FFFF'
M32      DATA     -1
Y02      DATA     X'02000000'
Y8       DATA     X'80000000'
MASK     DATA     X'7FFFF'          B
         DATA     X'3FFFF'          H
         DATA     X'1FFFF'          W
         DATA     X'0FFFF'          D
         DATA     -1                NO RES.
         PAGE
*  SUBROUTINES
*
*
*  RFDFSTK SEARCH
*
*        INPUTS:  N = WA(NAME LOC)
*        CALL:    BAL,SR4 RSEARCH
*        RETURN 1: SYMBOL NOT FOUND
*                 N = WA(NAME)
*                 A = WA(NEXT AVAILABLE RFDFSTK ITEM LOC)
*                 C = NEXT AVAILABLE RFDFSTK ITEM INDEX
*        RETURN 2: SYMBOL FOUND
*                 N = WA(NAME)
*                 A = WA(ITEM)
*                 C = ITEM INDEX
*        OTHER REG'S USED: I,J,K,X,Y
*
*
RSEARCH  LI,K     PRLH
         LH,A     *P,K              A:= RFDF ITEM ADDRESS
         SLS,A    1
         LI,C     0                 C:= RFDF ITEM INDEX
         LI,K     TRSH
         LH,Y     *T,K              Y:= SIZE OF RFDFSTK
RS1      BLEZ     *SR4              EXIT IF NO MORE ITEMS IN RFDFSTK
         LB,I     *N                I:= CH. COUNT FOR GIVEN SYMBOL
         LI,K     RNCB
         CB,I     *A,K              COMPARE WITH COUNT FOR RFDF SYMBOL
         BNE      RS2               REJECT ITEM IF DIFFERENT
         LI,J     0
RS3      AI,J     1
         AI,K     1
         LB,X     *N,J              COMPARE NEXT CHARACTER
         CB,X     *A,K
         BNE      RS2               REJECT IF DIFFERENT
         BDR,I    RS3
EXIT1    AI,SR4   1                 TAKE 'SKIP' EXIT
         B        *SR4
RS2      EQU      %                 ITEM REJECTED
         LB,X     *A                GET ITEM SIZE
         AW,A     X
         AW,C     X
         SW,Y     X
         B        RS1               PROCEED TO NEXT ITEM
         PAGE
*
*  EVALUATE LOCATION
*
*        INPUTS:  N = WA(LOC EXPR)-1
*        CALL:    BAL,SR4  LOC
*        RETURN:  N = WA(NEXT EXPR)-1
*                 LO = CORE ADDRESS OF DESIGNATED LOC
*                 SN = SECTION NUMBER (0,1 OR 2)
*        OTHER REG'S:    R,X,Y,J,C
*        SUBR'S CALLED:    EVAL
*
*  COMPUTE SECTION NUMBER
*
*        INPUTS:  N = WA(LOC CONTAINING UPPER 15 BITS FOR LO)
*                 LO = ADDRESS TO GET SECT. NO. OF
*        CALL:    BAL,SR4  SECTION
*        RETURN:  SN = SECTION NUMBER (0-2) OF LO
*        OTHER REG'S:    X,Y,J,C
*
*
LOC      PSW,SR4  *R0               SAVE SR4
         LI,R     2                 SET RES=WA
         BAL,SR4  EVAL              EVALUATE EXPRESSION
         B        ERR1              EXPRESSION MUST BE DEFINED
         B        ERR1
         PLW,SR4  *R0
         LW,LO    V
SECTION  SLD,LO   -1
         AND,LO   M16               LO:=DA(V). SAVE BIT 31 IN LO+1 (=J)
         LI,C     T2SLW
LO4      LW,X     *C,T              GET SIZE, LOC OF SECTION
         LH,Y     X                 Y:= SECTION SIZE (DOUBLEWORDS)
         AND,X    M16               X:= SECTION BASE (DA)
         CW,LO    X
         BL       LO3               REJECT IF LO<SECTION BASE
         AW,X     Y
         CW,LO    X
         BL       LO2               REJECT IF LO>=VASE+SIZE
LO3      AI,C     -2                REJECTED, TRY NEXT SECTION
         CI,C     T0SLW
         BGE      LO4
         B        ERR               NOT IN ANY SECTION, ERROR
LO2      AI,C     -T0SLW
         SLS,C    -1
         STB,C    SN                SAVE SECTION NUMBER
         SLD,LO   1                 RE-ESTABLISH AS WORD ADDRESS
         LI,LO1   X'E0000'
         LS,LO    *N                COPY UPPER 15 BITS OF VAL TO LO
         B        *SR4
EXITL    PLW,SR4  *R0
         B        *SR4
EXITL1   PLW,SR4  *R0
         B        EXIT1
         PAGE
*
*  EVALUATE EXPRESSION
*
*        INPUTS:  N = WA(EXPR)-1
*                 R = RESOLUTION CODE FOR SYMBOL (0-4)
*        CALL:    BAL,SR4  EVAL
*        RETURN 1:  NAME NOT FOUND IN RFDFSTK
*                 N = WA(NAME)
*                 R = RES INDEX (0-4)
*                 A = WA(NEXT AVAILABLE RFDFSTK ITEM)
*                 C = INDEX OF NEXT AVAILABLE RFDFSTK ITEM
*        RETURN 2:  NAME FOUND IN RFDFSTK, BUT IT'S A REF
*                 N = WA(NAME)
*                 R = RES INDEX (0-4)
*                 A = WA(RFDFSTK ITEM)
*                 C = INDEX OF RFDFSTK ITEM
*        RETURN 3:  EXPRESSION COMPLETELY EVALUATED
*                 N = WA(NEXT EXPR)-1
*                 R = RES INDEX OF FINAL VALUE (0-4)
*                 C = INDEX OF SYMBOL ITEM(IF ANY), -1 IF NONE
*                 M = RES WORD OF FINAL VALUE
*                 V = VALUE
*        OTHER REG'S:    J,K,X,M
*        SUBR'S CALLED:  RSEARCH, ADJUST
*
*  EVALUATE EXPR WITH RES. CODE IN CHANGE-TABLE
*
*        INPUTS, OUTPUTS, RETURNS: SAME AS 'EVAL' EXCEPT NO 'R' INPUT
*        CALL:    BAL,SR4  EVALR
*
EVALR    LW,R     PCW,P
         LW,R     *R
         AND,R    M3
EVAL     PSW,SR4  *R0
         AI,N     1                 N:= WA(NAME)
         MTB,0    *N                SEE IF SYMBOL PRESENT
         BEZ      EV1
         BAL,SR4  RSEARCH           YES- FIND IT IN RFDFSTK
         B        EXITL             RETURN 1
         LI,K     RTB
         LB,X     *A,K              X:=TYPE
         AND,X    M6
         BEZ      EV3
         CI,X     3                 REJECT IF TYPE NOT DEF,CSECT OR
         BL       EXITL1               DSECT
EV3      LW,V     RVW,A             V:= SYMBOL VALUE
         LW,M     RRW,A             M:= SYMBOL RESOLUTION WORD
         BAL,SR4  ADJUST            ADJUST V TO RESOLUTION (R)
EV4      LB,J     *N                ADD CONSTANT
         SLS,J    -2
         AW,N     J
         AI,N     1                 N:=WA(VAL)
         AW,V     *N                ADD VAL
         PLW,SR4  *R0               RETURN 3
         AI,SR4   2
         B        *SR4
EV1      LI,V     0                 NO NAME.  V:=0
         LI,M     0                           M:=0
         LI,R     4                           R:=4
         LI,C     -1
         B        EV4
         PAGE
*
*  ADJUST V,M TO RESOLUTION R
*
*        INPUT:   V = VALUE TO BE ADJUSTED
*                 M = RES WORD FOR V
*                 R = INDEX OF RES REQ'D (0-4)
*        CALL:    BAL,SR4  ADJUST
*        RETURN:  V = ADJUSTED VALUE
*                 M = RES WORD OF ADJUSTED VALUE
*                 R = RES INDEX OF ADJUSTED VALUE (0-4)
*        OTHER REG'S:    J
*
ADJUST   PSW,M    *R0               SAVE RES WORD
         LI,J     4
AJ3      CI,M     X'FF'             CHECK ONE BYTE OF RES WORD
         BANZ     AJ2
         SLS,M    -8
         BDR,J    AJ3
         B        AJ5
AJ2      AI,J     -1                SEE IF BYTE IS +1 OR -1
         CI,M     1
         BE       AJ4
         CI,M     X'FF'
         BE       AJ4
AJ5      LI,R     4                 NO- MIXED RES
         PLW,M    *R0               RESTORE RES WORD
         B        *SR4
AJ4      CI,R     4                 SEE IF RES REQ'D
         BE       AJ1
         SW,J     R                 YES, ALIGN V
         SAS,V    0,J
         LCW,J    R                 SET M TO +1 OR -1 IN PROPER BYTE
         SLS,J    3
         SLS,M    24,J
         PLW,J    *R0               DUMMY PULL TO FIX STACK
         B        *SR4
AJ1      LW,R     J
         PLW,M    *R0
         B        *SR4
         PAGE
*  EXPRSTK DESTINATION-ADDRESS SEARCH
*
*        INPUTS:  LO = DEST. ADDRESS
*        CALL:    BAL,SR4  EDEST
*        RETURN:  ALL EXPRSTK ITEMS HAVING DEST=LO ARE REMOVED
*                 BY SETTING DEFBIT=1
*        OTHER REG'S:    I,J,K,X,Y,A
*
EDEST    PSW,SR4  *R0
         LI,K     PELH
         LH,A     *P,K              A:= EXPR LOC
         SLS,A    1
         LI,LO1   X'1FFFF'          (LO1 = J)
         LI,K     TESH
         LH,Y     *T,K              Y:= EXPR SIZE
ED1      BLEZ     EXITL             EXIT IF NO ITEMS LEFT
         LH,I     *A
         CI,I     DEFBIT
         BANZ     ED2               REJECT ITEM IF DEFINED
         CI,I     CORDEST
         BAZ      ED2               REJECT ITEM IF NOT TO CORE DEST.
         AND,I    M6
         AI,I     -EDPW             I:= INDEX TO DEST WORD
         CS,LO    *A,I
         BNE      ED2               REJECT IF ADDR(LO)~=ADDR(DEST)
         LH,I     *A                ITEM MATCHES. SET ITS DEFBIT TO 1
         OR,I     XDEFBIT
         STH,I    *A
ED2      LB,X     *A                MOVE ON TO NEXT ITEM
         AW,A     X
         SW,Y     X
         B        ED1
         PAGE
*
*  COMPUTE RFDFSTK POINTER FROM RFDF INDEX
*
*        INPUT:   N = RFDF INDEX
*        CALL:    BAL,SR4  RINDEX
*        RETURN:  LO = RFDF ADDRESS OF INDEXED ITEM
*        OTHER REG'S:    X
*
RINDEX   LI,LO    PRLH
         LH,LO    *P,LO
         SLS,LO   1                 LO:= WA(RFDFSTK)
         AND,N    M16               REMOVE LEFT HALF OF INDEX
         AW,LO    N                 ADD INDEX TO RFDFSTK BASE
         B        *SR4
         PAGE
*
*  FIX EXPRSTK FOR UNSATISFIED REF
*
*        INPUT:   -
*        CALL:    BAL,SR4  EFIX
*        RETURN:  -
*        OTHER REG'S:    ALL
*        SUBR'S CALLED:  RINDEX, ADJUST
*
EFIX     PSW,SR4  *R0
         LI,K     PELH
         LH,A     *P,K              A:= EXPR ITEM LOC
         SLS,A    1
         LI,K     TESH
         LH,Y     *T,K              Y:= EXPR SIZE
EF1      BLEZ     EXITL             EXIT IF NO ITEMS LEFT
         LH,I     *A
         CI,I     DEFBIT
         BANZ     EF9               REJECT IF DEFINED
         LI,J     ECB1B             J:= CONTROL BYTE INDEX
         AND,I    M6
         AW,I     A
         AI,I     EPRW              I:= RES. WORD POINTER
         LI,K     -EPRW             K:= CONSTANT/POINTER INDEX
EF4      LB,X     *A,J              FETCH NEXT CONTROL BYTE
         BEZ      EF5               REJECT ZERO BYTE (PADDING)
         CI,X     2
         BL       EF6               TEST FOR 'ADD CONSTANT'
         BE       EF2               TEST FOR 'EXPRESSION END'
         CI,X     X'30'
         BGE      EF5               TEST FOR 'CHANGE RES.'
         LW,N     *I,K
         BAL,SR4  RINDEX            FIND RFDFSTK ITEM
         LH,X     *LO               GET ITS TYPE
         AND,X    M6
         BEZ      EF6
         CI,X     3
         BL       EF9               REJECT EXPR IF REF
EF6      AI,K     1                 BUMP CONST/PNTR INDEX
EF5      AI,J     1                 BUMP CONTROL BYTE INDEX
         B        EF4
EF9      LB,X     *A                PROCESS NEXT EXPRSTK ITEM
         AW,A     X
         SW,Y     X
         B        EF1
*  EXPR COMPLETELY DEFINED, EVALUATE IT
EF2      LI,V     0                 INITIALIZE VALUE TO 0
         LW,M     0,I               INITIALIZE RES WORD
         LI,K     -EPRW             K := PNTR/RFDF INDEX
         LI,J     ECB1B             J := CONTROL BYTE INDEX
EF10     LB,X     *A,J              GET CONTROL BYTE
         BEZ      EF11              PADDING: IGNORE
         CI,X     2
         BE       EF12              END
         BG       EF13
         AW,V     *I,K              ADD CONSTANT
EF14     AI,K     1
EF11     AI,J     1
         B        EF10
EF13     LW,R     X                 MOVE RES BITS TO R
         AND,R    M2
         CI,X     X'30'
         BGE      EF15
         LW,N     *I,K              ADD/SUB DECLARATION
         AI,K     1
         BAL,SR4  RINDEX            FIND DEF
         LD,C     V                 SAVE EXPR VALUE/RES
         LW,V     RVW,LO            GET VALUE/RES OF DEF
         LW,M     RRW,LO
EF20     PSW,J    *R0               SAVE J
         BAL,SR4  ADJUST            ADJUST VALUE/RES OF ADDEND
         CI,X     8                 CHECK ADD/SUB BIT
         BAZ      EF16
         LCW,V    V                 NEGATE ADDEND VALUE
EF16     AW,V     C                 ADD EXPR VALUE
         LI,J     -4                UPDATE RES WORD
EF17     LB,R     M+1,J             GET INDEX FROM ADDEND RES WORD
         CI,X     8                 CHECK ADD/SUB BIT
         BAZ      EF18
         LCW,R    R                 NEGATE INDEX
EF18     LB,C     N+1,J             GET INDEX FROM EXPR RES WORD
         AW,R     C                 ADD TO ADDEND INDEX
         STB,R    M+1,J             STORE IT AS NEW EXPR RES INDEX
         BIR,J    EF17
         PLW,J    *R0               RESTORE J
         B        EF11
EF15     CI,X     X'34'
         BGE      EF19
         LI,C     0                 CHANGE RESOLUTION: MOCK UP AN
         LI,N     0                    EXPR WITH VALUE=RES=0
         B        EF20              ADDEND := EXPR
EF19     LD,C     V                 ADD/SUB ABS SECTION
         LI,V     0                 MAKE ADDEND = DA(0)
         LI,M     1
         B        EF20
EF12     LH,X     *A                END OF EXPRESSION
         OR,X     XDEFBIT           SET ITS DEFBIT TO 1
         STH,X    *A
         CI,X     CORDEST           SEE IF ITS DEST IS CORE
         BAZ      EF8
         PSW,A    *R0               YES- SAVE A AND Y
         PSW,Y    *R0
         LI,R     4
         BAL,SR4  ADJUST
         LW,J     R
         LW,M     MASK,J            ESTABLISH MASK FOR STORING
         LW,N     I
         AI,N     -EDPW-EPRW        N:= WA(EXPR DEST POINTER)
         LW,LO    *N                L:= DEST POINTER
         BAL,SR4  SECTION           COMPUTE SECT. NO. OF LO
         BAL,SR4  CHCORE            STORE EXPR VALUE
         PLW,Y    *R0               RESTORE A AND Y
         PLW,A    *R0
         B        EF9               PROCEED TO NEXT EXPRSTK ITEM
EF8      LW,N     -EDPW-EPRW,I      GET RFDF INDEX
         BAL,SR4  RINDEX            FIND RFDF ITEM
         STW,V    RVW,LO            STORE VALUE
         STW,M    RRW,LO            STORE RES WORD
         LI,K     RTB               SET ITS TYPE TO 'DEF'
         LI,X     0
         STB,X    *LO,K
         B        EF9
         PAGE
*
*  ADD RFDFSTK ITEM
*
*        INPUTS:  A = WA(NEXT AVAILABLE ITEM LOC)
*                 C = INDEX OF NEXT ITEM
*                 N = WA(NAME)
*        CALL:    BAL,SR4  RADD
*        RETURN:  A = WA(ITEM)
*                 C = INDEX OF ITEM
*                 N = WA(NAME)
*        OTHER REG'S:    I,J,K,X,Y
*
RADD     EQU      %
         PSW,R    *R0
         LI,R     2
RADDCOM  EQU      %
         MTW,0    PCW,P             CHECK INHIBIT GROWING STACK BIT
         BLZ      ERR2              ERROR IF SET
         LB,X     *N                COMPUTE SIZE OF ITEM IN WORDS
         SLS,X    -2
         AI,X     4                 X := 4+N/4 = SIZE OF ITEM
         LI,K     PRULH             COMPUTE NO. OF WORDS AVAILABLE
         LH,Y     *P,K
         LI,K     PRLH
         SH,Y     *P,K
         AND,Y    M16
         SLS,Y    1
         AI,Y     2                 Y := NO. WORDS AVAILABLE
         LW,J     X                 COMPUTE TOTAL SIZE OF MODIFIED STK
         LI,K     TRSH
         AH,J     *T,K              J := TOTAL SIZE
         CW,J     Y                 SEE IF THERE IS ENOUGH ROOM FOR IT
         BG       ERR2              ERROR IF NOT
         STH,J    *T,K              STORE TOTAL SIZE
         LW,K     A
         SLS,K    2                 K := BA(ITEM)
         STB,X    0,K               STORE ITEM LENGTH
         AI,K     RTB
         LW,X     R                 SET TYPE = 'REF' OR 'DEF'
         STB,X    0,K
         AI,K     RNCB-RTB
         LB,I     *N                FETCH NAME LENGTH
         STB,I    0,K               STORE IT
         LI,J     0
RA1      AI,K     1                 MOVE NAME INTO RFDSTK ITEM
         AI,J     1
         LB,X     *N,J
         STB,X    0,K
         BDR,I    RA1
         PLW,R    *R0
         B        *SR4
DADD     EQU      %
         PSW,R    *R0
         LI,R     0
         B        RADDCOM
         PAGE
*
*  ADD EXPRSTK ITEM
*
*        INPUT:   X = DEST WORD
*                 Y = 0 OR CORDEST
*                 N = WA(EXPR)
*                 C = INDEX OF REF (IF R<4)
*                 R = RES INDEX FOR REF ADDITION
*        CALL:    BAL,SR4  EADD
*        OTHER REG'S:    J,K,A
*
EADD     MTW,0    PCW,P             CHECK ' INHIBIT GROWING STACK' BIT
         BLZ      ERR               ERROR IF SET
         LI,K     PEULH             COMPUTE AVAILABLE SPACE
         LH,A     *P,K
         LI,K     PELH
         SH,A     *P,K
         AND,A    M16
         SLS,A    1
         AI,A     2                 A = NO. WORDS AVAILABLE
         LI,K     TESH              COMPUTE TOTAL SIZE OF UPDATED STK
         LH,J     *T,K
         AI,J     6                 SIZE OF NEW ITEM IS 6 WORDS
         CW,J     A                 SEE IF THERE IS ENOUGH SPACE
         BG       ERR               ERROR IF NOT
         STH,J    *T,K              STORE UPDATED SIZE
         LI,K     PELH              COMPUTE LOC OF NEW ITEM
         LH,A     *P,K
         SLS,A    1
         AI,A     -6
         AW,A     J                 A = WA(ITEM)
         SLS,Y    16                GENERATE 1ST WORD
         CI,R     4
         BL       EA1
         CI,C     0
         BLZ      EA2
         B        EA3
EA2      EQU      %
         LI,R     -X'20'
EA1      EQU      %
         AW,Y     R                     EXPRESSION STRING IS:
EA3      EQU      %
         AW,Y     L(X'06040120')        01, 20+R, 02.
         STW,Y    0,A
         LW,Y     Y02               2ND WORD
         STW,Y    1,A
         STW,X    2,A               3RD WORD = DEST
         LI,X     0
         STW,X    3,A               4TH WORD (RES) = 0
         LB,J     *N                COMPUTE LOC OF EXPR CONSTANT
         SLS,J    -2
         AI,J     1
         LW,Y     *N,J              MOVE CONSTANT TO 5TH WORD
         STW,Y    4,A
         STW,C    5,A               6TH WORD = REF INDEX
         B        *SR4
         PAGE
*
*  CHANGE CORE LOC, OR STACK CHANGE
*
*        INPUTS:  LO = DEST
*                 SN = SECTION NUMBER (0-2)
*                 V = VALUE
*                 M = MASK
*                 R = REL. TYPE (0-4, OR X'80000000'+REL DICT CODE)
*        CALL:    BAL,SR4  CHCORE
*        OTHER REG'S:    I,J
*        SUBR'S CALLED:  EDEST, USER'S CHANGE STACKING SUBR
*
CHCORE   PSW,SR4  *R0
         BAL,SR4  EDEST             REMOVE EXPRSTK REFS TO THIS LOC
CC5      LB,J     SN                GET SECTION NO.
         AI,J     P0LW
         LW,A     *P,J
         SLS,A    1                 A := SECTION LOC
         SLS,J    1
         AI,J     T0SLW-2*P0LW
         LCW,I    *T,J              I := -DA(SECTION BIAS)
         SLS,I    1
         AW,I     LO                I := ADDRESS REL.TO SECT.BIAS
         LI,LO1   X'1FFFF'
         LS,LO    I                 ADDR(LO) := ADDR(I)
         LI,M     -1                INITIALIZE MASK
         CI,LO    X'1FFFF'          SEE IF THIS IS A 'FIELD' DEST
         BLE      CC1               NO
         LB,I     LO                YES, FETCH FIELD LENGTH
         LH,J     LO                AND TERMINAL-BIT NO.
         SLS,J    -1
         AND,J    M7
         LCW,J    J
         CI,I     32
         BG       ERR1              ERROR IF FIELD LONGER THAN WORD
         SLS,M    0,I
         EOR,M    M32               GENERATE MASK OF LENGTH I
         AW,I     J
         CI,I     1
         BG       ERR1              ERROR IF FIELD OVERLAPS WD BNDRY
         SLD,V    31,J              SHIFT VALUE AND MASK
CC1      LW,J     PSW,P
         BEZ      CC2               SEE IF STACKING REQUESTED
         LW,R1    LO
         LD,R2    V
         BAL,SR4  0,J
         B        EXITL
CC2      EQU      %
         LW,J     R                 ESTABLISH REL DICT CODE IN V
         BLZ      CC3
         STS,V    *A,LO
         LB,V     DCODE,J
CC4      LB,K     SN
         AI,K     P0LW
         LW,Y     *P,K              GET DICT/SECTION LOCS
         LW,R2    LO                SAVE RELATIVE ADR.IN R2 FOR PASS-0
         LW,R3    V                 SAVE VALUE IN R3 FOR PASS-0
         LI,LO1   0
         SLD,LO   -1
         AND,LO   M16               LO := DA(REL ADR)
         SLD,LO   -2                SEPARATE INTO WORD NO. AND
         SLS,LO1  -27                  GROUP NO.
         LCW,LO1  LO1
         LI,M     X'F'
         SLD,V    28,LO1            POSITION DICT CODE AND MASK
         LH,Y     Y
         BEZ      EXITL             NO DICT
         SLS,Y    1                 Y := WA(DICT)
         STS,V    *Y,LO             STORE DICT CODE
         B        EXITL
CC3      LW,V     R                 R<0 SO USE DICT CODE IN R
         B        CC4
DCODE    DATA,1   0,1,2,3,X'E',0,0,0
         PAGE
*
*  ERROR EXITS
*
ERR1     PLW,R1   *R0               DUMMY PULL TO ADJUST STACK
ERR      LCI      7
         PLM,R5   *R0               RESTORE R5-R7, SR1-SR4
         LCI      8                 CC1 := 1
         B        *SR4              RETURN TO USER
ERR2     EQU      %
         PLW,R    *R0
         B        ERR
         PAGE
*
*
*  M O D I F Y   R O U T I N E
*
*
MODIFY   LCI      7
         PSM,R5   *R0               SAVE R5-R7, SR1-SR4
         LW,T     PTLW,P            SET UP TREE ADDRESS IN T
         LW,N     PCW,P             N := WA(CHANGE TABLE)
         LB,J     *N                FETCH FUNCTION BYTE
         CI,J     5
         BG       ERR
         EXU      MOD1,J
MOD1     B        EXP
         B        DEF
         B        MOD
         B        DICT
         B        ADDDE
         B        ABSREF
         PAGE
EXP      BAL,SR4  LOC               EVALUATE LOC EXPR FOR DEST
         BAL,SR4  EVALR             EVALUATE MAIN EXPR
         BAL,SR4  RADD              ADD REF ITEM IF NECESSARY
         B        EX1               EXPR NOT DEFINED
         LW,J     R                 EXPR DEFINED, DO CORE MODIFICATION
         LW,M     MASK,J
         B        MOD2
EX1      LW,X     LO                EXPR NOT DEFINED, ADD IT TO EXPRSTK
         LI,Y     CORDEST
         BAL,SR4  EADD
         B        MEXIT
         PAGE
DEF      AI,N     1                 SET TO WA(DEF NAME)
         MTB,0    *N
         BEZ      ERR               ERROR IF NO DEF NAME PRESENT
         BAL,SR4  RSEARCH           SEE IF IT IS IN RFDFSTK
         BAL,SR4  RADD              IF NOT, PUT IT IN
         LW,LO    A                 SAVE LOC OF DEF ITEM
         LB,X     *N                N:=WA(EXPR)-1
         SLS,X    -2
         AW,N     X
         BAL,SR4  EVALR             EVALUATE EXPR
         BAL,SR4  RADD              ADD REF IF NECESSARY
         B        DEF1
         STW,M    RRW,LO            STORE RES WORD,
         STW,V    RVW,LO               AND VALUE IN DEF ITEM
         LI,K     RTB               SET TYPE TO 'DEF'
         LI,X     0
         STB,X    *LO,K
         BAL,SR4  EFIX
         B        MEXIT
ADDDE    AI,N     1
         MTB,0    *N
         BEZ      ERR
         BAL,SR4  RSEARCH
         BAL,SR4  DADD
         LW,LO    A
         LB,X     *N
         SLS,X    -2
         AW,N     X
         BAL,SR4  EVALR
         BAL,SR4  RADD
         B        DEF1
         STW,M    RRW,LO
         STW,V    RVW,LO
         LI,K     RTB
         LI,X     0
         STB,X    *LO,K
         LW,N     PCW,P
         AI,N     1
         LB,X     *N
         SLS,X    -2
         AW,N     X
         AI,N     1
DEF1     LW,X     LO
         LI,LO    PRLH
         LH,LO    *P,LO
         SLS,LO   1
         SW,X     LO                X:= INDEX OF DEF ITEM
         LI,Y     0
         BAL,SR4  EADD
         B        MEXIT
         PAGE
MOD      BAL,SR4  LOC               EVALUATE LOC EXPR
         BAL,SR4  EVALR             EVALUATE CHANGE EXPR
         B        ERR               ERROR IF EXPRESSION NOT DEFINED
         B        ERR
         LW,I     R
         LW,M     MASK,I
         EOR,M    M32               MASK FOR NON-RELOCATED PART OF VAL
         LS,V     *N                FIX VALUE
         LI,M     -1                SET MASK TO STORE ENTIRE VALUE
MOD2     BAL,SR4  CHCORE
MEXIT    LCI      7                 MAIN EXIT FROM MODIFY
         PLM,R5   *R0               RESTORE R5-R7, SR1-SR4
         LCI      0                 CC1 := 0
         B        *SR4              RETURN TO USER
         PAGE
DICT     MTW,0    PSW,P             DO NOT CHANGE DICT IF
         BNEZ     MEXIT             USER-STACKING EQUESTED
         BAL,SR4  LOC               EVALUATE LOC EXPR
         AND,LO   M17               REMOVE FIELD INFO, IF ANY
         LW,R     PCW,P
         LW,R     *R                GET DICT CODE
         OR,R     Y8                SET R<0
         LI,M     0                 SET MASK=0 TO PREVENT CORE CHANGE
         LI,X     MEXIT             PUSH 'MEXIT' ONTO STACK
         PSW,X    *R0
         B        CC5               GO INTO 'CHCORE'
ABSREF   LW,R5    D2
         LW,D2    6,R6              GET REFDEF SIZE FROM TREE
         LH,D2    D2
         BAL,SR4  RINDEX
         LW,D1    D2                SET UP APPROPRIATE REG.'S FOR RADD
         LW,R3    R4
         STW,D1   2,R5              D1 = INDEX TO NEXT RFDF ENTRY IN STK
         LI,D2    3
         AW,D2    R5
         BAL,SR4  RADD              ADD THIS REF TO RFDFSTK
         LW,R5    PCW,R7
         LW,R3    8,R6              GET EXPRESSION WORD FROM TREE TABLE
         LH,R2    R3                GET SIZE
         AI,R2    -6                STEP BACK 1 ENTRY TO ELIMINATE
*                                   AN EXPRESSION ENTRY FOR THE ADEF ONLY
         INT,R3   R3                STACK BASE ADDRESS
         SLS,R3   1                 CONVERT IT TO WORDS
         AW,R3    R2
         LW,SR1   L(X'6042000')     1ST WORD FOR THIS ENTRY
         LW,D2    0,R5              GET RESOLUTION
         SLS,D2   8                 STRIP OFF REF TYPE
         AW,SR1   D2                MERGE INTO 1ST WORD CODE
         STW,SR1  0,R3              STORE IN ENTRY
         LW,SR1   Y02               SET UP CONTROL BYTE AND
         STW,SR1  1,R3              STORE IN 2ND WORD
         LW,SR1   1,R5              GET DISPLACEMENT TO ABS DEF
         STW,SR1  2,R3              STORE IN 3RD WORD
         LI,SR1   0                 DESTINATION IS AN ABSOLUTE DEF
         STW,SR1  3,R3              THEREFORE 4TH WORD = 0
         LW,SR1   2,R5              GET PTR TO CORRESPONDING REF IN
         STW,SR1  4,R3              RFDFSTK AND STORE IN 5TH WOD
         LI,SR3   -1
         STW,SR3  5,R3              STORE -1 INTO 5TH WORD
         B        MEXIT

