*                 CATALOG NO. 704898 - M:SYSMOD (SYSGEN MODIFY)
         SYSTEM   SIG7FDP
         DEF      MODIFY
         REF      M:LL,LLBUF,CSEGNO,SAVESEG
         REF      CLRBUF
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
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
P0DH     EQU      8
P0LH     EQU      9
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
         CSECT    1
*  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        ERMSG             WARN USER MODIFY IGNORED
         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
         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     4
         BG       ERR
         EXU      MOD1,J
MOD1     B        EXP
         B        DEF
         B        MOD
         B        DICT
         B        ADDDE
         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'
         PAGE
ERMSG    EQU      %                 NOTIFY USER THAT MODIFY
         LCI      6                 COMMAND HAS BEEN IGNORED
         PSM,T    *R0               BECAUSE SYMBOL REFERENCED
         LB,T     *N                DOES NOT APPEAR IN REF/DEF
         AI,T     4                 STACK OF SEGMENT NAMED.
         SLS,T    -2                # WDS TEXTC NAME OCCUPIES
         LW,P     T
         LW,Y     N
         LW,SR4   =X'FFFFFF'
         LW,R     *Y
         CS,R     LLBUF+6
         BNE      MOVSYM
         BDR,T    ERMSG4
         B        NOMSG
ERMSG4   LW,X     *N,T              SUPPRESS MSG IF SYMBOL
         CW,X     LLBUF+6,T           WAS JUST PRINTED
         BNE      MOVSYM
         BDR,T    ERMSG4
         B        NOMSG
MOVSYM   LCI      3
         PSM,P    *R0
         BAL,SR4  CLRBUF
         LCI      3
         PLM,P    *R0
         AI,Y     -1
MOVSYM4  LW,X     *Y,P
         STW,X    LLBUF+5,P
         BDR,P    MOVSYM4
         LCI      6
         LM,T     MODMSG
         STM,T    LLBUF
         LI,X     X'40'
         STB,X    LLBUF+6           SET VFC CHAR ACCORDING
         LW,P     CSEGNO            TO WHETHER SEGMENT HAS
         CW,P     SAVESEG           CHANGED
         BE       %+3
         STW,P    SAVESEG
         LI,X     X'F1'
         STB,X    LLBUF
         CAL1,1   WRTMSG
NOMSG    EQU      %
         LCI      6
         PLM,T    *R0
         B        EXITL
MODMSG   DATA     X'F1E4D5C1'
         TEXT     'BLE TO MODIFY LOC   '
WRTMSG   GEN,8,24 X'11',M:LL
         DATA     X'30000010',LLBUF,112
         END

