'HEAD'  NOUN LIST PROCESSING
C     EDIT DATE   14JAN79  09:51
C     SOURCE FILE NOUNSAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     2
      'OUTFILE'   DIMENAJH.FR
N     OVERLAY     OLNOU
      SUBROUTINE  DIMEN
C     EDIT DATE   14JAN79  09:51
C     SOURCE FILE NOUNSAJH.FS
C     AUTHOR      A. J. HOWARD
      INTEGER     TS, IERR
      INTEGER     NBX, NBSTK (20)
      INTEGER     IOTS, IOTS1, INITLC
      INTEGER     MODETS, MTS1
      INTEGER     OLDMOD, OLDTPL
      INTEGER     REDEF
      INTEGER     FIRST, LAST, COUNT
      INTEGER     NLOPS, CQVAL, SNMLST
      LOGICAL     NLTEST
      EXTERNAL    OLCRU
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE'   LEVELSAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   LCONSTAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   XNAMEAJH.IN,
      'EJECT'
C     PROCESS NOUN LIST DRIVER
C
      FCHRTS = 1
      LOGICF = 0
      QVALUE = 0
      BIAS (OPX) = 0
      LEVELB = NLEVEL
      CALL RBOTH (NOUNLC)
      ENDOK = .TRUE.
1     NBX = 5
      NBSTK (NBX-4) = 0
      NBSTK (NBX-3) = STDMD
      NBSTK (NBX-2) = LODLCI
      NBSTK (NBX-1) = LCI
      OLDMOD = STDMD
      OLDTPL = 0
C     NOUN DEFINITION
2     TPFLAG = OLDTPL
      DEFMOD = OLDMOD
      FNLX = 0
      IOTYPE = 0
      CALL NEXP
      IF (CONEND) RETURN
      ENDOK = .FALSE.
C     TEST NEXT OP
3     IF (NEXTOP .EQ. EQUAL) GO TO 40
      IF (NEXTOP .GT. LBRACE) GO TO 80
      GO TO (99, ^
             10, ^ // ,
             10, ^ // ;
             85, ^ // .
             20, ^ // :
             80, ^ // 'FOR'
             80, ^ // 'DO'
             80, ^ // 'WHILE'
             10, ^ // 'RBR'
             30),^ // 'LBR'
         NEXTOP
      'EJECT'
C     DEFINE NOUN,  NEXTOP IS , ; 'RBR'
10    NLX = NAMEX (OPX)
      'IF' (NLX .NE. 0)
         CALL SMLCV
         CALL ADJLOC (BIAS (OPX))
         'ENDIF'
C     EXIT SWITCH
15    GO TO (99, ^
              2, ^ // ,
             90, ^ // ;
             99, ^ // .
             99, ^ // :
             99, ^ // 'FOR'
             80, ^ // 'DO'
             99, ^ // 'WHILE'
             60),^ // 'RBR'
         NEXTOP
C     DIMENSION ERROR
80    CALL FAULTP (4)
      GO TO 2
C     FC ERR
85    IF (NAMEX (OPX) .NE. 0) GO TO 80
      CALL FAULTP (79)
C     NOUN EXIT
90    'IF' (NBX .NE. 5)
         CALL FAULTP (12)
C     *********PUT IN SOME BRACES
         GOTO 1
         'ENDIF'
      'IF' (LCI .EQ. NOUNLC)
         CALL RBOTH (CODE)
         GO TO 1
         'ENDIF'
      IOTYPE = 0
      RETURN
99    CALL FATAL (6)
      RETURN
      'EJECT'
C
C     NOUN COLON
20    'IF' (NAMEX (OPX) .EQ. NULLX)
C     [NUMBER]: 'LBR'
         LCTAB (ABSLC) = BIAS (OPX)
         CALL RBOTH (ABSLC)
         CALL ADVAN
         IF (NEXTOP .NE. LBRACE) CALL FAULTP (58)
         GO TO 35
         'ENDIF'
      CALL PEEK
      'IF' (PEEKS .EQ. LBK)
C        NAME: [XAAAAA]       NAME RENAME FOR EXTERNAL
         CALL FNZS
         CALL FNZS
         NLX = 0
         'IF' (PSYMB .NE. RBK .AND. PSYMB .NE. MULT)
            CALL RDNAME (PERIOD)
            NLX = SNMLST (DUMMY)
            'ENDIF'
         TS = NAMEX (OPX)
         CALL NLVAL (TS, ISHFT (DEFMOD, MSHIFT), MDMASK)
         'IF' (IOTYPE .EQ. ST)
            CALL NLSET (TS, STRBIT)
            'ENDIF'
         NLOC (TS) = -1
         'IF' (NLX .NE. 0 .AND. NLX .NE. TS)
            XNAME (XNX) = TS
            XNAME (XNX+1) = NLX
            XNX = XNX + 2
            'IF' (XNX .GT. XNXMAX)
               CALL FAULTP (13)
               XNX = XNXMAX
               'ENDIF'
            'ENDIF'
         CALL LIST (LEXEQU, TS, NLX)
         'IF' (PSYMB .EQ. MULT)
            IF (NLX .NE. 0) CALL NLSET (NLX, EXDBIT)
            CALL FNZS
            CALL NLSET (NAMEX (OPX), EXDBIT)
            'ENDIF'
         CALL FNZS
         GO TO 2
         'ENDIF'
      'EJECT'
C     MORE NOUN COLON PROCESSING
C     SAVE THE REAL NAME LIST INDEX
      NAMEX (OPX) = FNLX
      OSTACK (OPX) = 1026
      OPX = OPX + 1
      REDEF = PEEKS
      IF (REDEF .EQ. COLON) CALL FNZS
      MODETS = DEFMOD
      DEFMOD = OLDMOD
      TPFLAG = OLDTPL
      IOTS = IOTYPE
      IOTYPE = 0
      CALL NEXP
      OPX = OPX - 1
      'IF' (NEXTOP .EQ. LBRACE)
C        COMMON BLOCK NAME
         'DOLOOP' I = FBLOCK, CBX
            'IF' (CBTAB (I) .EQ. NAMEX (OPX))
               CALL RBOTH (I)
               GO TO 35
               'ENDIF'
            'END'
         'IF' (CBX .GE. ZREL)
            CALL FAULTP (57)
            GO TO 35
            'ENDIF'
         CALL RBOTH (CBX)
         NLX = NAMEX (OPX)
         CBTAB (CBX) = NLX
         FNLX = NLX
         CBX = CBX + 1
         CALL NDEFN
         GO TO 35
         'ENDIF'
      'EJECT'
C
C     EQUIVALENCE PROCESSING
C
      MTS1 = DEFMOD
      DEFMOD = MODETS
      IOTS1 = IOTYPE
      IOTYPE = IOTS
      IF (BIAS (OPX) .EQ. 0) BIAS (OPX) = 1
      OPTOPX = NAMEX (OPX+1)
      IF (OPTOPX .EQ. 0) GO TO 80
      'IF' (NLTEST (OPTOPX, CBIT))
C        NAME: NUMBER
         NLX = NAMEX (OPX)
         'IF' ( NLOPS (DFINED, NLX) .NE. 0 .AND. REDEF .NE. COLON)
            CALL FAULTP (18)
            GO TO 2
            'ENDIF'
         NLOC (NLX) = OPTOPX
         CALL NLSET (NLX, ISHFT (DEFMOD, MSHIFT) + CBIT + LCMASK)
         'IF' (REDEF .NE. COLON)
C           PICKUP EQUATE AFTER USE
            IF (NLTEST (NLX, USEBIT)) CALL NLSET (OPTOPX, USEBIT)
            'ENDIF'
         CALL LIST (LNLEQU, NLX, OPTOPX)
         GO TO 15
         'ENDIF'
C     NAME: NAME
      NLX = NAMEX (OPX)
      CALL NDEFN
      'IF' (NAMEX (OPX) .NE. NAMEX (OPX+1))
         DEFMOD = MTS1
         IOTYPE = IOTS1
         'ENDIF'
      NAMEX (OPX) = NAMEX (OPX+1)
      SUBX  (OPX) = SUBX  (OPX+1)
      BIAS  (OPX) = BIAS  (OPX+1)
      GO TO 3
      'EJECT'
C     NOUN LEFT BRACE
30    'IF' (ZFLAG)
         CALL RBOTH (ZREL)
         ZFLAG = .FALSE.
         'ELSE'
         IF (.NOT. MSEEN) CALL RBOTH (COMLOC)
         'ENDIF'
C     STACK BRACE INFORMATION
35    IF (BIAS (OPX) .NE. 0) CALL FAULTP (5)
      NBX = NBX + 4
      NBSTK (NBX-4) = TPFLAG
      NBSTK (NBX-3) = DEFMOD
      NBSTK (NBX-2) = LODLCI
      NBSTK (NBX-1) = LCI
      OLDMOD = DEFMOD
      OLDTPL = TPFLAG
      GO TO 2
      'EJECT'
C     INIT NOUN
40    NLX = NAMEX (OPX)
      LABNLX = NLX
      'IF' (LABNLX .EQ. 0)
         CALL FAULTP (4)
         GO TO 2
         'ENDIF'
      CALL SMLCV
      TPFLAG = OLDTPL
      INITLC = LC
C
C     MORE INIT
C
41    QVALUE = 0
      DEFMOD = OLDMOD
      FNLX = 0
      CALL NEXP
      GO TO (99,  ^  // NUMBER
             42,  ^  // ,
             42,  ^  // ;
             85,  ^  // .
             43,  ^  // :
             50,  ^  // 'FOR'
             80,  ^  // 'DO'
             80,  ^  // 'WHILE'
             42,  ^  // 'RBR'
             43,  ^  // 'LBR'
             80,  ^  // 'RETURN'
             45,  ^  // $
             80,  ^  // (
             80,  ^  // )
             80,  ^  // [
             80,  ^  // ]
             43), ^  // =
         NEXTOP
'EJECT'
C     NOUN INIT
42    NLX = NAMEX (OPX)
      'IF' (NLX .NE. 0)
         'IF' (.NOT. NLTEST (NLX, CBIT) ^
               .AND. QVALUE .EQ. 0 ^
               .AND. LOCFLG (OPX) .EQ. 0)
C
C           INIT EXIT
43          IF (INITLC .EQ. LC) CALL FAULTP (30)
            TS = MAXLCV - LC
            'IF' (TS .NE. 0)
               NLX = LABNLX
               CALL ADJLOC (TS)
               'ENDIF'
            GO TO 3
            'ENDIF'
         'ENDIF'
C     CHECK LONG QUOTE
      IF (CQVAL (QVALUE) .GE. 0) CALL NVALUE
C     TEST LOCATION COUNTER VALUE FOR EXTENDED ARRAY
44    IF (LC .GT. MAXLCV) MAXLCV = LC
      IF (NEXTOP .EQ. COMMA) GO TO 41
      NAMEX (OPX) = 0
      GO TO 43
C     CRUTCH INITIAL VALUE
45    CALL CRUSYM
      GO TO 44
      'EJECT'
C     INIT FOR LOOP
C        'FOR' C 'LBR' C1, C2, ... , CN 'RBR'
C     GET THE LOOP COUNT
50    CALL NEXP
      FIRST = OPX
      IF (NEXTOP .NE. LBRACE) CALL FAULTP (58)
      NLX = NAMEX (OPX)
      'IF' (NLX .EQ. 0)
         CALL FAULTP (11)
         COUNT = 0
         'ELSE'
         'IF' (NLTEST (NLX, CBIT))
            COUNT = NLOPS (CVALUE, NLX)
            'ELSE'
            CALL FAULTP (11)
            COUNT = 0
            'ENDIF'
         'ENDIF'
      'DO'
         CALL NEXP
C        CHECK CONSTANT VALUE
         NLX = NAMEX (OPX)
         'IF' (NLX .NE. 0)
            'IF' (CQVAL (QVALUE) .LT. 0 .OR. (CFLAG .EQ. 0 ^
               .AND. LOCFLG (OPX) .EQ. 0))
               CALL FAULTP (11)
               NAMEX (OPX) = 0
               'ENDIF'
            'ENDIF'
         OPX = OPX + 1
         'WHILE' (NEXTOP .EQ. COMMA)
            'END'
      IF (NEXTOP .NE. RBRACE) CALL FAULTP (12)
      LAST = OPX - 1
      NEXTOP = COMMA
      'DO'
         'WHILE' (COUNT .NE. 0)
            'DOLOOP' OPX = FIRST, LAST
               CALL NVALUE
               'END'
            COUNT = COUNT - 1
            'END'
      OPX = FIRST
      'DO'
         CALL PEEK
         'WHILE' (PEEKS .EQ. COMMA)
            CALL FNZS
            'END'
      GO TO 44
      'EJECT'
C     TERMINATE BRACE GROUP
60    MSEEN = .FALSE.
      NBX = NBX - 4
      'IF' (NBX .LE. 1)
         CALL FAULTP (14)
         NBX = 5
         'ELSE'
C
C        RESTORE TO OUTER BRACE LEVEL
         OLDTPL = NBSTK (NBX-4)
         OLDMOD = NBSTK (NBX-3)
         LODLCI = NBSTK (NBX-2)
         CALL BLDBLK (LODLCI, WF14)
         CALL RLCI (NBSTK (NBX-1))
         'ENDIF'
      GO TO 2
      END
      'OUTFILE'   NVALUEAJH.FR
      SUBROUTINE  NVALUE
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE NVALUEAJH.FR
C     AUTHOR      A. J. HOWARD
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      INTEGER     NLOPS
      LOGICAL     NLTEST
      NLX = NAMEX (OPX)
      IF (NLX .EQ. 0) RETURN
      'IF' (LOCFLG (OPX) .NE. 0)
         CALL BLDBLK (BIAS (OPX), WF6)
         CALL BLDBLK (NAMEX (OPX), WF7)
         RETURN
         'ENDIF'
      NUMBER = NLOPS (CVALUE, NLX)
C     BUILD THE LOW BYTE
      CALL BLDBLK (IAND (NUMBER, 255), WF1)
      'IF' (NLTEST (LABNLX, DPBIT) ^
         .OR. MODE (OPX) .EQ. DPMODE)
C        BUILD THE HIGH BYTE
         CALL BLDBLK (ISHFT (NUMBER, -8), WF1)
         'ENDIF'
      RETURN
      END
      'OUTFILE'   CQVALAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE CQVALAJH.FR
C     AUTHOR      A. J. HOWARD
      INTEGER  FUNCTION CQVAL (VAL)
      INTEGER     VAL
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      LOGICAL     NLTEST
C     CHECK LONG OR SHORT STRING AND USAGE PRIOR TO DEFINITION
      CQVAL = VAL
      'IF' (VAL .NE. 0)
         'IF' (.NOT. NLTEST (LABNLX, STRBIT))
            CALL NLSET (LABNLX, STRBIT)
            'IF' (NLTEST (LABNLX, IOBIT))
               CALL FAULTP (17)
               'ENDIF'
            'ENDIF'
         VAL = 0
         'ENDIF'
      RETURN
      END
      'OUTFILE'   SETMAXAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE SETMAXAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  SMLCV
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
C     SET THE (NOMINAL) SIZE OF AN ARRAY
      CALL NDEFN
      IOTYPE = 0
      IF (BIAS (OPX) .EQ. 0) BIAS (OPX) = 1
      IF (DEFMOD .EQ. DPMODE) BIAS (OPX) = BIAS (OPX)*2
      MAXLCV = LC + BIAS (OPX)
      RETURN
      END
      'OUTFILE'   ADJLOCAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE ADJLOCAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  ADJLOC (ADJUST)
C     ADJUST THE LOCATION COUNTER TO THE END OF THE ARRAY

      'INCLUDE'   LCONSTAJH.IN,
      INTEGER     ADJUST
      'IF' (ADJUST .NE. 0)
         CALL LIST (LBSS, ADJUST, 0)
         CALL SETLCI
         'ENDIF'
      RETURN
      END