'HEAD'  SETUP
C     EDIT DATE   26JAN79  11:13
C     SOURCE FILE SETUPJHP.FS
C     AUTHOR      J.H.PERINE
C     CLUSTER     18
      'OUTFILE'   SETUPJHP.FR
C     NAME     SETUP
C     MODULE#
C     PURPOSE  GENERATE SETUP CODE AND PROPER INSTRUCTION TO
C              PERFORM THE REQUESTED OPERATION.
C     CALL     SETUP (FUNC, INDX)
C                 FUNC = OPERATION DESCRIPTOR (FROM OPINXJHP.IN)
C                 INDX = STACK INDEX
C     OUTPUT   1. SETUP CODE AS REQUIRED THROUGH 'GEN' & 'BLDBLK'
C              2. STACK ENTRIES MAY BE MODIFIED

C                 ALSO 'SUBOP' AND 'WFSOP'
      SUBROUTINE  SETUP (FUNC, INDX)
      INTEGER     FUNC, INDX
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFE.IN, // KEEP IT
      'INCLUDE'   STKDEFF.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,
      INTEGER     CTN, CTS, CTB
C     EXTERNALS
      INTEGER     NLOPS
      LOGICAL     ZPTST, NLTEST
      EXTERNAL    OLPLO, OLPSB, OLPLC
      'EJECT'
      SOPC = LDAZP
      SWF = WF5
      SWFOPN = WF7
      SSUBOP = LDYZP
      SWFSUB = WF5
      SETSTX = INDX
      SETNLX = NAMEX (SETSTX)
C     CHECK FOR NO OPERAND
      'IF' (SETNLX .EQ. 0)
         CALL FAULTP (10)
         SETNLX = NULLX
         'ENDIF'
      STMODE = MODE (SETSTX)
      SSUBX = SUBX (SETSTX)
      SSUBXM = SUBXM (SETSTX)
      STBIAS = BIAS (SETSTX)
      SSUBXB = 0
      STLOC = LOCFLG (SETSTX) .NE. 0
C     SHORT CIRCUIT IF REGISTER, SET FOR RECOVERY FROM CT
10    'IF' (NLTEST (SETNLX, REGBIT))
C        SET ACTIVE REGISTER IF NOT SET
         TS1 = NLOPS (REGNUM, SETNLX)
         'IF' (STATUS (TS1) .EQ. 0 .AND. FUNC .NE. STAINX)
            STATUS (TS1) = SETSTX
            ACTLO = TS1
            'IF' (STMODE .EQ. DPMODE)
               ACTLO = XREG
               ACTHI = AREG
               'ENDIF'
            'ENDIF'
         GO TO 1
         'ENDIF'
      ZPFLAG = ZPTST (SETNLX, STBIAS)
C     SUBSCRIPTED?
      IF ( SSUBX .NE. 0 ) GO TO 6000
C     PROCESS PARAM [N] AND 'LOC' PARAM [N]
      IF (NLTEST (SETNLX, PBIT)) GO TO 5000
C     PROCESS UNSUBSCRIPTED GROUP1
C     'LOC' REQUESTED?
      'IF' (STLOC)
         SOPC = LDAIMM
         SWFOPN = WF12
         GO TO 1
         'ENDIF'
C     CHECK FOR UNSUBSCRIPTED 'TP' USAGE
C
      IF (NLTEST (SETNLX, TPLBIT)) CALL FAULTP (49)
      'EJECT'
C     NOT A LOC - CONSTANT?
      'IF' (NLTEST (SETNLX, CBIT))
C        HAVE A CONSTANT
         SOPC = LDAIMM
         IF ( STMODE .EQ. DPMODE ) SWFOPN = WF12
         STBIAS = NLOPS (CVALUE, SETNLX)
         SETNLX = NULLX
         'ELSE'
C        NOT A CONSTANT - SIMPLE LOAD
         'IF' (.NOT. ZPFLAG)
            SOPC = LDAABS
            SWF = WF8
            'ENDIF'
         'ENDIF'
C     GENERAL EXIT, RESET THE STACK
1     CALL STSET (SETSTX, SETNLX, STMODE, STBIAS, ^
                  SOPC,   SWF,    SWFOPN)
      SUBX  (SETSTX) = SSUBX
      SUBXB (SETSTX) = SSUBXB
      SUBXM (SETSTX) = SSUBXM
      SUBOP (SETSTX) = SSUBOP
      WFSOP (SETSTX) = SWFSUB
      CALL DUMST ('SETX')
      RETURN
      'EJECT'
C     UNSUBSCRIPTED PARAMETER AND 'LOC' PARAMETER
5000  CALL OVLOD (OLPLO)
      'IF' (.NOT. STLOC)
C        NOT A LOC, CHECK FOR BIAS < 255
         'IF' (STBIAS .LT. 255 .AND. STBIAS .GE. 0)
            CALL PLOAD (SETNLX, STMODE, 1, TS1)     // 'LOC' P -> FL
            SETNLX = FLS (TS1)
            SSUBX = NULLX
            GO TO 6680
            'ENDIF'
C        BIAS IS 'DP'
         CALL PLOAD (SETNLX, STMODE, 2, TS1)        // 'LOC' P -> AREG
         SETNLX = NULLX
         SSUBX = REGS (AREG)
         GO TO 6210
         'ENDIF'
C     'LOC' PARAM
      CALL PLOAD (SETNLX, STMODE, 0, TS1)           // TS1 = P NUMBER
      'IF' (FLSAVE (TS1) .EQ. 0)
         SOPC = LDAABS
         SWF = WF8
         'ELSE'
         SETNLX = FLS (TS1)
         'ENDIF'
      GO TO 1
'EJECT'
C     PROCESS GROUP1 SUBSCRIPT
C     IDENTIFY CHARACTERISTICS OF SUBX
C     A/X/Y=1, 'DP'A=2, S=3, D=4, P=5, 'DP' P=6
6000  TS1 = 3
      IF (NLTEST (SSUBX, REGBIT)) TS1 = 1
      IF (NLTEST (SSUBX, PBIT)) TS1 = 5
      IF ( SSUBXM .EQ. DPMODE ) TS1 = TS1 + 1
      IF (NLTEST (SSUBX, TPLBIT)) CALL FAULTP (49)
C     BASIC DIVISION: NAMEX IS S/D, P, OR LOC
      IF (STLOC) GO TO 8000
      IF (NLTEST (SETNLX, PBIT)) GO TO 7000
C     NOT A PARAMETER OR LOC - PROCESS S/D
      GO TO (6100, 6200, 6300, 6400, 6500, 6500),TS1
C     S [REGISTER + N],  D [REGISTER + N]
6100  SOPC = LDAABY
      SWF = WF8
      SWFOPN = WF7
      GO TO 1
C     S ['DP' AREG + N],  D ['DP' AREG + N]
C     LOOK FOR SPECIAL CASE OF 'LOC' S + N IN ZP
6200  'IF' (STAREG .EQ. 0)
         STAREG = SETSTX + STKSIZ
         ACTLO = XREG
         ACTHI = AREG
         'ENDIF'
      'IF' ( ZPTST (SETNLX, STBIAS) )
C        CAN SHORTCUT; GOES TO  (CT), 'LOC' S + N
         SSUBX = SETNLX
         SSUBXB = STBIAS
         CALL STSET (SLEFT, REGS (AREG), DPMODE, 0, 0, 0, 0)
         'ELSE'
C        DO IT THE HARD WAY
C        'LOC' S + N + 'DP' AREG ->  'DP' AREG
6210     CALL STSET (SRIGHT, SETNLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         CALL STSET (SLEFT, SSUBX, DPMODE, 0, ^
                     LDAZP, WF5, WF7)
         STAREG = SLEFT
         CALL GEN (PLUS, SLEFT, SRIGHT)
         SSUBX = NULLX
         'ENDIF'
      CTN = 0       // DON'T KNOW WHAT WAS IN THE REGISTER
      GO TO 6600
      'EJECT'
C     S [S' + N],  D [S' + N]
6300  'IF' (.NOT. ZPTST (SSUBX, 0) )
         SSUBOP = LDYABS
         SWFSUB = WF8
         'ENDIF'
      GO TO 6100
C     S [D' + N], D [D' + N]
C     SPECIAL CASE IF D IS IN ZP AND 'LOC' S + N IS ZP
6400  'IF' ( ZPTST (SSUBX, 0) .AND. ZPFLAG)
C        SHORTCUT - DONT NEED CT; USE (D), 'LOC' S + N
         TS1 = SSUBX
         SSUBX = SETNLX
         SETNLX = TS1
         GO TO 6680
         'ENDIF'
      'EJECT'
C     ADDRESS SETUP REQUIRES USE OF CT AND LDA, @YREG
      CTN = NULLX
      CTS = SSUBX
      CTB = 0
      CALL STSET (SLEFT, CTS, DPMODE, 0, LDAABS, WF8, WF7)
      'IF' (ZPTST (SSUBX, 0))   // INDEX IN ZP?
         LOPC = LDAZP
         LWFOP = WF5
         'ENDIF'
      'IF' (ZPFLAG)               // 'LOC' S + N IN ZP
         SSUBX = SETNLX
         SSUBXB = STBIAS
         CALL REGSRC (3, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
         IF (SCTN .NE. 0) GO TO 6650
         CALL GEN (COM + 1, SLEFT, SLEFT)
         GO TO 6600
         'ENDIF'
      'IF' (ZPTST (SETNLX, 0))    // 'LOC' S IN ZP
         SSUBX = SETNLX
         SSUBXB = 0
         CTB = STBIAS
         GO TO 6420
         'ENDIF'
      CTN = SETNLX
      'IF' (STBIAS .GE. 0 .AND. STBIAS .LT. 255)
         SSUBX = NULLX
         SSUBXB = STBIAS
         GO TO 6420
         'ENDIF'
      SSUBX = NULLX
      SSUBXB = 0
      CTB = STBIAS
6420  CALL REGSRC (3, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
      IF (SCTN .NE. 0) GO TO 6650
      CALL STSET (SRIGHT, CTN, DPMODE, CTB, LDAIMM, WF5, WF12)
      CALL GEN (PLUS, SLEFT, SRIGHT)
      GO TO 6600
      'EJECT'
C     PARAMETER SUBSCRIPT -- BECOMES AREG
6500  CALL OVLOD (OLPLO)
      CALL PLOAD (SSUBX, SSUBXM, 3, TS1)   // P -> AREG
      SSUBX = REGS (AREG)
      STAREG = SETSTX + STKSIZ
      CALL DUMST ('PLOD')
      GO TO 6000
C     'DP' AREG -> CT
6600  STAREG = SLEFT
      CALL REGMAN (SAVREG, AREG, SCTN)
C     SETUP FOR @CT
6650  SETNLX = REGS (SCTN)
      CALL REGSRC (6, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
      SSUBOP = LDYIMM
      STATUS (SCTN) = SETSTX
      GO TO 6700
6680  SSUBXB = STBIAS
      SSUBOP = LDYIMM
C     [ZP + Y]
6700  SOPC = LDAINY
      SWF = WF5
      SWFOPN = WF7
      STBIAS = 0
      GO TO 1
C     PARAMETER [SOMETHING]
7000  CALL OVLOD (OLPSB)
      CALL PARSUB
      GO TO 6700
C     'LOC' SOMETHING [SOMETHING ELSE]
8000  'IF' (NLOPS (NAMAT0, SETNLX) .EQ. 0 .AND. STBIAS .EQ. 0)
C        'LOC' [X] SAME AS X
         SETNLX = SSUBX
         STMODE = SSUBXM
         SSUBX  = 0
         STLOC  = .FALSE.
         GO TO 10
         'ENDIF'
      CALL OVLOD (OLPLC)
      CALL PARLOC
      GO TO 1
      END
      'OUTFILE'   PLOADFTM.FR
N     OVERLAY     OLPLO
      SUBROUTINE  PLOAD (INDEX, INMODE, LOAD, PARNO)
C     LOAD = 0    RETURN PARAMETER NUMBER
C            1    MOVE ADDRESS OF PARAM TO FL
C            2    MOVE ADDRESS TO 'DP' AREG
C            3    MOVE VALUE TO AREG ('SP'/'DP')
C
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   BRACEFTM.IN,
      INTEGER     INDEX, INMODE, LOAD, PARNO, STEMP, TS1, TS2
P     INTEGER     PAD (575)   // FOR PDP-11 OVERLAY SIZING
      PARNO = (NLOC (INDEX) - NLOC (PARSAV))/2 + 1
      IF (LOAD .EQ. 0) RETURN
      'IF' (FLSAVE (PARNO) .NE. 0)
         IF (LOAD .EQ. 1) RETURN    // LOAD INTO FL NOT NEEDED
         CALL REGMAN (SAVREG, AREG, STEMP)   // NEED AREG, SAVE IT
         IF (LOAD .EQ. 3) GOTO 100      //LOAD DIRECTLY THROUTH FL
         CALL BLDOP (165, WF5, 0, FLS (PARNO), WF7)  //LDA ZP
         CALL BLDOP (166, WF5, 1, FLS (PARNO), WF7)  //LDX ZP HI
         'ELSE'
         CALL REGMAN (SAVREG, AREG, STEMP)
         CALL BLDOP (173, WF8, 0, INDEX, WF7)    //LDA ABS
         CALL BLDOP (174, WF8, 1, INDEX, WF7)    //LDX ABS HI
         'ENDIF'
      ACTHI = XREG
      ACTLO = AREG
      IF (LOAD .EQ. 2) RETURN
      CALL BLDOP (133, WF5, 0, FLS (PARNO), WF7)   //STA ZP
      CALL BLDOP (134, WF5, 1, FLS (PARNO), WF7)   //STX ZP HI
      FLSAVE (PARNO) = 1
      ACTHI = 0
      ACTLO = 0
      IF (LOAD .EQ. 1) RETURN
      'EJECT'
100   IF (STYREG .NE. 0) ^
         CALL REGMAN (SAVREG, YREG, STEMP)
      'IF' (INMODE .EQ. DPMODE)
C        DO HI BYTE FIRST, TRANSFER TO XREG
         STEMP = 160
         TS1 = WF5
         TS2 = 1
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF12)   //LDY IMM 1
         CALL BLDOP (177, WF5, 0, FLS (PARNO), WF7)  //LDA @FL,Y
         CALL BLDBLK (170, WF4)  //TAX
         STEMP = 160
         TS1 = WF5
         TS2 = 0
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF7)  //DEY
         ACTHI = XREG
         'ELSE'
         STEMP = 160
         TS1 = WF5
         TS2 = 0
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF12)  //LDY IMM 0
         'ENDIF'
      CALL BLDOP (177, WF5, 0, FLS (PARNO), WF7)   //LDA @FL, Y
      ACTLO = AREG
      RETURN
      END
      'OUTFILE'   PARSUBFTM.FR
N     OVERLAY     OLPSB
      SUBROUTINE  PARSUB
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,   // KEEP IT
      'INCLUDE'   STKDEFE.IN,   // KEEP IT
      'INCLUDE'   STKDEFF.IN,   // KEEP IT
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,
      INTEGER     TS
      LOGICAL     ZPTST,  NLTEST
      INTEGER     NLOPS
      EXTERNAL    OLPLO
      'EJECT'
C     PROCESS SUBSCRIPTED PARAMETER (NOT 'LOC')
C
      'IF' (NLTEST (SSUBX, PBIT))
         CALL OVLOD (OLPLO)
         CALL PLOAD (SSUBX, SSUBXM, 3, TS1)   // P -> AREG
         SSUBX = REGS (AREG)
         'ENDIF'
      'IF' (SSUBXM .EQ. SPMODE)
         'IF' (NLTEST (SSUBX, REGBIT))
            TS = NLOPS (REGNUM, SSUBX)
            STATUS (TS) = SETSTX + STKSIZ
            ACTLO = TS
            IF (TS .EQ. XREG)  CALL REGMAN (SAVREG, XREG, TS)
            'ELSE'
            'IF' (.NOT.ZPTST (SSUBX, 0))
               SSUBOP = LDYABS
               SWFSUB = WF8
               'ENDIF'
            'ENDIF'
         'IF' (STBIAS .NE. 0)
C           ADD BIAS TO 'LOC' P  -- USE FL IF POSSIBLE
            CALL STSET (SLEFT, SETNLX, DPMODE, 0, ^
                        LDAABS, WF8, WF7)
            CALL OVLOD (OLPLO)
            CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
            'IF' (FLSAVE (TS1) .NE. 0)
C              USE FL
               LNAMEX = FLS (TS1)
               LOPC = LDAZP
               LWFOP = WF5
               'ENDIF'
            CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                        LDAIMM, WF5, WF12)
            CALL GEN (PLUS, SLEFT, SRIGHT)
            STBIAS = 0
            STAREG = SLEFT
            CALL REGMAN (SAVREG, AREG, TS)
            SETNLX = REGS (TS)
            STATUS (TS) = SETSTX
            'ELSE'
            CALL OVLOD (OLPLO)
            CALL PLOAD (SETNLX, STMODE, 1, TS)          // 'LOC' P -> FL
            SETNLX = FLS (TS)
            'ENDIF'
         RETURN
         'ENDIF'
      'EJECT'
C     P ['DP' ANYTHING]
      CALL STSET (SLEFT, SSUBX, DPMODE, 0, ^
                  LDAZP, WF5, WF7)
      IF (SSUBX .EQ. REGS (AREG))  STAREG = SLEFT
      'IF' (NLTEST (SSUBX, REGBIT) ^
            .AND. .NOT. ZPTST (SSUBX, 0))
C        P [D], P [D+K]
         LOPC = LDAABS
         LWFOP = WF8
         'ENDIF'
      CALL STSET (SRIGHT, SETNLX, DPMODE, 0, ^
                  LDAABS, WF8, WF7)
      CALL OVLOD (OLPLO)
      CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
      'IF' (FLSAVE (TS1) .NE. 0)
C        USE ADDRESS OF P FROM FL
         LNAMEX = FLS (TS1)
         LOPC = LDAZP
         LWFOP = WF5
         'ENDIF'
      CALL GEN (PLUS, SLEFT, SRIGHT)
      STAREG = SLEFT
      'IF' (STBIAS .LT. 255 .AND. STBIAS .GE. 0)
         SSUBXB = STBIAS
         'ELSE'
         CALL STSET (SLEFT, REGS (AREG), DPMODE, 0, ^
                     LDAZP, WF5, WF7)
         CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         CALL GEN (PLUS, SLEFT, SRIGHT)
         'ENDIF'
      CALL REGMAN (SAVREG, AREG, TS)
      SETNLX = REGS (TS)
      STATUS (TS) = SETSTX
      SSUBX = NULLX
      SSUBOP = LDYIMM
      RETURN
      END
      'OUTFILE'   PARLOCFTM.FR
N     OVERLAY     OLPLC
      SUBROUTINE  PARLOC
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,   // KEEP IT
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFE.IN,   // KEEP IT
      'INCLUDE'   STKDEFF.IN,   // KEEP IT
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,
      LOGICAL     ZPTST,  NLTEST
      INTEGER     NLOPS
      EXTERNAL    OLPLO

      CALL CLRSTK (SLEFT)
C     SUBSCRIPTED LOC - CHECK FOR [PARAM]
      'IF' (NLTEST (SSUBX, PBIT))
         CALL OVLOD (OLPLO)
         CALL PLOAD (SSUBX, SSUBXM, 3, TS1)    // P -> AREG
         SSUBX = REGS (AREG)
         'ENDIF'
      LOPC = LDAZP
      LWFOP = WF5
      'IF' (NLTEST (SSUBX, REGBIT))
         'IF' (SSUBX .NE. REGS (AREG))
            CALL REGMAN (SAVREG, AREG, TS2)
C           MOVE REG TO 'DP' AREG   ******
            'ENDIF'
         STAREG = SLEFT
         'IF' (ACTLO .EQ. 0)
            'IF' (SSUBXM .EQ. SPMODE)
               ACTLO = AREG
               'ELSE'
               ACTHI = AREG
               ACTLO = XREG
               'ENDIF'
            'ENDIF'
         'ELSE'
         'IF' (.NOT. ZPTST (SSUBX, 0))
            LOPC = LDAABS
            LWFOP = WF8
            'ENDIF'
         'ENDIF'
      'EJECT'
      LNAMEX = SSUBX
      LMODE = SSUBXM
      LWFOPN = WF7
      'IF' (NLTEST (SETNLX, PBIT))
         'IF' (STBIAS .NE. 0)
            CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                        LDAIMM, WF5, WF12)
            CALL GEN (PLUS, SLEFT, SRIGHT)
            STAREG = SLEFT
            STBIAS = 0
            CALL CLRSTK (SRIGHT)
            LNAMEX = REGS (AREG)
            LMODE = DPMODE
            LOPC = LDAZP
            LWFOP = WF5
            'ENDIF'
         CALL OVLOD (OLPLO)
         CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
         'IF' (FLSAVE (TS1) .NE. 0)
            RNAMEX = FLS (TS1)
            ROPC = LDAZP
            RWFOP = WF5
            'ELSE'
            ROPC = LDAABS
            RWFOP = WF8
            RNAMEX = SETNLX
            'ENDIF'
         RMODE = STMODE
         RWFOPN = WF7
         'ELSE'
         CALL STSET (SRIGHT, SETNLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         'ENDIF'
      CALL GEN (PLUS, SLEFT, SRIGHT)
      STAREG = SETSTX
      STXREG = 0
      SETNLX = REGS (AREG)
      STMODE = DPMODE
      SSUBX = 0
      LOCFLG (SETSTX) = 0
      SOPC = LDAZP
      SWF = WF5
      SWFOPN = WF7
      RETURN
      END
      'OUTFILE' STSETFTM.FR
      SUBROUTINE STSET (ROW, SNAMEX, SMODE, SBIAST, SOPCOD, ^
                        SWFOP, SWFOPN)
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   STKDEFF.IN,
      INTEGER ROW, SNAMEX, SMODE, SBIAST, SOPCOD
      INTEGER SWFOP, SWFOPN
      CALL CLRSTK (ROW)
      NAMEX (ROW) = SNAMEX
      MODE  (ROW) = SMODE
      BIAS  (ROW) = SBIAST
      OPCODE(ROW) = SOPCOD
      WFOP  (ROW) = SWFOP
      WFOPND(ROW) = SWFOPN
      RETURN
      END
      'OUTFILE'   ZPTSTJHP.FR
C     NAME     ZPTST
C     MODULE#
C     PURPOSE  SEE IF A NAME LIST ENTRY IS ZERO PAGE ADDRESSABLE
C     CALL     ZPTST (ZNLX, ZBIAS)
C                 ZNLX  = NAME LIST INDEX
C                 ZBIAS = CONSTANT BIAS
C     OUTPUT   FUNCTION VALUE .TRUE. IF ZP IS OK
      LOGICAL FUNCTION ZPTST (ZNLX, ZBIAS)
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      INTEGER     ZNLX, ZBIAS, TS1, TS2
      INTEGER     NLOPS
      LOGICAL     NLTEST
      ZPTST = .FALSE.
C     IS NAME DEFINED?
      'IF' ( NLOPS (DFINED, ZNLX) .NE. 0 )
C        YES - CHECK LOCATION
         TS1 = NLOPS (NLXLCI, ZNLX)
         TS2 = NLOPS (NAMLOC, ZNLX) + ZBIAS
C        CHECK LOW CORE ADDRESS
         IF ( ( TS1 .EQ. ZREL .OR. TS1 .EQ. ABSLC ) ^
                .AND. TS2 .GE. 0 .AND. TS2 .LT. 255 ) ZPTST = .TRUE.
C        NOT DEFINED - CHECK EXTD
         'ELSE'
         IF (NLTEST (ZNLX, EXDBIT) .AND. ZBIAS .LT. 256) ^
            ZPTST = .TRUE.
         'ENDIF'
      RETURN
      END