Oakland CPM Archive/oakcpm.iso/cpm/misc/plm80.ark/PLM81.FOR

Text File | 1989-04-05 | 127.1 KB | 3,656 lines

C***********************************************************************
C
C         8 0 8 0   P L / M   C O M P I L E R ,   P A S S - 1
C                                 PLM81
C                              VERSION 2.0
C                             JANUARY, 1975
C
C                          COPYRIGHT (C) 1975
C                          INTEL CORPORATION
C                          3065 BOWERS AVENUE
C                          SANTA CLARA, CALIFORNIA 95051
C
C  MODIFIED BY JEFF OGDEN (UM), DECEMBER 1977
C
C***********************************************************************
C
C
C
C            P A S S - 1    E R R O R   M E S S A G E S
C
C  ERROR                           MESSAGE
C  NUMBER
C  ------  -------------------------------------------------------------
C     1    THE SYMBOLS PRINTED BELOW HAVE BEEN USED IN THE CURRENT BLOCK
C          BUT DO NOT APPEAR IN A DECLARE STATEMENT, OR LABEL APPEARS IN
C          A GO TO STATEMENT BUT DOES NOT APPEAR IN THE BLOCK.
C
C     2    PASS-1 COMPILER SYMBOL TABLE OVERFLOW.  TOO MANY SYMBOLS IN
C          THE SOURCE PROGRAM.  EITHER REDUCE THE NUMBER OF VARIABLES IN
C          THE PROGRAM, OR RE-COMPILE PASS-1 WITH A LARGER SYMBOL TABLE.
C
C     3    INVALID PL/M STATEMENT.  THE PAIR OF SYMBOLS PRINTED BELOW
C          CANNOT APPEAR TOGETHER IN A VALID PL/M STATEMENT (THIS ERROR
C          MAY HAVE BEEN CAUSED BE A PREVIOUS ERROR IN THE PROGRAM).
C
C     4    INVALID PL/M STATEMENT.  THE STATEMENT IS IMPROPERLY FORMED--
C          THE PARSE TO THIS POINT FOLLOWS (THIS MAY HAVE OCCURRED BE-
C          CAUSE OF A PREVIOUS PROGRAM ERROR).
C
C     5    PASS-1 PARSE STACK OVERFLOW.  THE PROGRAM STATEMENTS ARE
C          RECURSIVELY NESTED TOO DEEPLY.  EITHER SIMPLIFY THE PROGRAM
C          STRUCTURE, OR RE-COMPILE PASS-1 WITH A LARGER PARSE STACK.
C
C     6    NUMBER CONVERSION ERROR.  THE NUMBER EITHER EXCEEDS 65535 OR
C          CONTAINS DIGITS WHICH CONFLICT WITH THE RADIX INDICATOR.
C
C     7    PASS-1 TABLE OVERFLOW.  PROBABLE CAUSE IS A CONSTANT STRING
C          WHICH IS TOO LONG.  IF SO, THE STRING SHOULD BE WRITTEN AS A
C          SEQUENCE OF SHORTER STRINGS, SEPARATED BY COMMAS.  OTHERWISE,
C          RE-COMPILE PASS-1 WITH A LARGER VARC TABLE.
C
C     8    MACRO TABLE OVERFLOW.  TOO MANY LITERALLY DECLARATIONS.
C          EITHER REDUCE THE NUMBER OF LITERALLY DECLARATIONS, OR RE-
C          COMPILE PASS-1 WITH A LARGER 'MACROS' TABLE.
C
C     9    INVALID CONSTANT IN INITIAL, DATA, OR IN-LINE CONSTANT.
C          PRECISION OF CONSTANT EXCEEDS TWO BYTES (MAY BE INTERNAL
C          PASS-1 COMPILER ERROR).
C
C    10    INVALID PROGRAM.  PROGRAM SYNTAX INCORRECT FOR TERMINATION
C          OF PROGRAM.  MAY BE DUE TO PREVIOUS ERRORS WHICH OCCURRED
C          WITHIN THE PROGRAM.
C
C    11    INVALID PLACEMENT OF A PROCEDURE DECLARATION WITHIN THE PL/M
C          PROGRAM.  PROCEDURES MAY ONLY BE DECLARED IN THE OUTER BLOCK
C          (MAIN PART OF THE PROGRAM) OR WITHIN DO-END GROUPS (NOT
C          ITERATIVE DO'S, DO-WHILE'S, OR DO-CASE'S).
C
C    12    IMPROPER USE OF IDENTIFIER FOLLOWING AN END STATEMENT.
C          IDENTIFIERS CAN ONLY BE USED IN THIS WAY TO CLOSE A PROCEDURE
C          DEFINITION.
C
C    13    IDENTIFIER FOLLOWING AN END STATEMENT DOES NOT MATCH THE NAME
C          OF THE PROCEDURE WHICH IT CLOSES.
C
C    14    DUPLICATE FORMAL PARAMETER NAME IN A PROCEDURE HEADING.
C
C    15    IDENTIFIER FOLLOWING AN END STATEMENT CANNOT BE FOUND IN THE
C          PROGRAM.
C
C    16    DUPLICATE LABEL DEFINITION AT THE SAME BLOCK LEVEL.
C
C    17    NUMERIC LABEL EXCEEDS CPU ADDRESSING SPACE.
C
C    18    INVALID CALL STATEMENT.  THE NAME FOLLOWING THE CALL IS NOT
C          A PROCEDURE.
C
C    19    INVALID DESTINATION IN A GO TO.  THE VALUE MUST BE A LABEL
C          OR SIMPLE VARIABLE.
C
C    20    MACRO TABLE OVERFLOW (SEE ERROR 8 ABOVE).
C
C    21    DUPLICATE VARIABLE OR LABEL DEFINITION.
C
C    22    VARIABLE WHICH APPEARS IN A DATA DECLARATION HAS BEEN PRE-
C          VIOUSLY DECLARED IN THIS BLOCK
C
C    23    PASS-1 SYMBOL TABLE OVERFLOW (SEE ERROR 2 ABOVE).
C
C    24    INVALID USE OF AN IDENTIFIER AS A VARIABLE NAME.
C
C    25    PASS-1 SYMBOL TABLE OVERFLOW (SEE ERROR 2 ABOVE).
C
C    26    IMPROPERLY FORMED BASED VARIABLE DECLARATION.  THE FORM IS
C          I BASED J, WHERE I IS AN IDENTIFIER NOT PREVIOUSLY DECLARED
C          IN THIS BLOCK, AND J IS AN ADDRESS VARIABLE.
C
C    27    SYMBOL TABLE OVERFLOW IN PASS-1 (SEE ERROR 2 ABOVE).
C
C    28    INVALID ADDRESS REFERENCE.  THE DOT OPERATOR MAY ONLY
C          PRECEDE SIMPLE AND SUBSCRIPTED VARIABLES IN THIS CONTEXT.
C
C    29    UNDECLARED VARIABLE.  THE VARIABLE MUST APPEAR IN A DECLARE
C          STATEMENT BEFORE ITS USE.
C
C    30    SUBSCRIPTED VARIABLE OR PROCEDURE CALL REFERENCES AN UN-
C          DECLARED IDENTIFIER.  THE VARIABLE OR PROCEDURE MUST BE
C          DECLARED BEFORE IT IS USED.
C
C    31    THE IDENTIFIER IS IMPROPERLY USED AS A PROCEDURE OR SUB-
C          SCRIPTED VARIABLE.
C
C    32    TOO MANY SUBSCRIPTS IN A SUBSCRIPTED VARIABLE REFERENCE.
C          PL/M ALLOWS ONLY ONE SUBSCRIPT.
C
C    33    ITERATIVE DO INDEX IS INVALID. IN THE FORM 'DO I = E1 TO E2'
C          THE VARIABLE I MUST BE SIMPLE (UNSUBSCRIPTED).
C
C    34    ATTEMPT TO COMPLEMENT A $ CONTROL TOGGLE WHERE THE TOGGLE
C          CURRENTLY HAS A VALUE OTHER THAN 0 OR 1.  USE THE '= N'
C          OPTION FOLLOWING THE TOGGLE TO AVOID THIS ERROR.
C
C    35    INPUT FILE NUMBER STACK OVERFLOW.  RE-COMPILE PASS-1 WITH
C          A LARGER INSTK TABLE.
C
C    36    TOO MANY BLOCK LEVELS IN THE PL/M PROGRAM.  EITHER SIMPLIFY
C          YOUR PROGRAM (30 BLOCK LEVELS ARE CURRENTLY ALLOWED) OR
C          RE-COMPILE PASS-1 WITH A LARGER BLOCK TABLE.
C
C     37   THE NUMBER OF ACTUAL PARAMETERS IN THE CALLING SEQUENCE
C          IS GREATER THAN THE NUMBER OF FORMAL PARAMETERS DECLARED
C          FOR THIS PROCEDURE.
C
C     38   THE NUMBER OF ACTUAL PARAMETERS IN THE CALLING SEQUENCE
C          IS LESS THAN THE NUMBER OF FORMAL PARAMETERS DECLARED
C          FOR THIS PROCEDURE.
C
C     39   INVALID INTERRUPT NUMBER (MUST BE BETWEEN 0 AND 7)
C
C     40   DUPLICATE INTERRUPT PROCEDURE NUMBER.  A PROCEDURE
C          HAS BEEN PREVIOUSLY SPECIFIED WITH AN IDENTICAL
C          INTERRUPT ATTRIBUTE.
C
C
C     41   PROCEDURE APPEARS ON LEFT-HAND-SIDE OF AN ASSIGNMENT.
C
C     42   ATTEMPTED 'CALL' OF A TYPED PROCEDURE.
C
C     43   ATTEMPTED USE OF AN UNTYPED PROCEDURE AS A FUNCTION
C          OR A VARIABLE.
C
C
C     44   THIS PROCEDURE IS UNTYPED AND SHOULD NOT RETURN A VALUE.
C
C     45   THIS PROCEDURE IS TYPED AND SHOULD RETURN A VALUE.
C
C     46   'RETURN' IS INVALID OUTSIDE A PROCEDURE DEFINITION.
C
C     47   ILLEGAL USE OF A LABEL AS AN IDENTIFIER.
C
C  ------  -------------------------------------------------------------
C              I M P L E M E N T A T I O N    N O T E S
C              - - - - - - - - - - - - - -    - - - - -
C    THE PL/M COMPILER IS INTENDED TO BE WRITTEN IN ANSI STANDARD
C    FORTRAN - IV, AND THUS IT SHOULD BE POSSIBLE TO COMPILE AND
C    EXECUTE THIS PROGRAM ON ANY MACHINE WHICH SUPPORTS THIS FORTRAN
C    STANDARD.  BOTH PASS-1 AND PASS-2, HOWEVER, ASSUME THE HOST
C    MACHINE WORD SIZE IS AT LEAST 31 BITS, EXCLUDING THE SIGN BIT
C    (I.E., 32 BITS IF THE SIGN IS INCLUDED).
C
C    THE IMPLEMENTOR MAY FIND IT NECESSARY TO CHANGE THE SOURCE PROGRAM
C    IN ORDER TO ACCOUNT FOR SYSTEM DEPENDENCIES.  THESE CHANGES ARE
C    AS FOLLOWS
C
C    1)   THE FORTRAN LOGICAL UNIT NUMBERS FOR VARIOUS DEVICES
C         MAY HAVE TO BE CHANGED IN THE 'GNC' AND 'WRITEL' SUBROU-
C         TINES (SEE THE FILE DEFINITIONS BELOW).
C
C     2)   THE HOST MACHINE MAY NOT HAVE THE PL/M 52 CHARACTER SET
C           0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$=./()+-'*,<>:;
C         (THE LAST 15 SPECIAL CHARACTERS ARE
C         DOLLAR,  EQUAL,  PERIOD,  SLASH, LEFT PAREN,
C         RIGHT PAREN, PLUS,   MINUS,  QUOTE, ASTERISK,
C         COMMA, LESS-THAN, GREATER-THAN, COLON, SEMI-COLON)
C         IN THIS CASE, IT IS NECESSARY TO CHANGE THE 'OTRAN' VECTOR IN
C         BLOCK DATA TO A CHARACTER SET WHICH THE HOST MACHINE SUPPORTS
C
C     3)   THE COMPUTED GO TO IN 'SYNTH' MAY BE TOO LONG FOR SOME
C         COMPILERS.  IF YOU GET A COMPILATION ERROR, BREAK THE
C         'GO TO' INTO TWO SECTIONS.
C
C     4)  THE HOST FORTRAN SYSTEM MAY HAVE A LIMITATION ON THE NUMBER
C         OF CONTIGUOUS COMMENT RECORDS (E.G. S/360 LEVEL G). IF SO,
C         INTERSPERSE THE DECLARATION STATEMENTS INTEGER I1000, INTEGER
C         I1001, ETC., AS NECESSARY TO BREAK UP THE LENGTH OF COMMENTS.
C         THE SYMBOLS I1XXX ARE RESERVED FOR THIS PURPOSE.
C
C    THERE ARE A NUMBER OF COMPILER PARAMETERS WHICH MAY HAVE TO
C    BE CHANGED FOR YOUR INSTALLATION.  THESE PARAMETERS ARE DEFINED
C    BELOW (SEE 'SCANNER COMMANDS'), AND THE CORRESPONDING DEFAULT
C    VALUES ARE SET FOLLOWING THEIR DEFINITION.  FOR EXAMPLE, THE
C                  $RIGHTMARGIN = I
C    PARAMETER DETERMINES THE RIGHT MARGIN OF THE INPUT SOURCE LINE.
C    THE PARAMETER IS SET EXTERNALLY BY A SINGLE LINE STARTING WITH
C    '$R' IN COLUMNS ONE AND TWO (THE REMAINING CHARACTERS UP TO
C    THE '=' ARE IGNORED).  THE INTERNAL COMPILER REPRESENTATION
C    OF THE CHARACTER 'R' IS 29 (SEE CHARACTER CODES BELOW), AND THUS
C    THE VALUE OF THE $RIGHTMARGIN PARAMETER CORRESPONDS TO ELEMENT 29
C    OF THE 'CONTRL' VECTOR.
C
C     1)  THE PARAMETERS $T, $P, $W, $I, $O, AND $R
C        CONTROL THE OPERATING MODE OF PL/M.  FOR BATCH PROCESSING,
C        ASSUMING 120 CHARACTER (OR LARGER) PRINT LINE AND 80 CHARAC-
C        TER CARD IMAGE, THE PARAMETERS SHOULD DEFAULT AS FOLLOWS
C                $TERMINAL   =  0
C                $PRINT      =  1
C                $WIDTH      = 120
C                $INPUT      =  2
C                $OUTPUT     =  2
C                $RIGHTMARGIN= 80
C        NOTE THAT IT MAY BE DESIRABLE TO LEAVE $R=72 TO ALLOW ROOM
C        FOR AN 8-DIGIT SEQUENCE NUMBER IN COLUMNS 73-80 OF THE PL/M
C        SOURCE CARD.
C
C    2)  FOR INTERACTIVE PROCESSING, ASSUMING A CONSOLE WITH WIDTH
C        OF 72 CHARACTERS (E.G., A TTY), THESE PARAMETERS SHOULD
C        DEFAULT AS FOLLOWS
C                $TERMINAL   =  1
C                $PRINT      =  1
C                $WIDTH      = 72
C                $INPUT      =  1
C                $OUTPUT     =  1
C                $RIGHTMARGIN= 72
C
C    3)  THE CHARACTERISTICS OF THE INTERMEDIATE LANGUAGE FILES
C        PRODUCED BY PASS-1 ARE GOVERNED BY THE $J, $K, $U, $V, AND
C        $Y PARAMETERS.  THESE PARAMETERS CORRESPOND TO THE DESTINATION
C        AND WIDTH OF THE INTERMEDIATE CODE FILE ($J AND $K), AND
C        DESTINATION AND WIDTH OF THE INTERMEDIATE SYMBOL TABLE ($U
C        AND $V).  SOME FORTRAN SYSTEMS DELETE THE LEADING CHARACTER
C        OF THE FILES PRODUCED BY OTHER FORTRAN PROGRAMS.  THE $Y
C        PARAMETER CAN BE USED TO PAD EXTRA BLANKS AT THE BEGINNING OF
C        THE INTERMEDIATE FILES IF THIS BECOMES A PROBLEM ON THE HOST
C        SYSTEM.
C
C        UNDER NORMAL CIRCUMSTANCES, THESE PARAMETERS WILL NOT
C        HAVE TO BE CHANGED.  IN ANY CASE, EXPERIMENT WITH VARIOUS
C        VALUES OF THE $ PARAMETERS BY SETTING THEM EXTERNALLY BE-
C        FORE ACTUALLY CHANGING THE DEFAULTS.
C
C    THE IMPLEMENTOR MAY ALSO WISH TO INCREASE OR DECREASE THE SIZE
C    OF PASS-1 OR PASS-2 TABLES.  THE TABLES IN PASS-1 WHICH MAY BE
C    CHANGED IN SIZE ARE 'MACROS' AND 'SYMBOL' WHICH CORRESPOND TO
C    THE AREAS WHICH HOLD 'LITERALLY' DEFINITIONS AND PROGRAM SYMBOLS
C    AND ATTRIBUTES, RESPECTIVELY.  IT IS IMPOSSIBLE TO PROVIDE AN
C    EXACT FORMULA WHICH RELATES THE NUMBER OF SYMBOLS HELD BY EITHER
C    OF THESE TABLES TO THE TABLE LENGTH, SINCE TABLE SPACE IS DY-
C    NAMICALLY ALLOCATED ACCORDING TO SYMBOL NAME LENGTH AND NUMBER
C    OF ATTRIBUTES REQUIRED FOR THE PARTICULAR SYMBOL.
C
C    1)  IN THE CASE OF THE MACROS TABLE, THE LENGTH IS RELATED TO THE
C        TOTAL NUMBER OF CHARACTERS IN THE MACRO NAMES PLUS THE TOTAL
C        NUMBER OF CHARACTERS IN THE MACRO DEFINITIONS - AT THE DEEP-
C        EST BLOCK LEVEL DURING COMPILATION.  TO CHANGE THE MACRO
C        TABLE SIZE, ALTER ALL OCCURRENCES OF
C
C                         MACROS(500)
C
C        IN EACH SUBROUTINE TO MACROS(N), WHERE N REPRESENTS THE NEW
C        INTEGER CONSTANT SIZE.  IN ADDITION, THE 'DATA' STATEMENT
C        BLOCK DATA (LAST PROGRAM SEGMENT) MUST BE CHANGED FOR THE
C        MACRO PARAMETERS BASED UPON THE CONSTANT VALUE N TO
C
C           DATA MACROS /N*0/, CURMAC /N+1/, MAXMAC /N/,
C          1    MACTOP /1/
C
C    2)  IF THE IMPLEMENTOR WISHES TO INCREASE OR DECREASE THE SIZE
C        OF THE SYMBOL TABLE, THEN ALL OCCURRENCES OF
C
C                          SYMBOL(4000)
C
C        MUST BE CHANGED TO SYMBOL(M), WHERE M IS THE DESIRED INTEGER
C        CONSTANT SIZE.  THE 'DATA' STATEMENTS FOR SYMBOL TABLE PARA-
C        METERS MUST ALSO BE ALTERED AS DESCRIBED IN THE CORRESPONDING
C        COMMENT IN BLOCK DATA.  IN PARTICULAR, THE LAST ITEM  OF
C        THE DATA STATEMENT FOR 'SYMBOL' FILLS THE UNINITIALIZED POR-
C        TION OF THE TABLE WITH ZEROES, AND HENCE MUST BE THE EVALUATION
C        OF THE ELEMENT
C                           (M-120)*0
C
C        (IT IS CURRENTLY (4000-120)*0 = 3880*0).  THE DATA STATEMENT
C        FOR MAXSYM AND SYMABS MUST BE CHANGED TO INITIALIZE THESE
C        VARIABLES TO THE VALUE M.
C
C    GOOD LUCK...
C
C
C     F  I  L  E     D  E  F  I  N  I  T  I  O  N  S
C            INPUT                        OUTPUT
C
C     FILE   FORTRAN  MTS      DEFAULT    FORTRAN  MTS      DEFAULT
C     NUM    I/O UNIT I/O UNIT FDNAME     I/O UNIT I/O UNIT FDNAME
C
C      1        1     GUSER    *MSOURCE*    11     SERCOM   *MSINK*
C      2        2     SCARDS   *SOURCE*     12     SPRINT   *SINK*
C      3        3     3                     13     13
C      4        4     4                     14     14
C      5        5     5                     15     15
C      6        6     6                     16     16       -PLM16##
C      7        7     7                     17     17       -PLM17##
C
C   ALL INPUT RECORDS ARE 80 CHARACTERS OR LESS.  ALL
C   OUTPUT RECORDS ARE 120 CHARACTERS OR LESS.
C   THE FORTRAN UNIT NUMBERS CAN BE CHANGED IN THE
C   SUBROUTINES GNC AND WRITEL (THESE ARE THE ONLY OC-
C   CURRENCES OF REFERENCES TO THESE UNITS).
C
C
C
C    0 1 2 3 4 5 6 7 8 9
C    0 0 0 0 0 0 0 0 1 1
C    2 3 4 5 6 7 8 9 0 1
C
C
C    $ = . / ( ) + - ' * , < > : ;
C    3 3 4 4 4 4 4 4 4 4 4 4 5 5 5
C    8 9 0 1 2 3 4 5 6 7 8 9 0 1 2
C
C
C    A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
C    1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3
C    2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7
C
C
C  SEQNO              SUB/FUNC NAME
C  15410000      SUBROUTINE EXITB
C  16300000      INTEGER FUNCTION LOOKUP(IV)
C  17270000      INTEGER FUNCTION ENTER(INFOV)
C  18050000      SUBROUTINE DUMPSY
C  20030000      SUBROUTINE RECOV
C  20420000      LOGICAL FUNCTION STACK(Q)
C  20930000      LOGICAL FUNCTION PROK(PRD)
C  21550000      SUBROUTINE REDUCE
C  22100000      SUBROUTINE CLOOP
C  22740000      SUBROUTINE PRSYM(CC,SYM)
C  23120000      INTEGER FUNCTION GETC1(I,J)
C  23330000      SUBROUTINE SCAN
C  25280000      INTEGER FUNCTION WRDATA(SY)
C  26460000      SUBROUTINE DUMPCH
C  26960000      SUBROUTINE SYNTH(PROD,SYM)
C  36310000      INTEGER FUNCTION GNC(Q)
C  37980000      SUBROUTINE WRITEL(NSPACE)
C  38520000      FUNCTION ICON(I)
C  38710000      SUBROUTINE DECIBP
C  38850000      SUBROUTINE CONV(PREC)
C  39090000      SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH)
C  39370000      SUBROUTINE CONOUT(CC,K,N,BASE)
C  39690000      SUBROUTINE PAD(CC,CHR,I)
C  39800000      SUBROUTINE STACKC(I)
C  39950000      SUBROUTINE ENTERB
C  40180000      SUBROUTINE DUMPIN
C  40880000      SUBROUTINE ERROR(I,LEVEL)
C  41320000      INTEGER FUNCTION SHR(I,J)
C  41360000      INTEGER FUNCTION SHL(I,J)
C  41400000      INTEGER FUNCTION RIGHT(I,J)
C  41440000      SUBROUTINE SDUMP
C  41670000      SUBROUTINE REDPR(PROD,SYM)
C  41900000      SUBROUTINE EMIT(VAL,TYP)
C
C***********************************************************************
C
      INTEGER I
      INTEGER TITLE(10),VERS
      COMMON /TITL/TITLE,VERS
C
C     SYNTAX ANALYZER TABLES
      INTEGER SHL,SHR,RIGHT,CONV,GETC1
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
C     GLOBAL VARIABLES
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER POLISH(30),MAXPOL,POLTOP,POLCNT,POLCHR(18)
      COMMON /POLE/POLISH,MAXPOL,POLTOP,POLCNT,POLCHR
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
C     THE FOLLOWING SCANNER COMMANDS ARE DEFINED
C     ANALYZE = I      (12)  PRINT SYNTAX ANALYSIS TRACE
C     BYPASS           (13)  BYPASS STACK DUMP ON ERROR
C     COUNT = I        (14)  BEGIN LINE COUNT AT I
C     DELETE = I       (15)
C     EOF              (16)
C     GENERATE         (18)
C     INPUT = I        (20)
C     JFILE (CODE)= I  (21)
C     KWIDTH (CD)= I   (22)
C     LEFTMARGIN = I   (23)
C     MEMORY = I       (24)
C     OUTPUT = I       (26)
C     PRINT (T OR F)   (27)
C     RIGHTMARG = I    (29)
C     SYMBOLS          (30)
C     TERMINAL         (31) (0=BATCH, 1=TERM, 2=INTERLIST)
C     USYMBOL = I      (32)
C     VWIDTH (SYM) = I (33)
C     WIDTH = I        (34)
C     YPAD = N         (36)  BLANK PAD ON OUTPUT
C     CONTRL(1) IS THE ERROR COUNT
      DO 2 I=1,64
2     CONTRL(I) = -1
      CONTRL(1) = 0
      CONTRL(12) = 0
      CONTRL(13) = 1
      CONTRL(14) = 0
      CONTRL(15) = 120
      CONTRL(16) = 0
      CONTRL(18) = 0
      CONTRL(20) = 2
      CONTRL(21) = 6
      CONTRL(22) = 72
      CONTRL(23) = 1
      CONTRL(24) = 1
      CONTRL(26) = 2
      CONTRL(27) = 1
      CONTRL(29) = 80
      CONTRL(30) = 0
      CONTRL(31) = 1
      CONTRL(32) = 7
      CONTRL(33) = 72
      CONTRL(34) = 120
      CONTRL(36) = 1
C
          DO 4 I=1,5
4         PRMASK(I)=2**(I*8-8)-1
          DO 8 I=1,256
          ITRAN(I) = 1
8         CONTINUE
C
          DO 5 I=53,64
          OTRAN(I) = OTRAN(1)
5         CONTINUE
C
          DO 10 I=1,52
          J = OTRAN(I)
          J = ICON(J)
10        ITRAN(J) = I
      CALL CONOUT(0,4,8080,10)
      CALL PAD(1,1,1)
      CALL FORM(1,TITLE,1,10,10)
      CALL CONOUT(1,1,VERS/10,10)
      CALL PAD(1,40,1)
      CALL CONOUT(1,1,MOD(VERS,10),10)
      CALL WRITEL(1)
          DO 20 I=1,3
20        PSTACK(I)=0
      PSTACK(4)=EOFILE
      SP = 4
      CALL SCAN
      CALL CLOOP
      CALL EMIT(NOP,OPR)
100   IF (POLTOP.EQ.0) GO TO 200
      CALL EMIT(NOP,OPR)
      GO TO 100
200   CONTINUE
C     PRINT ERROR COUNT
      I = CONTRL(1)
      J = CONTRL(26)
      K = J
300   CONTINUE
      CALL WRITEL(0)
      CONTRL(26) = J
      IF (I.EQ.0) CALL FORM(0,MSSG,6,7,41)
      IF (I.NE.0) CALL CONOUT(2,-5,I,10)
      CALL PAD(1,1,1)
      CALL FORM(1,MSSG,8,20,41)
      IF (I.NE.1) CALL PAD(1,30,1)
      CALL PAD(0,1,1)
      CALL WRITEL(0)
C     CHECK FOR TERMINAL CONTROL OF A BATCH RUN
      IF ((J.EQ.1).OR.(CONTRL(31).EQ.0)) GO TO 400
C     ARRIVE HERE IF TERMINAL TOGGLE GT 0, AND OUTPUT NOT CONSOLE
      J = 1
      GO TO 300
400   CONTINUE
      CONTRL(26) = K
      CALL DUMPSY
C     MAY WANT A SYMBOL TABLE FOR THE SIMULATOR
      IF(CONTRL(24).EQ.0) SYMBOL(2) = 0
      CALL DUMPCH
      CALL DUMPIN
      STOP
      END
      SUBROUTINE EXITB
C     GOES THROUGH HERE UPON BLOCK EXIT
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER HENTRY(127),HCODE
      COMMON /HASH/HENTRY,HCODE
      INTEGER RIGHT,SHR,SHL
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      LOGICAL ERRED
      ERRED = .FALSE.
      IF (CURBLK .LE. 0) GO TO 9999
      I = BLOCK(CURBLK)
      N = MACBLK(CURBLK)
      CURMAC = RIGHT(N,12)
      MACTOP = SHR(N,12)
      CURBLK = CURBLK - 1
          J = SYMBOL(SYMTOP)
100       IF (J.LT.I) GO TO 300
          IF (SYMBOL(J+1).LT.0) GO TO 200
          K = IABS(SYMBOL(J+2))
          KP = RIGHT(K,4)
          LP = SHR(KP,8)
          IF(KP.GE.LITER) GO TO 200
          IF ((KP.NE.VARB).AND.(KP.NE.LABEL))GO TO 150
          K = RIGHT(SHR(K,4),4)
          IF (K.NE.0) GO TO 150
          IF ((KP.EQ.LABEL).AND.(CURBLK.GT.1)) GO TO 200
          IF (ERRED) GO TO 130
              CALL ERROR(1,1)
              ERRED=.TRUE.
130       CALL PAD(0,1,5)
          N = SYMBOL(J+1)
          N = SHR(N,12)
          IF (N.EQ.0) GO TO 150
              DO 120 KP=1,N
          LTEMP=J+2+KP
          L=SYMBOL(LTEMP)
                  DO 120 LP=1,PACK
                  JP = 30-LP*6
                  JP = RIGHT(SHR(L,JP),6)+1
                  CALL PAD(1,JP,1)
120           CONTINUE
          CALL WRITEL(0)
150       SYMBOL(J+1) = -SYMBOL(J+1)
C         MAY WANT TO FIX THE HASH CODE CHAIN
          IF (LP.LE.0) GO TO 200
C         FIND MATCH ON THE ENTRY
          K = J - 1
          KP = SYMBOL(K)
          HCODE = SHR(KP,16)
          KP = RIGHT(KP,16)
          N = HENTRY(HCODE)
          IF (N.NE.K) GO TO 160
C
C         THIS ENTRY IS DIRECTLY CONNECTED
          HENTRY(HCODE) = KP
          GO TO 200
C
C         LOOK THROUGH SOME LITERALS IN THE SYMBOL TABLE ABOVE
160       NP = RIGHT(SYMBOL(N),16)
          IF (NP.EQ.K) GO TO 170
          N = NP
          GO TO 160
C
170       SYMBOL(N) = SHR(HCODE,16) + KP
C
200       J = RIGHT(SYMBOL(J),16)
          GO TO 100
300    BLKSYM = BLOCK(CURBLK)
9999   RETURN
       END
      INTEGER FUNCTION LOOKUP(IV)
C     SYNTAX ANALYZER TABLES
      INTEGER SHL,SHR,RIGHT,CONV,GETC1
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER HENTRY(127),HCODE
      COMMON /HASH/HENTRY,HCODE
      INTEGER ENTER
      LOGICAL SFLAG
      EQUIVALENCE (L,SYMLEN),(I,SYMLOC)
      NVAL = FIXV(IV)
      SFLAG = PSTACK(IV) .NE. NUMBV
      I = VAR(IV)
      L = SHR(I,12)
      I = RIGHT(I,12)
      J = I
      KP = PACK*6
      K = KP
      JP = 0
      M = 0
100   IF (JP .GE. L) GO TO 300
      K = K - 6
      IF (K .GE. 0) GO TO 200
      VARC(J) = M
      J = J + 1
      M = 0
      K = KP - 6
200   LTEMP=JP+I
      M=SHL(VARC(LTEMP)-1,K)+M
      JP = JP + 1
      GO TO 100
300   VARC(J) = M
C     VARC IS NOW IN PACKED FORM READY FOR LOOKUP
C     COMPUTE HASH CODE (REDUCE NUMBERS MOD 127, USE FIRST 5 CHARS OF
C     IDENTIFIERS AND STRINGS )
      HCODE = NVAL
      IF (SFLAG) HCODE = VARC(I)
      HCODE = MOD(HCODE,127) + 1
C     HCODE IS IN THE RANGE 1 TO 127
      LP = (L-1)/PACK + 1
      K = HENTRY(HCODE)
400   IF (K .LE. 0) GO TO 9990
      IF (SFLAG) GO TO 450
C     COMPARE NUMBERS IN INTERNAL FORM RATHER THAN CHARACTERS
          J = SYMBOL(K+3)
          IF (RIGHT(J,4).LE.LITER) GO TO 600
          J = SHR(J,8)
          IF (J.EQ.NVAL) GO TO 510
          GO TO 600
450   J = SYMBOL(K+2)
      JP = RIGHT(J,12)
      IF (JP .NE. L) GO TO 600
          J = K + 3
          JP = I
          DO 500 M=1,LP
          LTEMP=J+M
          IF(VARC(JP).NE.SYMBOL(LTEMP)) GO TO 600
500       JP = JP + 1
C     SYMBOL FOUND
C
C     MAKE SURE THE TYPES MATCH.
      JP = PSTACK(IV)
      M = SYMBOL(K+3)
      M = RIGHT(M,4)
      IF ((JP.EQ.STRV).AND.(M.EQ.LITER)) GO TO 510
      IF ((JP.NE.IDENTV).OR.(M.GE.LITER)) GO TO 600
C     JP IS IDENTIFIER, M IS VARIABLE, LABEL, OR PROCEDURE.
510   LOOKUP = K+2
      RETURN
600   K = SYMBOL(K)
      K = RIGHT(K,16)
      GO TO 400
9990  LOOKUP = 0
      RETURN
      END
      INTEGER FUNCTION ENTER(INFOV)
      INTEGER Q,TYP,INFO,INFOV,SHR,SHL,RIGHT
C     SYNTAX ANALYZER TABLES
      INTEGER CONV,GETC1
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
C
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER HENTRY(127),HCODE
      COMMON /HASH/HENTRY,HCODE
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
C      ENTER ASSUMES A PREVIOUS CALL TO LOOKUP (EITHER THAT, OR SET UP
C      THE VALUES OF SYMLOC AND SYMLEN IN THE VARC ARRAY).
C         ALSO SET-UP HASH CODE VALUE (SEE LOOKUP), IF NECESSARY
      INFO = INFOV
      I = SYMTOP
      IF (INFO.GE.0) GO TO 10
C     ENTRY WITH NO EXTERNAL NAME
      IHASH = 0
      HCODE = 0
      INFO = - INFO
      SYMLEN = 0
      Q = 0
      GO TO 20
C
10    IHASH = 1
      Q = (SYMLEN-1)/PACK + 1
C
20    SYMTOP = SYMTOP + Q + IHASH + 3
      IQ = I
      I = I + IHASH
C
      IF (SYMTOP .LE. MAXSYM) GO TO 100
      I = IHASH
      SYMTOP = Q + IHASH + 3
      CALL ERROR(2,5)
100   SYMBOL(SYMTOP) = I
      SYMCNT = SYMCNT + 1
      SYMBOL(I) = SHL(SYMCNT,16) + SYMBOL(IQ)
      I = I + 1
      SYMBOL(I) = SHL(Q,12) + SYMLEN
      IP = I + 1
      SYMBOL(IP) = INFO
      L = SYMLOC - 1
      IF (Q.EQ.0) GO TO 210
          DO 200 J = 1,Q
          LTEMP=IP+J
          LTEMP1=L+J
200       SYMBOL(LTEMP)=VARC(LTEMP1)
210   ENTER = I
C
C     COMPUTE HASH TABLE ENTRY
      IF (IHASH.EQ.0) GO TO 300
C     FIX COLLISION CHAIN
      SYMBOL(IQ) = SHL(HCODE,16) + HENTRY(HCODE)
      HENTRY(HCODE) = IQ
300   RETURN
      END
      SUBROUTINE DUMPSY
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER RIGHT,SHR,SHL
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON/BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER LOOKUP,ENTER
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      IC = CONTRL(30)
      IF (IC.EQ.0) GO TO 2000
      CALL WRITEL(0)
      IF (IC.GT.1) CALL FORM(0,MSSG,42,77,77)
      I = SYMBOL(SYMTOP)
      IT = SYMTOP
210   IF (I .LE. 0) GO TO 1000
      K = SYMBOL(I)
      KP = SHR(K,16)
C     QUICK CHECK FOR ZERO LENGTH NAME
      IF (IC.GE.2) GO TO 215
      N = IABS(SYMBOL(I+1))
      IF (SHR(N,12).EQ.0) GO TO 218
215   CONTINUE
      CALL PAD(0,30,1)
      CALL CONOUT(1,5,KP,10)
218   CONTINUE
      K = SYMBOL(I+1)
      IF (IC.LT.2) GO TO 220
      J = 1
      IF (K .LT. 0) J = 47
      CALL PAD(1,J,1)
      CALL PAD(1,1,1)
220   CONTINUE
      K = IABS(K)
      KP = SHR(K,12)
      N = KP
      K = RIGHT(K,12)
      MC = K
      IF (IC.LT.2) GO TO 230
      CALL CONOUT(1,4,I+1,10)
      CALL PAD(1,1,1)
      CALL CONOUT(1,-3,KP,10)
      CALL PAD(1,1,1)
      CALL CONOUT(1,-4,K,10)
      CALL PAD(1,1,1)
230   CONTINUE
      K = SYMBOL(I+2)
      J = 29
      IF (IC.LT.2) GO TO 240
      IF (K .LT. 0) J = 13
      CALL PAD(1,J,1)
      CALL PAD(1,1,1)
240   CONTINUE
      K = IABS(K)
      M = RIGHT(K,4)
      IF (IC.LT.2) GO TO 250
      KP = SHR(K,8)
      CALL CONOUT(1,6,KP,10)
      KP = RIGHT(SHR(K,4),4)
      CALL CONOUT(1,-3,KP,10)
      KP = RIGHT(K,4)
      CALL CONOUT(1,-3,KP,10)
250   CONTINUE
      CALL PAD(1,1,1)
      IP = I+2
      IF (N.EQ.0) GO TO 310
          IF (M.EQ.LITER) CALL PAD(1,46,1)
          DO 300 KP=1,N
          LTEMP=KP+IP
          L=SYMBOL(LTEMP)
              DO 300 LP=1,PACK
              IF ((KP-1)*PACK+LP.GT.MC) GO TO 305
              JP = 30-LP*6
              JP = RIGHT(SHR(L,JP),6)+1
              CALL PAD(1,JP,1)
300           CONTINUE
305       IF (M.EQ.LITER) CALL PAD(1,46,1)
310   IP = IP + N
      IF (IC.LT.2) GO TO 330
320   IP = IP + 1
      IF (IP .GE. IT) GO TO 330
          CALL PAD(1,1,1)
          K = SYMBOL(IP)
          J = 1
          IF (K .LT. 0) J = 45
          CALL PAD(1,J,1)
          K = IABS(K)
          CALL CONOUT(1,8,K,16)
          GO TO 320
330   IT = I
      I = RIGHT(SYMBOL(I),16)
      GO TO 210
1000  CONTINUE
      CALL WRITEL(0)
2000  CONTINUE
      CALL WRITEL(0)
      K = CONTRL(26)
      CONTRL(26) = CONTRL(32)
      KP = CONTRL(34)
      CONTRL(34) = CONTRL(33)
C     WRITE THE INTERRUPT PROCEDURE NAMES
      CALL PAD(1,41,1)
          DO 2050 I = 1,8
          J = INTPRO(I)
          IF (J.LE.0) GO TO 2050
C         WRITE INTNUMBER SYMBOLNUM (4 BASE-32 DIGITS)
              CALL PAD(1,I+1,1)
              DO 2020 L=1,3
              CALL PAD(1,RIGHT(J,5)+2,1)
2020          J = SHR(J,5)
          CALL PAD(1,41,1)
2050  CONTINUE
      CALL PAD(1,41,1)
      CALL WRITEL(0)
C
C
C     REVERSE THE SYMBOL TABLE POINTERS
C     SET THE LENGTH FIELD OF COMPILER-GENERATED LABELS TO 1
C
      L = 0
      I = SYMTOP
      J = SYMBOL(I)
      SYMBOL(I) = 0
2100  IF (J.EQ.0) GO TO 2200
      L = L + 1
C     CHECK FOR A LABEL VARIABLE
      K = SYMBOL(J+2)
      IF (MOD(K,16).NE.LABEL) GO TO 2110
C     CHECK FOR CHARACTER LENGTH = 0
      K = IABS(SYMBOL(J+1))
      IF (MOD(K,4096).NE.0) GO TO 2110
C     SET LENGTH TO 1 AND PREC TO 5 (FOR COMP GENERATED LABELS)
          SYMBOL(J+2) = 336 + LABEL
C         336 = 1 * 256 + 5 * 16
2110  M = SYMBOL(J)
      SYMBOL(J) = I
      I = J
      J = RIGHT(M,16)
      GO TO 2100
C
2200  CONTINUE
      JP = 0
      IFIN = 1
      IP = 1
      J = 1
C
2500  IF (J.NE.JP) GO TO 2610
      J = J + IP
2610  IF (J.LT.IFIN) GO TO 2700
C     OTHERWISE GET ANOTHER ENTRY FROM TABLE
          CALL PAD(1,41,1)
          J = I + 1
          I = SYMBOL(I)
          IF (I.EQ.0) GO TO 2800
          IP = IABS(SYMBOL(J))
          IP =  RIGHT(SHR(IP,12),12)
          J = J + 1
          JP = J + 1
C         CHECK FOR BASED VARIABLE -- COMPUTE LAST ENTRY
          IFIN = JP + IP
          IF (SYMBOL(J).LT.0) IFIN = IFIN + 1
          GO TO 2500
2700  L = 1
      LP = SYMBOL(J)
      IF (LP.LT.0) L = 45
      LP = IABS(LP)
      CALL PAD(1,L,1)
2710  CALL PAD(1,RIGHT(LP,5)+2,1)
      LP = SHR(LP,5)
      IF (LP.GT.0) GO TO 2710
      J = J + 1
      GO TO 2500
C
2800  CALL PAD(1,41,1)
      CALL WRITEL(0)
      CONTRL(26) = K
      CONTRL(34) = KP
      RETURN
      END
      SUBROUTINE RECOV
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER GETC1
      INTEGER RIGHT
C     FIND SOMETHING SOLID IN THE TEXT
100   IF(TOKEN.EQ.DECL.OR.TOKEN.EQ.PROCV.OR.TOKEN.EQ.ENDV
     1 .OR.TOKEN.EQ.DOV.OR.TOKEN.EQ.SEMIV.OR.TOKEN.EQ.EOFILE) GO TO 300
200       CALL SCAN
          GO TO 100
C     AND IN THE STACK
300   I = PSTACK(SP)
      IF (FAILSF.AND.GETC1(I,TOKEN).NE.0) GO TO 500
      IF (I.EQ.EOFILE.AND.TOKEN.EQ.EOFILE) GO TO 400
      IF ((I.EQ.GROUPV.OR.I.EQ.SLISTV.OR.I.EQ.STMTV.OR.
     1    I.EQ.DOV.OR.I.EQ.PROCV).AND.TOKEN.NE.EOFILE) GO TO 200
C         BUT DON'T GO TOO FAR
          IF (SP.LE.4) GO TO 200
          VARTOP = RIGHT(VAR(SP),12)
          SP = SP - 1
          GO TO 300
400   COMPIL = .FALSE.
500   FAILSF = .FALSE.
      RETURN
      END
      LOGICAL FUNCTION STACK(Q)
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER GETC1,SHL,SHR
      INTEGER Q
100   I = GETC1(PSTACK(SP),TOKEN)+1
      GO TO (1000,2000,3000,4000),I
C     ILLEGAL SYMBOL PAIR
1000  CALL ERROR(3,1)
      CALL PRSYM(0,PSTACK(SP))
      CALL PAD(1,1,1)
      CALL PRSYM(1,TOKEN)
      CALL SDUMP
      CALL RECOV
C     RECOVER MAY HAVE SET COMPILING FALSE
      IF (.NOT.COMPIL) GO TO 2000
      GO TO 100
C     RETURN TRUE
2000  STACK = .TRUE.
      GO TO 9999
C     RETURN FALSE
3000  STACK = .FALSE.
      GO TO 9999
C     CHECK TRIPLES
4000  CONTINUE
      J = SHL(PSTACK(SP-1),16)+SHL(PSTACK(SP),8)+TOKEN
      IU = NC1TRI+2
      IL = 1
4100  K =SHR(IU+IL,1)
      JP = C1TRI(K)
          IF(J .LT. JP) IU = K
          IF(J .GE. JP) IL = K
      IF ((IU-IL) .GT. 1) GO TO 4100
C     CHECK FOR MATCH
      STACK = J .EQ. C1TRI(IL)
9999  RETURN
      END
      LOGICAL FUNCTION PROK(PRD)
      INTEGER PRD
      INTEGER SHL,SHR,RIGHT,CONV,GETC1
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
C      CONTEXT CHECK OF EQUAL OR IMBEDDED RIGHT PARTS
      I = CONTC(PRD)+1
      GO TO (1000,2000,3000,4000),I
C     NO CHECK REQUIRED
1000  PROK = .TRUE.
      GO TO 9999
C     RIGHT CONTEXT CHECK
2000  PROK = GETC1(HDTB(PRD),TOKEN) .NE. 0
      GO TO 9999
C     LEFT CONTEXT CHECK
3000  K = HDTB(PRD) - NT
      L = PRLEN(PRD)
      LTEMP=SP-L
      I=PSTACK(LTEMP)
      L = LEFTI(K)+1
      LP = LEFTI(K+1)
      IF (L .GT. LP) GO TO 3200
          DO 3100 J=L,LP
          IF (LEFTC(J) .NE. I) GO TO 3100
          PROK = .TRUE.
          GO TO 9999
3100      CONTINUE
3200  CONTINUE
C
      PROK = .FALSE.
      GO TO 9999
C     CHECK TRIPLES
4000  CONTINUE
      K = HDTB(PRD)-NT
      L=PRLEN(PRD)
      LTEMP=SP-L
      I=SHL(PSTACK(LTEMP),8)+TOKEN
      L = TRIPI(K)+1
      LP = TRIPI(K+1)
      IF (L .LT. LP) GO TO 4200
          DO 4100 J=L,LP
          IF (CONTT(J) .NE. I) GO TO 4100
          PROK = .TRUE.
          GO TO 9999
4100      CONTINUE
4200  CONTINUE
      PROK = .FALSE.
9999  RETURN
      END
      SUBROUTINE REDUCE
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
      INTEGER SHL,SHR,RIGHT,CONV,GETC1
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER I,J,PRD,K,L,M
      LOGICAL JL,ML,PROK
      EQUIVALENCE (J,JL),(M,ML)
C     PACK STACK TOP
      K = SP-4
      L = SP-1
      J = 0
          DO 100 I=K,L
100       J = SHL(J,8)+PSTACK(I)
      LTEMP=PSTACK(SP)
      K=PRIND(LTEMP)+1
      L=PRIND(LTEMP+1)
C
          DO 200 PRD=K,L
          M = PRLEN(PRD)
          M = 8 * (M - 1)
          M = RIGHT (J, M)
          IF (M .NE. PRTB(PRD)) GO TO 200
          IF (.NOT. PROK(PRD)) GO TO 200
          MP = SP -PRLEN(PRD)+1
          MPP1 = MP+1
          J = HDTB(PRD)
          CALL SYNTH(PRDTB(PRD),J)
          SP = MP
          PSTACK(SP) = J
          VARTOP=RIGHT(VAR(SP),12)
          GO TO 9999
C
200       CONTINUE
300   CONTINUE
C     NO APPLICABLE PRODUCTION
      CALL ERROR(4,1)
      FAILSF = .FALSE.
      CALL SDUMP
      CALL RECOV
9999  RETURN
      END
      SUBROUTINE CLOOP
      LOGICAL STACK
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      INTEGER SHL,SHR,RIGHT
      COMPIL = .TRUE.
100   IF (.NOT. COMPIL) GO TO 9999
      IF (.NOT. STACK(0)) GO TO 400
C     STACK MAY HAVE SET COMPILING FALSE
      IF (.NOT.COMPIL) GO TO 9999
      SP = SP + 1
      IF (SP .LT. MSTACK) GO TO 300
          CALL ERROR(5,5)
          GO TO 9999
300   PSTACK(SP) = TOKEN
C     INSERT ACCUM INTO VARC HERE
      IF (TOKEN .NE. NUMBV) GO TO 302
      CALL CONV(16)
      IF (VALUE.GE.0) GO TO 301
          CALL ERROR(6,1)
          VALUE = 0
301   FIXV(SP) = VALUE
302   VAR(SP) = VARTOP
305   IF (ACCLEN .EQ. 0) GO TO 315
          DO 310 J=1,ACCLEN
          VARC(VARTOP) = ACCUM(J)
          VARTOP = VARTOP + 1
          IF (VARTOP .LE. MVAR) GO TO 310
              CALL ERROR(7,5)
              VARTOP = 1
310       CONTINUE
315   IF (TOKEN .NE. STRV) GO TO 360
      IF (STYPE .NE. CONT) GO TO 360
      CALL SCAN
      GO TO 305
360   I = VARTOP-VAR(SP)
      IF (I .LT. 0) I = 1
      VAR(SP) = SHL(I,12) + VAR(SP)
      CALL SCAN
      GO TO 100
400   CALL REDUCE
      GO TO 100
9999  RETURN
      END
      SUBROUTINE PRSYM(CC,SYM)
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER CC,SYM,SHL,SHR,RIGHT
      INTEGER PBUFF(30)
      K=VLOC(SYM+1)
      IF (SYM .GT. NT) GO TO 100
      L = V(K)
      CALL FORM(CC,V,K+1,K+L,NSY+1)
      GO TO 9999
100   CONTINUE
      L = RIGHT(K,15)-1
      K = SHR(K,15)
      KP = 0
          DO 300 I=1,K,PACK
          L = L + 1
          LP = V(L)
          JP = PACK * 6
               DO 300 J=1,PACK
               JP = JP - 6
               KP = KP + 1
               IP = SHR(LP,JP)
               PBUFF(KP) = RIGHT(IP,6)+1
300        CONTINUE
C
      CALL FORM(CC,PBUFF,1,K,30)
9999  RETURN
      END
      INTEGER FUNCTION GETC1(I,J)
      INTEGER SHL,SHR,RIGHT
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      K = (NT+1)*I+J
      L = K/15+1
      L = C1(L)
      M = SHL(14-MOD(K,15),1)
      GETC1=RIGHT(SHR(L,M),2)
      RETURN
      END
      SUBROUTINE SCAN
      INTEGER GNC,SHL,SHR,RIGHT
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
C     SCAN FINDS THE NEXT ENTITY IN THE INPUT STREAM
C     THE RESULTING ITEM IS PLACED INTO ACCUM (OF LENGTH
C     ACCLEN).  TYPE AND STYPE IDENTIFY THE ITEM AS SHOWN
C     BELOW --
C     TYPE     STYPE         ITEM           VARIABLE
C       1        NA        END OF FILE       EOFLAG
C       2       CONT       IDENTIFIER        IDENT
C       3       RADIX      NUMBER            NUMB
C       4        NA        SPEC CHAR         SPECL
C       5        CONT      STRING            STR
C
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
      FAILSF = .TRUE.
10    I=GNC(0)
      ACCLEN = 0
      IF (STYPE .NE. CONT) GO TO 51
      GO TO (100,200,51,51,499), TYPE
C     DEBLANK INPUT
50    I = GNC(0)
51    IF (I .EQ. 0) GO TO 100
      GO TO (50,300,300,300,300,300,300,300,300,300,300,
     1      200,200,200,200,200,200,200,200,200,200,
     2      200,200,200,200,200,200,200,200,200,200,
     3      200,200,200,200,200,200,
     4      400,400,400,400,400,400,400,400,400,400,
     5      400,400,400,400,400,400,400,400,400,400,
     6      400,400,400,400,400,400,400),I
C     END OF FILE
100   TYPE = EOFLAG
      GO TO 999
C     IDENTIFIER
200   TYPE = IDENT
210   ACCLEN = ACCLEN + 1
      ACCUM(ACCLEN) = I
      IF (ACCLEN .GE. 32) GO TO 220
215   I = GNC(0)
C     CHECK FOR $ WITHIN AN IDENTIFIER
      IF (I.EQ.38) GO TO 215
      IF ((I .GE. 2) .AND. (I .LE. 37)) GO TO 210
      CALL DECIBP
      STYPE = 0
      GO TO 999
220   STYPE = CONT
      GO TO 999
C
C
C     NUMBER
300   TYPE = NUMB
      STYPE = 0
310   ACCLEN = ACCLEN +1
      ACCUM(ACCLEN) = I
      IF (ACCLEN .EQ. 32) GO TO 350
312   I = GNC(0)
C     CHECK FOR $ IN NUMBER
      IF (I.EQ.38) GO TO 312
      IF ((I .GE. 2) .AND. (I .LE. 17)) GO TO 310
C     CHECK RADIX
      IF (I .EQ. 19) STYPE = 16
      IF (I .EQ. 28) STYPE = 8
      IF (I .EQ. 26) STYPE = 8
      IF (STYPE .NE. 0) GO TO 325
      IF (ACCUM(ACCLEN) .EQ. 13) GO TO 315
      IF (ACCUM(ACCLEN) .EQ. 15) GO TO 318
      STYPE = 10
      GO TO 320
315   STYPE = 2
      ACCLEN = ACCLEN - 1
      GO TO 320
318   STYPE = 10
      ACCLEN = ACCLEN -1
320   CALL DECIBP
325       DO 330 I=1,ACCLEN
          J = ACCUM(I) -2
          IF (J.GE.STYPE) GO TO 340
330       CONTINUE
      GO TO 999
340   STYPE = 1
      GO TO 999
350   STYPE = 1
351   I = GNC(0)
      IF ((I .GE. 2) .AND. (I .LE. 17)) GO TO 351
      CALL DECIBP
      GO TO 999
C     SPECIAL CHARACTER (TEST FOR QUOTE)
400   CONTINUE
      IF (I .EQ. 46) GO TO 500
      TYPE = SPECL
      ACCLEN = 1
      ACCUM(1) = I
      IF (I .NE. 41) GO TO 999
      I = GNC(0)
C     LOOK FOR COMMENT
      IF (I .EQ. 47) GO TO 410
      CALL DECIBP
      GO TO 999
C     COMMENT FOUND
410   I = GNC (0)
      IF (I .EQ. 0) GO TO 100
      IF (I .NE. 47) GO TO 410
      I = GNC(0)
      IF (I .EQ. 41) GO TO 420
      CALL DECIBP
      GO TO 410
420   ACCLEN = 0
      GO TO 50
C     CONTINUE WITH STRING
499   CALL DECIBP
C     STRING QUOTE
500   TYPE = STR
      ACCUM(1) = 1
510   I = GNC(0)
      IF (I .EQ. 46) GO TO 530
520   ACCLEN = ACCLEN +1
      ACCUM(ACCLEN) = I
      IF (ACCLEN .LT. 32) GO TO 510
      STYPE = CONT
      GO TO 999
C     STRING QUOTE FOUND (ENDING, MAYBE)
530   I = GNC(0)
      IF (I. EQ. 46) GO TO 520
      CALL DECIBP
      STYPE = 0
C     THE CODE BELOW IS HERE TO SATISFY THE SYNTAX ANALYZER
999   IF (TYPE.EQ.EOFLAG) GO TO 2000
      TOKEN = STRV
      IF (TYPE .EQ. STR) RETURN
      TOKEN = 0
      IF (ACCLEN .GT. VIL) GO TO 3000
C     SEARCH FOR TOKEN IN VOCABULARY
      J = VINDX(ACCLEN)+1
      K = VINDX(ACCLEN+1)
          DO 1300 I=J,K
          L = VLOC(I)
          LP = L + V(L)
          L = L + 1
          N = 1
              DO 1200 M=L,LP
              IF (ACCUM(N) .NE. V(M)) GO TO 1300
1200          N = N + 1
          TOKEN = I-1
          GO TO 1400
1300      CONTINUE
      GO TO 3000
1400  RETURN
2000  TOKEN = EOFILE
      RETURN
3000  IF (TYPE .NE. IDENT) GO TO 4000
      TOKEN = IDENTV
      L = MACTOP
3100  L = MACROS(L)
      IF (L .EQ. 0) GO TO 3400
      K = MACROS(L+1)
      IF (K .NE. ACCLEN) GO TO 3100
          I = L+2
          DO 3200 J=1,K
          IF (ACCUM(J) .NE. MACROS(I)) GO TO 3100
3200      I = I + 1
C     MACRO FOUND, SET-UP MACRO TABLE AND RESCAN
      CURMAC = CURMAC - 1
      IF (CURMAC .GT. MACTOP) GO TO 3300
      CALL ERROR(8,5)
      CURMAC = MAXMAC
3300      J = I + MACROS(I)
          MACROS(CURMAC) = SHL(I,12)+J
      GO TO 10
3400  CONTINUE
4000  IF (TYPE .EQ. NUMB) TOKEN = NUMBV
      RETURN
      END
      INTEGER FUNCTION WRDATA(SY)
      INTEGER SY
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      LOGICAL DFLAG
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
C     IF SY IS NEGATIVE, THE CALL COMES FROM SYNTH -- DATA IS INSERTED
C     INLINE BY CALLING LIT WITH EACH BYTE VALUE.
C
C     IF SY IS POSITIVE, THE CALL COMES FROM DUMPIN --
C     WRDATA WRITES DATA INTO THE OUTPUT FILE FROM SYMBOL AT LOCATION
C     'SY'  EACH BYTE VALUE IS WRITTEN AS A PAIR OF BASE 32 DIGITS.
C     THE HIGH ORDER BIT OF THE FIRST DIGIT IS 1, AND ALL REMAINING HIGH
C     ORDER DIGITS ARE ZERO. THE VALUE RETURNED BY WRDATA IS THE TOTAL
C     NUMBER OF BYTES WRITTEN.
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER ASCII(64)
      COMMON /ASC/ASCII
      INTEGER SHL, SHR, RIGHT
      NBYTES = 0
      J = IABS(SY)
C
C     CHECK PRECISION OF VALUE
      K = SYMBOL(J+1)
C     SET DFLAG TO TRUE IF WE ARE DUMPING A VARIABLE OR LABEL NAME
      L = RIGHT(K,4)
      DFLAG = (L.EQ.LABEL).OR.(L.EQ.VARB).OR.(L.EQ.PROC)
      L = RIGHT(SHR(K,4),4)
      IF ((L.GT.2).OR.DFLAG) GO TO 400
C
C     SINGLE OR DOUBLE BYTE CONSTANT
      KP = SHR(K,8)
      K = 16
      NBYTES = L
C
200   IF (L.LE.0) GO TO 9999
C     PROCESS NEXT BYTE
          L = L - 1
          N = RIGHT(SHR(KP,L*8),8)
          IF (SY.LT.0) GO TO 350
C         N IS THEN WRITTEN IN TWO PARTS
              DO 300 I=1,2
              K  = RIGHT(SHR(N,(2-I)*4),4) + K + 2
              CALL PAD(1,K,1)
300           K = 0
C
          GO TO 200
C
C     OTHERWISE EMIT DATA INLINE
350   CALL EMIT(N,LIT)
      GO TO 200
C
C    WRITE OUT STRING DATA
400   CONTINUE
      L = RIGHT(IABS(SYMBOL(J)),12)
      J = J + 1
      K = 16
      N = - 1
      NP = (PACK-1)*6
      LP = 1
C
500   IF (LP.GT.L) GO TO 9999
      IF (N.GE.0) GO TO 600
          N = NP
          J = J + 1
          M = SYMBOL(J)
C
600   CONTINUE
      NBYTES = NBYTES + 1
      KP = RIGHT(SHR(M,N),6)+1
      IF (DFLAG) GO TO 900
          KP = ASCII(KP)
C
C    WRITE OUT BOTH HEX VALUES
      IF (SY.LT.0) GO TO 800
C
          DO 700 IP=1,2
          K = RIGHT(SHR(KP,(2-IP)*4),4) + K + 2
          CALL PAD(1,K,1)
700       K = 0
710   N = N - 6
      LP = LP + 1
      GO TO 500
C
C     EMIT STRING DATA INLINE
800   CALL EMIT(KP,LIT)
      GO TO 710
C
C     WRITE OUT THE VARIABLE OR LABEL NAME
900   CALL PAD(1,KP,1)
      GO TO 710
9999  WRDATA = NBYTES
      RETURN
      END
      SUBROUTINE DUMPCH
C     DUMP THE SYMBOLIC NAMES FOR THE SIMULATOR
      INTEGER SHR,SHL,RIGHT
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER WRDATA
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      CALL WRITEL(0)
      KT = CONTRL(26)
      CONTRL(26) = CONTRL(32)
      KQ = CONTRL(34)
      CONTRL(34) = CONTRL(33)
C
      K = 0
      I = 2
      IF (SYMBOL(2).EQ.0) I=0
      CALL PAD(1,41,1)
200   IF (I.EQ.0) GO TO 1000
          K = K + 1
          J = SYMBOL(I+2)
          IF (J.LT.0) GO TO 400
          J = MOD(J,16)
          IF ((J.NE.LABEL).AND.(J.NE.VARB).AND.(J.NE.PROC)) GO TO 400
C         CHECK FOR NO CHARACTERS
          J = IABS(SYMBOL(I+1))
C         CHECK FOR NO WORDS ALLOCATED
          IF (SHR(J,12).EQ.0) GO TO 400
C         WRITE SYMBOL NUMBER
          M = K
              DO 300 L=1,3
              CALL PAD(1,MOD(M,32)+2,1)
              M = M/32
300           CONTINUE
C         NOW WRITE THE STRING
          M = WRDATA(I+1)
          CALL PAD(1,41,1)
400       I = SYMBOL(I)
      GO TO 200
C
1000  CALL PAD(1,41,1)
      CALL WRITEL(0)
      CONTRL(26) = KT
      CONTRL(34) = KQ
      RETURN
      END
      SUBROUTINE SYNTH(PROD,SYMM)
C
C    MP == LEFT ,  SP == RIGHT
C
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER PROD,SYMM,SHL,SHR,RIGHT,ENTER,LOOKUP,WRDATA
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      INTEGER POLISH(30),MAXPOL,POLTOP,POLCNT,POLCHR(18)
      COMMON /POLE/POLISH,MAXPOL,POLTOP,POLCNT,POLCHR
      INTEGER ASCII(64)
      COMMON /ASC/ASCII
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      IF(CONTRL(12).NE.0) CALL REDPR(PROD,SYMM)
C    1     1     2     3     4     5     6     7     8     9    10
C    2    11    12    13    14    15    16    17    18    19    20
C    3    21    22    23    24    25    26    27    28    29    30
C    4    31    32    33    34    35    36    37    38    39    40
C    5    41    42    43    44    45    46    47    48    49    50
C    6    51    52    53    54    55    56    57    58    59    60
C    7    61    62    63    64    65    66    67    68    69    70
C    8    71    72    73    74    75    76    77    78    79    80
C    9    81    82    83    84    85    86    87    88    89    90
C    A    91    92    93    94    95    96    97    98    99   100
C    B   101   102   103   104   105   106   107   108   109   110
C    C   111   112   113   114   115   116   117   118   119   120
C    D   121   122   123   124   125   126   127   128   129   130
      GO TO (
     1    100,99999,99999,99999,99999,  600,99999,  800,99999,99999,
     2  99999,  800, 1300, 1340, 1360,99999,99999, 1500, 1600,99999,
     3   1800, 1900, 2000, 2100, 2200, 2300, 2400, 2500, 2600, 2700,
     4   2800, 2900,99999, 3100, 3200, 3300, 3400, 3500, 3540, 3600,
     5   3700, 3800, 3700, 4000, 4100, 4200, 4300, 4350, 4400, 4500,
     6   4600, 4700, 5000,99999,99999,99999,99999,99999, 5300, 5600,
     7   5610, 5620, 5610, 5400, 5500,99999, 5700, 5800, 5900,99999,
     8   6100, 6400, 6300, 6400, 6500, 6600, 6500, 6800, 6900, 6800,
     9   7100, 7100,99999,99999,99999, 7500,99999, 7600, 7700,99999,
     1   7900,99999, 8100,99999, 8300, 8400, 8400, 8400, 8400, 8400,
     2   8400,99999, 9300, 9300, 9300, 9300, 9400,99999,10000,10000,
     3  10000,10300,10310,10320,10400,10500,99999,10550,10560,10600,
     4  10700,10800,10900,11000,11100,11200,11300,11400),PROD
C     P R O D U C T I O N S
C     <PROGRAM> ::= <STATEMENT LIST>
C     <STATEMENT LIST> ::= <STATEMENT>
100   CONTINUE
      IF (MP .NE. 5) CALL ERROR(10,1)
      COMPIL = .FALSE.
      CALL EXITB
      GO TO 99999
C     <STATEMENT LIST> ::= <STATEMENT LIST> <STATEMENT>
C     <STATEMENT> ::= <BASIC STATEMENT>
C     <STATEMENT> ::= <IF STATEMENT>
C     <BASIC STATEMENT> ::= <ASSIGNMENT> ;
600   IF (ACNT .LE. 0) GO TO 630
      LTEMP=MAXSYM-ACNT
      I=SYMBOL(LTEMP)
      ACNT = ACNT - 1
      IF (I.GT.0) GO TO 610
          CALL EMIT(XCH,OPR)
          GO TO 620
610   J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),ADR)
620   IF(ACNT.GT.0) CALL EMIT(STO,OPR)
      GO TO 600
630   I = STD
      GO TO 88888
C     <BASIC STATEMENT> ::= <GROUP> ;
C     <BASIC STATEMENT> ::= <PROCEDURE DEFINITION> ;
800   CONTINUE
      I = DOPAR(CURBLK)
      I = RIGHT(I,2)
      IF (I.EQ.0) GO TO 99999
      CALL ERROR(11,1)
      GO TO 99999
C     <BASIC STATEMENT> ::= <RETURN STATEMENT> ;
C     <BASIC STATEMENT> ::= <CALL STATEMENT> ;
C     <BASIC STATEMENT> ::= <GO TO STATEMENT> ;
C     <BASIC STATEMENT> ::= <DECLARATION STATEMENT> ;
C     <BASIC STATEMENT> ::= HALT
1300  I = HAL
      GO TO 88888
C     <BASIC STATEMENT> ::= ENABLE;
1340  CONTINUE
      I = ENA
      GO TO 88888
C     <BASIC STATEMENT> ::= DISABLE;
1360  CONTINUE
      I = DIS
      GO TO 88888
C     <BASIC STATEMENT> ::= ;
C     <BASIC STATEMENT> ::= <LABEL DEFINITION> <BASIC STATEMENT>
1500  I = FIXV(MP)
      GO TO 1610
C     <IF STATEMENT> ::= <IF CLAUSE> <STATEMENT>
1600  I = FIXV(MP)
1610  J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),DEF)
      SYMBOL(I+1) = 64+LABEL
      GO TO 99999
C     <IF STATEMENT> ::= <IF CLAUSE> <TRUE PART> <STATEMENT>
C     <IF STATEMENT> ::= <LABEL DEFINITION> <IF STATEMENT>
C     <IF CLAUSE> ::= IF <EXPRESSION> THEN
1800  I = ENTER(-LABEL)
      J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),VLU)
      CALL EMIT(TRC,OPR)
      FIXV(MP) = I
      GO TO 99999
C     <TRUE PART> ::= <BASIC STATEMENT> ELSE
1900  I = ENTER(-LABEL)
      J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),VLU)
      CALL EMIT(TRA,OPR)
      J = FIXV(MP-1)
      FIXV(MP-1) = I
      I = J
      GO TO 1610
C     <GROUP> ::= <GROUP HEAD> <ENDING>
2000  IF (FIXV(SP).GT.0) CALL ERROR(12,1)
      IF (FIXC(SP).LT.0) FIXC(MP) = 0
      I = DOPAR(CURBLK+1)
      J = RIGHT(I,2) + 1
      I = SHR(I,2)
      GO TO (2060,2050,2040,2005),J
C     GENERATE DESTINATION OF CASE BRANCH
2005  J = RIGHT(I,14)
      K = SHR(SYMBOL(J-1),16)
      CALL EMIT(K,DEF)
      M = SHR(SYMBOL(J+1),8)
      SYMBOL(J+1) = RIGHT(SYMBOL(J+1),8)
C     M IS SYMBOL NUMBER OF LABEL AT END OF JUMP TABLE
      CALL EMIT(CSE,OPR)
C     DEFINE THE JUMP TABLE
      I = SHR(I,14)
C     REVERSE THE LABEL LIST
      L = 0
2010  IF (I.EQ.0) GO TO 2020
          K = SYMBOL(I+1)
          SYMBOL(I+1) = SHL(L,8)+RIGHT(K,8)
          L = I
          I = SHR(K,8)
          GO TO 2010
C     EMIT LIST STARTING AT L
2020      I = SYMBOL(L+1)
          SYMBOL(L+1) = 64 + LABEL
          J = SHR(I,8)
          IF (J.EQ.0) GO TO 2030
          K = SHR(SYMBOL(L-1),16)
2025      CALL EMIT(K,VLU)
          CALL EMIT(AX2,OPR)
          L = J
          GO TO 2020
2030  CONTINUE
C     DEFINE END OF JUMP TABLE
      CALL EMIT(M,DEF)
      GO TO 99999
C     DEFINE END OF WHILE STATEMENT
2040  J = SHR(I,14)
      I = RIGHT(I,14)
      CALL EMIT(J,VLU)
      CALL EMIT(TRA,OPR)
      CALL EMIT(I,DEF)
      GO TO 99999
C     END OF ITERATIVE STATEMENT
2050  K = FIXV(MP)
      IF (K.EQ.0) GO TO 2040
C     OTHERWISE INCREMENT VARIABLE
      CALL EMIT(K,VLU)
      CALL EMIT(INC,OPR)
      CALL EMIT(K,ADR)
      CALL EMIT(STD,OPR)
C     DEFINE ENDING BRANCH AND LABEL
      GO TO 2040
2060  I = END
      GO TO 88888
C     <GROUP HEAD> ::= DO ;
2100  CALL ENTERB
      I = ENB
      GO TO 88888
C     <GROUP HEAD> ::= DO <STEP DEFINITION> ;
2200  CALL ENTERB
      DOPAR(CURBLK) = 1 +  SHL(FIXV(MP+1),2)
      GO TO 99999
C     <GROUP HEAD> ::= DO <WHILE CLAUSE> ;
2300  CALL ENTERB
      DOPAR(CURBLK) = 2 + SHL(FIXV(MP+1),2)
      GO TO 99999
C     <GROUP HEAD> ::= DO <CASE SELECTOR> ;
2400  CALL ENTERB
      K = ENTER(-(64+LABEL))
      K = SHR(SYMBOL(K-1),16)
C     K IS LABEL AFTER CASE JUMP TABLE
      I = ENTER(-(SHL(K,8)+64+LABEL))
      J = SHR(SYMBOL(I-1),16)
      CALL EMIT(J,VLU)
      CALL EMIT(AX1,OPR)
      DOPAR(CURBLK) = SHL(I,2)+3
2410  I = DOPAR(CURBLK)
      K = SHR(I,16)
      J = ENTER(-(SHL(K,8)+64+LABEL))
      DOPAR(CURBLK) = SHL(J,16) + RIGHT(I,16)
      J = SHR(SYMBOL(J-1),16)
      CALL EMIT(J,DEF)
      GO TO 99999
C     <GROUP HEAD> ::= <GROUP HEAD> <STATEMENT>
2500  CONTINUE
      I = DOPAR(CURBLK)
      IF (RIGHT(I,2).NE.3) GO TO 99999
C     OTHERWISE CASE STMT
      J = RIGHT(SHR(I,2),14)
      J = SYMBOL(J+1)
      J = SHR(J,8)
      CALL EMIT(J,VLU)
      CALL EMIT(TRA,OPR)
      GO TO 2410
C     <STEP DEFINITION> ::= <VARIABLE> <REPLACE> <EXPRESSION> <ITERATION
C
2600  I = FIXV(MP)
      J = FIXV(MP+3)
      IF (J.GE.0) I = 0
C     PLACE <VARIABLE> SYMBOL NUMBER INTO DO SLOT
      FIXV(MP-1) = I
      FIXV(MP) = IABS(J)
      GO TO 99999
C     <ITERATION CONTROL> ::= <TO> <EXPRESSION>
2700  CALL EMIT(LEQ,OPR)
      I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
      CALL EMIT(I,VLU)
      CALL EMIT(TRC,OPR)
      FIXV(MP) = - (SHL(FIXV(MP),14)+I)
C     SEND  -(BACK BRANCH NUMBER/END LOOP NUMBER)
      GO TO 99999
C     <ITERATION CONTROL> ::= <TO> <EXPRESSION> <BY> <EXPRESSION>
2800  I = FIXV(MP-3)
C     I = SYMBOL NUMBER OF INDEXING VARIABLE
      CALL EMIT(I,VLU)
      CALL EMIT(ADD,OPR)
      CALL EMIT(I,ADR)
      CALL EMIT(STD,OPR)
C     BRANCH TO COMPARE
      I = FIXV(MP+2)
      J = SHR(I,14)
      CALL EMIT(J,VLU)
      CALL EMIT(TRA,OPR)
C     DEFINE BEGINNING OF STATEMENTS
      J = RIGHT(I,14)
      CALL EMIT(J,DEF)
C     <TO> ALREADY HAS (BACK BRANCH NUMBER/END LOOP NUMBER)
      GO TO 99999
C     <WHILE CLAUSE> ::= <WHILE> <EXPRESSION>
2900  I = ENTER(-(64+LABEL))
      J = FIXV(MP)
      I = SHR(SYMBOL(I-1),16)
      FIXV(MP) = SHL(J,14)+I
C     (BACK BRANCH NUMBER/END LOOP NUMBER)
      CALL EMIT(I,VLU)
      I = TRC
      GO TO 88888
C     <CASE SELECTOR> ::= CASE <EXPRESSION>
C     <PROCEDURE DEFINITION> ::= <PROCEDURE HEAD> <STATEMENT LIST> <ENDI
3100  I = FIXV(MP)
      K = SHR(I,15)
      I = RIGHT(I,15)
      J = FIXV(SP)
      IF (J.LT.0) J = -J+1
      IF ((J.NE.0).AND.(I.NE.J)) CALL ERROR(13,1)
      I = SHR(SYMBOL(K-1),16)
      CALL EMIT(END,OPR)
C     EMIT A RET JUST IN CASE HE FORGOT IT
      CALL EMIT(DRT,OPR)
      CALL EMIT(I,DEF)
      GO TO 99999
C     <PROCEDURE HEAD> ::= <PROCEDURE NAME> ;
3200  L = 0
      K = 0
      GO TO 3450
C     <PROCEDURE HEAD> ::= <PROCEDURE NAME> <TYPE> ;
3300  L = 0
      K = FIXV(SP-1)
      GO TO 3510
C     <PROCEDURE HEAD> ::= <PROCEDURE NAME> <PARAMETER LIST> ;
3400  L = FIXV(MP+1)
      K = 0
3450  PROCTP(CURBLK)=1
      GO TO 3520
C     <PROCEDURE HEAD> ::= <PROCEDURE NAME> <PARAMETER LIST> <TYPE> ;
3500  L = FIXV(MP+1)
      K = FIXV(SP-1)
3510  PROCTP(CURBLK)=2
3520  I = FIXV(MP)
      SYMBOL(I+1) = SHL(L,8)+SHL(K,4)+PROC
      J = ENTER(-(64+LABEL))
      FIXV(MP) = SHL(J,15) + I
      J = SHR(SYMBOL(J-1),16)
      CALL EMIT(J,VLU)
      CALL EMIT(TRA,OPR)
      I = SHR(SYMBOL(I-1),16)
      CALL EMIT(I,DEF)
      GO TO 99999
C     <PROCEDURE HEAD> ::= <PROCEDURE NAME> INTERRUPT <NUMBER>;
3540  CONTINUE
C     GET SYMBOL NUMBER
      I = FIXV(MP)
      I = SYMBOL(I-1)
      I = SHR(I,16)
C     GET INTERRUPT NUMBER
      J = FIXV(SP-1)
      IF (J.LE.7) GO TO 3550
      CALL ERROR(39,1)
      GO TO 3200
3550  J = J + 1
      K = INTPRO(J)
C     IS INTERRUPT DUPLICATED
      IF (K.LE.0) GO TO 3560
      CALL ERROR(40,1)
      GO TO 3200
3560  INTPRO(J) = I
      GO TO 3200
C     <PROCEDURE NAME> ::= <LABEL DEFINITION> PROCEDURE
3600  CONTINUE
      CALL ENTERB
      I = ENP
      GO TO 88888
C     <PARAMETER LIST> ::= <PARAMETER HEAD> <IDENTIFIER> )
3700  CONTINUE
      I = LOOKUP(SP-1)
      IF (I.GE.BLKSYM) CALL ERROR(14,1)
      I = ENTER(VARB)
      FIXV(MP) = FIXV(MP)+1
      GO TO 99999
C     <PARAMETER HEAD> ::= (
3800  FIXV(MP) = 0
      GO TO 99999
C     <PARAMETER HEAD> ::= <PARAMETER HEAD> <IDENTIFIER> ,
C     <ENDING> ::= END
4000  CALL EXITB
      FIXV(MP) = 0
      GO TO 99999
C     <ENDING> ::= END <IDENTIFIER>
4100  CALL EXITB
      I = LOOKUP(SP)
      IF (I .EQ. 0) CALL ERROR(15,1)
      FIXV(MP) = I
      GO TO 99999
C     <ENDING> ::= <LABEL DEFINITION> <ENDING>
4200  FIXV(MP) = FIXV(SP)
      GO TO 99999
C     <LABEL DEFINITION> ::= <IDENTIFIER> :
4300  I = LOOKUP(MP)
      IF (CURBLK.EQ.2) IP = 48
      IF (CURBLK.NE.2) IP = 64
      IF (I.GE.BLKSYM) GO TO 4310
C
C         PREC = 3 IF USER-DEFINED OUTER BLOCK LABEL
C         PREC = 4 IF USER-DEFINED LABEL NOT IN OUTER BLOCK
C         PREC = 5 IF COMPILER-GENERATED LABEL
      I = ENTER (IP+LABEL)
      GO TO 4320
4310  J = SYMBOL(I+1)
      J = RIGHT(SHR(J,4),4)
      K = I + 1
      IF (J.EQ.0) GO TO 4315
          CALL ERROR(16,1)
          SYMBOL(K) = SYMBOL(K) - J*16
4315  SYMBOL(K) = SYMBOL(K) + IP
4320  FIXV(MP) = I
      IF (TOKEN .EQ. PROCV) GO TO 99999
      I = SYMBOL(I-1)
      CALL EMIT(SHR(I,16),DEF)
      GO TO 99999
C     <LABEL DEFINITION> ::= <NUMBER> :
4350  CONTINUE
      I = ORG
      J = MP
4360  K = FIXV(J)
      IF (K.LE.65535) GO TO 4370
          CALL ERROR(17,1)
          GO TO 99999
4370  CONTINUE
      L = LOOKUP(J)
      IF (L.NE.0) GO TO 4380
C     ENTER NUMBER
      J = 1
      IF (K.GT.255) J = 2
      L = ENTER(SHL(K,8)+SHL(J,4)+LITER+1)
4380  L = SYMBOL(L-1)
      CALL EMIT(SHR(L,16),VLU)
      GO TO 88888
C     <RETURN STATEMENT> ::= RETURN
4400  CALL EMIT(0,LIT)
      I = RET
      IF(PROCTP(CURBLK).EQ.2) CALL ERROR(45,1)
      IF(PROCTP(CURBLK).EQ.0) CALL ERROR(46,1)
      GO TO 88888
C     <RETURN STATEMENT> ::= RETURN <EXPRESSION>
4500  I = RET
      IF(PROCTP(CURBLK).EQ.1) CALL ERROR(44,1)
      IF(PROCTP(CURBLK).EQ.0) CALL ERROR(46,1)
      GO TO 88888
C     <CALL STATEMENT> ::= CALL <VARIABLE>
4600  I = FIXV(SP)
      IF (I.EQ.0) GO TO 99999
      IF (I.GT.0) GO TO 4620
4610      CALL ERROR(18,1)
          GO TO 99999
4620  J = SYMBOL(I+1)
      J = RIGHT(J,4)
      I = SHR(SYMBOL(I-1),16)
      CALL EMIT(I,ADR)
      I = 0
      IF (J.EQ.PROC) I = PRO
      IF (J.EQ.INTR) I = BIF
      IF (I.EQ.0) GO TO 4610
      GO TO 88888
C     <GO TO STATEMENT> ::= <GO TO> <IDENTIFIER>
4700  CONTINUE
      I = LOOKUP(SP)
      IF(I .EQ. 0) I= ENTER(LABEL)
      J=SYMBOL(I+1)
      J = RIGHT(J,4)
      IF ((J.EQ.LABEL).OR.(J.EQ.VARB)) GO TO 4710
      CALL ERROR(19,1)
      GO TO 99999
C     INCREMENT THE REFERENCE COUNTER (USE LENGTH FIELD)
4710  IF (J.EQ.LABEL) SYMBOL(I+1) = SYMBOL(I+1) + 256
      I = SYMBOL(I-1)
      CALL EMIT(SHR(I,16),VLU)
      I = TRA
      GO TO 88888
C     <GO TO STATEMENT> ::= <GOTO> <NUMBER>
5000  J = SP
      I = TRA
      GO TO 4360
C     <GO TO> ::= GO TO
C     <GO TO> ::= GOTO
C     <DECLARATION STATEMENT> ::= DECLARE <DECLARATION ELEMENT>
C     <DECLARATION STATEMENT> ::= <DECLARATION STATEMENT> , <DECLARATION
C
C     <DECLARATION ELEMENT> ::= <TYPE DECLARATION>
C     <DECLARATION ELEMENT> ::= <IDENTIFIER> LITERALLY <STRING>
 5300 CONTINUE
      L = MP
      K = MACTOP
          DO 5330 M = 1,2
          I = VAR(L)
          IP = SHR(I,12)
          I = RIGHT(I,12)-1
          K = K + 1
          IF (K .GE. CURMAC) GO TO 5390
          MACROS(K) = IP
              DO 5320 J=1,IP
              K = K + 1
              IF (K .GE. CURMAC) GO TO 5390
              LTEMP=I+J
              MACROS(K)=VARC(LTEMP)
5320          CONTINUE
          L = SP
5330      CONTINUE
C
      K = K + 1
      IF (K .GE. CURMAC) GO TO 5390
          MACROS(K) = MACTOP
          MACTOP = K
          GO TO 99999
5390  CALL ERROR(20,5)
      GO TO 99999
C     <TYPE DECLARATION> ::= <IDENTIFIER SPECIFICATION> <TYPE>
5400  N = 1
5410  I = FIXV(MP)
      J = SHR(I,15)
      I = RIGHT(I,15)
      K = FIXV(SP)
          DO 5420 L = J,I
          M = SYMBOL(L)+1
          IP = SYMBOL(M)
              IF (K.NE.0) GO TO 5430
              IF (IP.NE.1) CALL ERROR(21,1)
              IP = LABEL
5430      CONTINUE
          SYMBOL(M) = SHL(N,8)+SHL(K,4)+RIGHT(IABS(IP),4)
          IF (IP .LT. 0) SYMBOL(M) = - SYMBOL(M)
5420      CONTINUE
C
      MAXSYM = I
      FIXV(MP) = SYMBOL(I)
      GO TO 99999
C     <TYPE DECLARATION> ::= <BOUND HEAD> <NUMBER> ) <TYPE>
5500  N = FIXV(MP+1)
      GO TO 5410
C     <TYPE DECLARATION> ::= <TYPE DECLARATION> <INITIAL LIST>
C     <DECLARATION ELEMENT> ::= <IDENTIFIER> <DATA LIST>
5600  I = FIXV(MP)+1
      J = FIXV(MP+1)
      L = RIGHT(J,16)
      SYMBOL(I) = SHL(L,8) + SYMBOL(I)
      J = SHR(J,16)
      CALL EMIT(DAT,OPR)
      CALL EMIT(J,DEF)
      I = DAT
      GO TO 99999
C     <DATA LIST> ::= <DATA HEAD> <CONSTANT> )
5610  I = FIXV(MP+1)
      FIXV(MP) = FIXV(MP) + WRDATA(-I)
      GO TO 99999
C     <DATA HEAD> ::= DATA (
5620  J = ENTER(-(64+LABEL))
      J = SHR(SYMBOL(J-1),16)
      CALL EMIT(J,VLU)
      CALL EMIT(TRA,OPR)
      FIXV(MP) = SHL(J,16)
      I = LOOKUP(MP-1)
      IF (I.LE.BLKSYM) GO TO 5630
          CALL ERROR(22,1)
C     SET PRECISION OF INLINE DATA TO 3
5630  I = ENTER(48+VARB)
      FIXV(MP-1) = I
      I = SHR(SYMBOL(I-1),16)
      CALL EMIT(DAT,OPR)
      CALL EMIT(I,DEF)
C     COUNT THE NUMBER OF BYTES EMITTED
      GO TO 99999
C     <DATA HEAD> ::= <DATA HEAD> <CONSTANT> ,
C     <TYPE> ::= BYTE
5700  FIXV(MP) = 1
      GO TO 99999
C     <TYPE> ::= ADDRESS
5800  FIXV(MP) = 2
      GO TO 99999
C     <TYPE> ::= LABEL
5900  FIXV(MP) = 0
      GO TO 99999
C     <BOUND HEAD> ::= <IDENTIFIER SPECIFICATION> (
C     <IDENTIFIER SPECIFICATION> ::= <VARIABLE NAME>
6100  SYMBOL(MAXSYM) = FIXV(MP)
      FIXV(MP) = SHL(MAXSYM,15)+MAXSYM
      GO TO 99999
C     <IDENTIFIER SPECIFICATION> ::= <IDENTIFIER LIST> <VARIABLE NAME> )
C     <IDENTIFIER LIST> ::= (
6300  FIXV(MP) = MAXSYM
      GO TO 99999
C     <IDENTIFIER LIST> ::= <IDENTIFIER LIST> <VARIABLE NAME> ,
6400  IF (SYMTOP .LT. MAXSYM) GO TO 6420
6410  CALL ERROR(23,5)
      MAXSYM = SYMABS
6420  SYMBOL(MAXSYM) = FIXV(MP+1)
      FIXV(MP) = SHL(MAXSYM,15)+RIGHT(FIXV(MP),15)
      MAXSYM=MAXSYM-1
      GO TO 99999
C     <VARIABLE NAME> ::= <IDENTIFIER>
6500  CONTINUE
      I = LOOKUP(MP)
      IF (I.GT.BLKSYM) GO TO 6520
          I = ENTER(VARB)
      GO TO 6540
6520  J = RIGHT(SYMBOL(I+1),8)
      IF (J.EQ.VARB) GO TO 6540
          CALL ERROR(24,1)
6540  FIXV(MP) = I
      GO TO 99999
C     <VARIABLE NAME> ::= <BASED VARIABLE> <IDENTIFIER>
6600  I = FIXV(MP)
      J = SYMTOP
      SYMTOP = SYMTOP + 1
      IF (SYMTOP .LE. MAXSYM) GO TO 6620
          SYMTOP = SYMTOP - 1
          CALL ERROR(25,5)
          GO TO 99999
6620  SYMBOL(SYMTOP) = SYMBOL(J)
      K = LOOKUP(SP)
      IF (K .NE. 0) GO TO 6630
      K = ENTER(VARB)
      GO TO 6640
6630  L = SYMBOL(K+1)
      L = RIGHT(L,4)
      IF (L.EQ.VARB) GO TO 6640
      CALL ERROR(26,1)
      GO TO 99999
6640  K = SYMBOL(K-1)
      SYMBOL(J) = SHR(K,16)
      I = I + 1
      SYMBOL(I) = - SYMBOL(I)
      GO TO 99999
C     <BASED VARIABLE> ::= <IDENTIFIER> BASED
C     <INITIAL LIST> ::= <INITIAL HEAD> <CONSTANT> )
6800  CONTINUE
      I = FIXV(MP)
      IF (MAXSYM.LE.SYMTOP) GO TO 6410
      SYMBOL(I) = SYMBOL(I)+1
      I = FIXV(MP+1)
      I = SHL(SHR(SYMBOL(I-1),16),16) + I
      SYMBOL(MAXSYM) = I
      MAXSYM = MAXSYM - 1
      GO TO 99999
C     <INITIAL HEAD> ::= INITIAL (
6900  CONTINUE
      I = FIXV(MP-1)
      FIXV(MP) = MAXSYM
      J = MAXSYM
      MAXSYM = MAXSYM - 1
      IF (MAXSYM .LE. SYMTOP) GO TO 6410
      I = SHR(SYMBOL(I-1),16)
      SYMBOL(J) = SHL(I,15)
      GO TO 99999
C     <INITIAL HEAD> ::= <INITIAL HEAD> <CONSTANT> ,
C     <ASSIGNMENT> ::= <VARIABLE> <REPLACE> <EXPRESSION>
7100  ACNT = ACNT + 1
      I = MAXSYM - ACNT
      IF (I.GT.SYMTOP) GO TO 7110
          CALL ERROR(27,5)
          ACNT = 0
          GO TO 99999
7110  SYMBOL(I) = FIXV(MP)
C      CHECK FOR PROCEDURE ON LHS OF ASSIGNMENT.
C     ****NOTE THAT THIS IS DEPENDENT ON SYMBOL NUMBER OF OUTPUT=17****
      IF(FIXV(MP).NE.0.OR.FIXC(MP).EQ.17) GO TO 99999
      CALL ERROR(41,1)
      GO TO 99999
C     <ASSIGNMENT> ::= <LEFT PART> <ASSIGNMENT>
C     <REPLACE> ::= =
C     <LEFT PART> ::= <VARIABLE> ,
C     <EXPRESSION> ::= <LOGICAL EXPRESSION>
C     <EXPRESSION> ::= <VARIABLE> : = <EXPRESSION>
7500  CONTINUE
      I = STO
      J = FIXV(MP)
      IF(FIXV(MP).EQ.0) CALL ERROR(41,1)
      IF (J.LT.0) GO TO 7510
          J = SYMBOL(J-1)
          CALL EMIT(SHR(J,16),ADR)
          GO TO 88888
7510  CALL EMIT(XCH,OPR)
      GO TO 88888
C
C     <EXPRESSION> ::= <LOGICAL FACTOR>
C     <EXPRESSION> ::= <EXPRESSION> OR <LOGICAL FACTOR>
7600  I = IOR
      GO TO 88888
C     <EXPRESSION> ::= <EXPRESSION> XOR <LOGICAL FACTOR>
7700  I = XOR
      GO TO 88888
C     <LOGICAL FACTOR> ::= <LOGICAL SECONDARY>
C     <LOGICAL FACTOR> ::= <LOGICAL FACTOR> AND <LOGICAL SECONDARY>
7900  I = AND
      GO TO 88888
C     <LOGICAL SECONDARY> ::= <LOGICAL PRIMARY>
C     <LOGICAL SECONDARY> ::= NOT <LOGICAL PRIMARY>
8100  I = NOT
      GO TO 88888
C     <LOGICAL PRIMARY> ::= <STRING EXPRESSION>
C     <LOGICAL PRIMARY> ::= <STRING EXPRESSION> <RELATION> <STRING EXPRE
8300  I = FIXV(MP+1)
      GO TO 88888
C
C     * NOTE THAT THE CODE THAT FOLLOWS DEPENDS UPON FIXED PRODUCTION #
8400  FIXV(MP) = (PROD-96) + EQL
C     THE 96 COMES FROM THE PRODUCTION NUMBER FOR =
      GO TO 99999
C     <RELATION> ::= =
C     <RELATION> ::= <
C     <RELATION> ::= >
C     <RELATION> ::= < >
C     <RELATION> ::= < =
C     <RELATION> ::= > =
C     <STRING EXPRESSION> ::= <ARITHMETIC EXPRESSION>
C
C     <ARITHMETIC EXPRESSION> ::= <TERM>
C     * NOTE THAT THE FOLLOWING CODE DPENDS UPON FIXED PROD NUMBERS
9300  I = (PROD-103) + ADD
C     *** THE VALUES OF ADC AND SUB WERE ACCIDENTILY REVERSED ***
      IF ((I.EQ.ADC).OR.(I.EQ.SUB)) I = 5-I
      GO TO 88888
C     <ARITHMETIC EXPRESSION> ::= <ARITHMETIC EXPRESSION> + <TERM>
C     <ARITHMETIC EXPRESSION> ::= <ARITHMETIC EXPRESSION> - <TERM>
C     <ARITHMETIC EXPRESSION> ::= <ARITHMETIC EXPRESSION> PLUS <TERM>
C     <ARITHMETIC EXPRESSION> ::= <ARITHMETIC EXPRESSION> MINUS <TERM>
C     <ARITHMETIC EXPRESSION> ::= - <TERM>
9400  CONTINUE
      CALL EMIT(0,LIT)
      CALL EMIT(XCH,OPR)
      I = SUB
      GO TO 88888
C
C     <TERM> ::= <PRIMARY>
C     * NOTE THAT THE FOLLOWING CODE DEPENDS UPON FIXED PROD NUMBERS
10000 I = (PROD-109) + MUL
      GO TO 88888
C     <TERM> ::= <TERM> * <PRIMARY>
C     <TERM> ::= <TERM> / <PRIMARY>
C     <TERM> ::= <TERM> MOD <PRIMARY>
C     <PRIMARY> ::= <CONSTANT>
10300 I = FIXV(MP)
      I = SYMBOL(I-1)
      CALL EMIT(SHR(I,16),VLU)
      GO TO 99999
C     <PRIMARY> ::= . <CONSTANT>
10310 I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
      FIXV(MP) = I
      CALL EMIT(I,VLU)
      CALL EMIT(TRA,OPR)
      CALL EMIT(DAT,OPR)
      CALL EMIT(0,DEF)
C     DROP THROUGH TO NEXT PRODUCTION
C     <PRIMARY> ::= <CONSTANT HEAD> <CONSTANT> )
C     ENTER HERE FROM ABOVE ALSO
10320  I = FIXV(MP+1)
      I = WRDATA(-I)
      CALL EMIT(DAT,OPR)
      I = FIXV(MP)
      CALL EMIT(I,DEF)
      GO TO 99999
C     <PRIMARY> ::= <VARIABLE>
10400 I = FIXV(MP)
      IF (I.GT.0) GO TO 10450
      IF (I.EQ.0) GO TO 99999
C     SUBSCRIPTED VARIABLE
      I = LOD
      GO TO 88888
C     SIMPLE VARIABLE
10450 J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),VLU)
      J = SYMBOL(I+1)
      J = RIGHT(J,4)
      IF (J.EQ.PROC) CALL EMIT(PRO,OPR)
      IF (J.EQ.INTR) CALL EMIT(BIF,OPR)
      GO TO 99999
C     <PRIMARY> ::= . <VARIABLE>
10500 CONTINUE
      I = FIXV(SP)
      IF (I.GT.0) GO TO 10520
C     SUBSCRIPTED - CHANGE PRECISION TO 2
      IF (I.EQ.0) GO TO  10530
10510     I = CVA
          GO TO 88888
C
10520 J = IABS(SYMBOL(I+1))
      IF (RIGHT(J,4).EQ.VARB) GO TO 10540
10530     CALL ERROR(28,1)
          GO TO 99999
10540 J = SYMBOL(I-1)
      CALL EMIT(SHR(J,16),ADR)
      GO TO 10510
C     <PRIMARY> ::= ( <EXPRESSION> )
C     <CONSTANT HEAD> ::= . (
10550 I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
      FIXV(MP) = I
      CALL EMIT(I,VLU)
      CALL EMIT(TRA,OPR)
      CALL EMIT(DAT,OPR)
      CALL EMIT(0,DEF)
      GO TO 99999
C     <CONSTANT HEAD> ::= <CONSTANT HEAD> <CONSTANT> ,
10560  I = FIXV(MP+1)
      I = WRDATA(-I)
      GO TO 99999
C     <VARIABLE> ::= <IDENTIFIER>
10600 CONTINUE
      I = LOOKUP(MP)
      IF (I .NE. 0) GO TO 10650
      CALL ERROR(29,1)
      I = ENTER(VARB)
10650 FIXV(MP) = I
      J = IABS(SYMBOL(I+1))
      J = RIGHT(J,4)
      IF(J.EQ.LABEL) CALL ERROR(47,1)
      IF ((J.NE.PROC).AND.(J.NE.INTR)) GO TO 99999
      IF(SHR(SYMBOL(I+1),8).NE.0) CALL ERROR(38,1)
      J=RIGHT(SHR(SYMBOL(I+1),4),4)
C     IN THE STATEMENTS BELOW, 30 IS THE TOKEN FOR 'CALL'
      IF(PSTACK(MP-1).EQ.30.AND.J.NE.0) CALL ERROR(42,1)
      IF(PSTACK(MP-1).NE.30.AND.J.EQ.0) CALL ERROR(43,1)
          I = SHR(SYMBOL(I-1),16)
          I = (SHL(I,15)+I+1)
          FIXC(MP) = 0
      GO TO 10760
C     <VARIABLE> ::= <SUBSCRIPT HEAD> <EXPRESSION> )
10700 I = FIXV(MP)
      IF (I.LT.0) GO TO 10740
      FIXV(MP) = - I
      I = INX
      GO TO 88888
10740 I = -I
      CALL EMIT(RIGHT(I,15),ADR)
      IF (FIXC(MP).NE.1) CALL EMIT(STD,OPR)
      IF(IABS(FIXC(MP)).EQ.0) CALL ERROR(37,1)
      IF(IABS(FIXC(MP)).GT.1) CALL ERROR(38,1)
10760 CONTINUE
      CALL EMIT(SHR(I,15),VLU)
      FIXC(MP)=SHR(I,15)
      I = PRO
      FIXV(MP) = 0
      GO TO 88888
C     <SUBSCRIPT HEAD> ::= <IDENTIFIER> (
10800 I = LOOKUP(MP)
      IF (I.NE.0) GO TO 10840
          CALL ERROR(30,1)
          I = ENTER(VARB)
10840 J = IABS(SYMBOL(I+1))
      J = RIGHT(J,4)
      IF (J.EQ.VARB) GO TO 10860
      IF ((J.EQ.PROC).OR.(J.EQ.INTR)) GO TO 10880
          CALL ERROR(31,1)
10860 FIXV(MP) = I
      I = SYMBOL(I-1)
      CALL EMIT(SHR(I,16),ADR)
      GO TO 99999
10880 FIXC(MP) = SHR(SYMBOL(I+1),8)
      IF (J.EQ.INTR) FIXC(MP) = -FIXC(MP)
      J=RIGHT(SHR(SYMBOL(I+1),4),4)
C     IN THE STATEMENTS BELOW, 30 IS THE TOKEN FOR 'CALL'
      IF(PSTACK(MP-1).EQ.30.AND.J.NE.0) CALL ERROR(42,1)
      IF(PSTACK(MP-1).NE.30.AND.J.EQ.0)  CALL ERROR(43,1)
      I = SHR(SYMBOL(I-1),16)
      FIXV(MP) = -(SHL(I,15)+I+1)
      GO TO 99999
C     <SUBSCRIPT HEAD> ::= <SUBSCRIPT HEAD> <EXPRESSION> ,
10900 I = -FIXV(MP)
      IF (I .GT. 0) GO TO 10910
          CALL ERROR(32,1)
          GO TO 99999
10910 FIXV(MP) = -(I+1)
      J = RIGHT(I,15)
      CALL EMIT(J,ADR)
      IF (FIXC(MP).NE.0) GO TO 10920
          CALL ERROR(37,1)
          GO TO 99999
10920 IF (FIXC(MP).NE.2) CALL EMIT(STD,OPR)
      I = -1
      IF (FIXC(MP).LT.0) I = 1
      FIXC(MP) = FIXC (MP) + I
      GO TO 99999
C     <CONSTANT> ::= <STRING>
11000 CONTINUE
C     MAY WISH TO TREAT THIS STRING AS A CONSTANT LATER
      J = VAR(SP)
      I = SHR(J,12)
      L = 3
      K = 0
      IF ((I.LE.0).OR.(I.GT.2)) GO TO 11010
C         CONVERT INTERNAL CHARACTER FORM TO ASCII
          J = RIGHT(J,12)
          K = 0
              DO 11005 L = 1,I
              LTEMP=J+L-1
              KP=VARC(LTEMP)
              K = K * 256 + ASCII(KP)
11005         CONTINUE
      L = I
11010 I = LOOKUP(SP)
      IF (I.EQ.0) I = ENTER(SHL(K,8)+SHL(L,4)+LITER)
      FIXV(MP) = I
      GO TO 99999
C     <CONSTANT> :: = <NUMBER>
11100  CONTINUE
      I = LOOKUP(SP)
      IF (I.NE.0) GO TO 11120
C     ENTER NUMBER INTO SYMBOL TABLE
      I = FIXV(MP)
      J = 1
      IF (I.GT.255) J=2
      I = ENTER(SHL(I,8)+SHL(J,4)+LITER+1)
11120 FIXV(MP) = I
      GO TO 99999
C     <TO>  ::=  TO
11200 CONTINUE
      I = FIXV(MP-3)
      IF (I .GT. 0) GO TO 11210
          CALL ERROR(33,1)
          FIXV(MP) = 1
          GO TO 99999
11210 I = SYMBOL(I-1)
      I = SHR(I,16)
      FIXV(MP-3) = I
      CALL EMIT(I,ADR)
      CALL EMIT(STD,OPR)
      J = ENTER(-(64+LABEL))
      J = SHR(SYMBOL(J-1),16)
      CALL EMIT(J,DEF)
      FIXV(MP) = J
      CALL EMIT(I,VLU)
      GO TO 99999
C     <BY>  ::=  BY
11300 CONTINUE
      CALL EMIT(LEQ,OPR)
      I = ENTER(-(64+LABEL))
C     SAVE SYMBOL NUMBER AT <TO> (END LOOP NUMBER)
      I = SHR(SYMBOL(I-1),16)
      J = FIXV(MP-2)
      FIXV(MP-2) = I
      CALL EMIT(I,VLU)
      CALL EMIT(TRC,OPR)
      I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
      FIXV(MP) = SHL(J,14)+I
C     <BY> IS (TO NUMBER/STATEMENT NUMBER)
      CALL EMIT(I,VLU)
      CALL EMIT(TRA,OPR)
C     NOW DEFINE BY LABEL
      I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
C     SAVE BY LABEL IN <TO> AS BRANCH BACK NUMBER
      FIXV(MP-2)=SHL(I,14)+FIXV(MP-2)
      CALL EMIT(I,DEF)
      GO TO 99999
C     <WHILE>  ::=  WHILE
11400 CONTINUE
      I = ENTER(-(64+LABEL))
      I = SHR(SYMBOL(I-1),16)
      CALL EMIT(I,DEF)
      FIXV(MP) = I
      GO TO 99999
88888 CALL EMIT(I,OPR)
99999 RETURN
      END
      INTEGER FUNCTION GNC(Q)
C     GET NEXT CHARACTER FROM THE INPUT STREAM (OR 0 IF
C     NO CHARACTER IS FOUND)
C
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      INTEGER SHL,SHR,RIGHT
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER Q
4000  IF(CURMAC .LE. MAXMAC) GO TO 2000
      IF (IBP .LE. CONTRL(29)) GO TO 200
C     READ ANOTHER RECORD FROM COMMAND STREAM
      IF (CONTRL(31) .EQ. 0) GO TO 1
      IF(CONTRL(20).EQ. 1) CALL PAD(0,1,1)
      CALL WRITEL(0)
1     IFILE = CONTRL(20)
      READ(IFILE,1000) IBUFF
100       DO 110 I=1,80
          J = IBUFF(I)
          J = ICON(J)
          IBUFF(I) = ITRAN(J)
110       CONTINUE
C
      LP = CONTRL(23)
      IF (IBUFF(LP).EQ.38) GO TO 300
115   IBP = LP
      CONTRL(14) = CONTRL(14) + 1
      CALL EMIT(CONTRL(14),LIN)
      IF (CONTRL(27).EQ.0) GO TO 200
      CALL CONOUT(0,5,CONTRL(14),10)
      CALL CONOUT(1,-3,CURBLK-1,10)
      CALL PAD(1,1,3)
      IF (CONTRL(23) .EQ. 1) GO TO 120
      CALL FORM(1,IBUFF,1,CONTRL(23)-1,80)
      CALL PAD(1,1,3)
120   CALL FORM(1,IBUFF,CONTRL(23),CONTRL(29),80)
      IF(CONTRL(29) .EQ. 80) GO TO 130
      CALL PAD(1,1,3)
      CALL FORM(1,IBUFF,CONTRL(29)+1,80,80)
130   CONTINUE
200   GNC = IBUFF(IBP)
      IBP = IBP + 1
      RETURN
300   CONTINUE
      IF(IBUFF(2) .EQ. 1) GO TO 115
      LP = LP + 1
C     SCANNER PARAMETERS FOLLOW
305   J = IBUFF(LP)
      IF (J.EQ.38) GO TO 400
      LP = LP + 1
C
          DO 310 I=LP,80
          II = I
          IF (IBUFF(I) .EQ. 39) GO TO 330
          IF (IBUFF(I).EQ.38) GO TO 315
310       CONTINUE
C
315   K = CONTRL(J)
      LP = II
      IF ((K.GT.1).OR.(K.LT.0)) GO TO 320
      CONTRL (J) = 1-K
      GO TO 325
320   CALL ERROR(34,1)
325   IF (II.EQ.80) GO TO 1
      LP = LP + 1
      GO TO 305
330   K = 0
      II = II+1
C
          DO 340 I=II,80
          LP = II
          L = IBUFF(I)
          IF (L .LE. 1) GO TO 340
          IF (L .GT. 11) GO TO 350
          K = K*10+(L-2)
340       CONTINUE
C
350   CONTRL(J) = K
C     MAY BE MORE $ IN INPUT LINE
360   II = LP + 1
          DO 370 I=II,80
          LP = I
          IF (IBUFF(I).EQ.38) GO TO 380
370       CONTINUE
C     NO MORE $ FOUND
      GO TO 1
380   LP = LP + 1
      GO TO 305
400   CONTINUE
C     DISPLAY $ PARAMETERS
      L = 2
      K = 64
      LP = LP + 1
      J = IBUFF(LP)
      IF (J.EQ.1) GO TO 410
      L = J
      K = J
410   CONTINUE
          DO 420 I=L,K
          J = CONTRL(I)
          IF (J.LT.0) GO TO 420
          CALL PAD(0,38,1)
          CALL PAD(1,I,1)
          CALL PAD(1,39,1)
          CALL CONOUT(2,-10,J,10)
420       CONTINUE
      IF (CONTRL(31).NE.0) CALL PAD(0,1,1)
      CALL WRITEL(0)
      GO TO 360
990   IF (INPTR .LT. 1) GO TO 999
      CONTRL(16) = 0
      INPTR = INPTR - 1
      CONTRL(20) = INSTK(INPTR)
      GO TO 1
999   GNC = 0
      RETURN
1000  FORMAT(80A1)
2000  CONTINUE
      I = MACROS(CURMAC)
      J = SHR(I,12)
      I = RIGHT(I,12)
      IF (J .GE. I) GO TO 2100
      J = J + 1
      GNC = MACROS(J)
      MACROS(CURMAC) = SHL(J,12)+I
      RETURN
2100  CURMAC = CURMAC + 1
      GO TO 4000
      END
      SUBROUTINE WRITEL(NSPAC )
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
        INTEGER CONTRL(64),OFILE
      COMMON/CNTRL/CONTRL
C
      NSPACE=NSPAC
      NP = CONTRL(36) - 1
      IF (OBP.LE.NP) GO TO 998
      NBLANK = 1
C
          DO 5 I=1,OBP
          J = OBUFF(I)
          IF (J .NE. 1) NBLANK = I
5         OBUFF(I) = OTRAN(J)
C
      OBP = IMIN(CONTRL(15),NBLANK)
      OFILE = CONTRL(26) + 10
9     CONTINUE
10      WRITE(OFILE,1000) (OBUFF(I), I=1,OBP)
11    IF(NSPACE.LE.0) GO TO 998
C
      DO 12 I=1,OBP
12    OBUFF(I)=OTRAN(1)
      NSPACE=NSPACE-1
      GO TO 9
998   IF (NP.LE.0) GO TO 997
          DO 999 I=1,NP
999       OBUFF(I) = 1
997   OBP = NP
      RETURN
1000    FORMAT (1H ,121A1)
1001    FORMAT(1H )
        END
      FUNCTION ICON(I)
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
C     ICON IS CALLED WITH AN INTEGER VARIABLE I WHICH CONTAINS A
C     CHARACTER READ WITH AN A1 FORMAT.  ICON MUST REDUCE THIS CHARACTER
C     TO A VALUE SOMEWHERE BETWEEN 1 AND 256.  NORMALLY, THIS WOULD BE
C     ACCOMPLISHED BY SHIFTING THE CHARACTER TO THE RIGHTMOST BIT POSI-
C     TIONS OF THE WORD AND MASKING THE RIGHT 8 BITS.  IT IS DONE RATHER
C     INEFFICIENTLY HERE, HOWEVER, TO GAIN SOME MACHINE INDEPENDENCE.
        DO 100 K=1,52
        J = K
        IF (I .EQ. OTRAN(K)) GO TO 200
100   CONTINUE
        J = 1
200   ICON = J
      RETURN
      END
      SUBROUTINE DECIBP
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      IF (CURMAC .LE. MAXMAC) GO TO 100
      IBP = IBP -1
      RETURN
100   I = MACROS(CURMAC)
      MACROS(CURMAC) = I - 2**12
      RETURN
      END
      SUBROUTINE CONV(PREC)
      INTEGER PREC
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      IF (STYPE .LE. 1) GO TO 200
      VALUE = 0
          DO 100 I=1,ACCLEN
          J = ACCUM(I) - 2
100       VALUE = VALUE * STYPE + J
      IF (PREC .LE. 0) GO TO 999
      I = 2**PREC
      IF (VALUE .LT. I) GO TO 999
200   VALUE = -1
999   RETURN
      END
      FUNCTION IMIN(I,J)
      IF (I .LT. J) GO TO 10
      IMIN = J
      GO TO 20
10    IMIN = I
20    RETURN
      END
      SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH)
C     CC = 0 DUMP BUFFER, GO TO NEXT LINE
C     CC = 1 APPEND TO CURRENT BUFFER
C     CC = 2 DELETE LEADING BLANKS AND APPEND
      INTEGER CHARS(LENGTH)
      INTEGER CC,START,FINISH
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      J = START
      I = CC + 1
      GO TO (100,200,300),I
100   CALL WRITEL(0)
200   IF (J .GT. FINISH) GO TO 999
      OBP = OBP + 1
      OBUFF(OBP) = CHARS(J)
      J = J + 1
      IF (OBP .GE. CONTRL(34)) GO TO 100
      GO TO 200
300   IF (J .GT. FINISH) GO TO 999
      IF (CHARS(J) .NE. 1) GO TO 200
      J = J + 1
      GO TO 300
999   RETURN
      END
      SUBROUTINE CONOUT(CC,K,N,BASE)
      INTEGER CC,K,N,BASE,T(20)
      LOGICAL ZSUP
      NP = N
      ZSUP = K .LT. 0
      KP = IMIN (IABS(K),19)
C
          DO 10 I=1,KP
10        T(I) = 1
C
      IP = KP + 1
C
          DO 20 I=1,KP
          LTEMP=IP-I
          T(LTEMP)=MOD(NP,BASE)+2
          NP = NP/BASE
          IF(ZSUP .AND. (NP .EQ. 0)) GO TO 30
20        CONTINUE
C
30    IF(BASE .EQ. 8) GO TO 40
      IF(BASE .EQ. 2) GO TO 45
      IF(BASE .NE. 16) GO TO 50
      KP = KP+1
      T(KP) = 19
      GO TO 50
40    KP = KP+1
      T(KP) = 28
      GO TO 50
45     KP = KP+1
      T(KP) = 13
50    CALL FORM(CC,T,1,KP,20)
      RETURN
      END
      SUBROUTINE PAD(CC,CHR,I)
      INTEGER CC,CHR,I
      INTEGER T(20)
      J = IMIN(I,20)
C
          DO 10 K=1,J
10        T(K) = CHR
C
      CALL FORM(CC,T,1,J,20)
      RETURN
      END
      SUBROUTINE STACKC(I)
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INPTR = INPTR + 1
      IF (INPTR .GT. 7) GO TO 100
      INSTK(INPTR) = CONTRL(20)
      CONTRL(20) = I
      RETURN
100   CALL ERROR(35,5)
      RETURN
      END
      SUBROUTINE ENTERB
C     ENTRY TO BLOCK GOES THROUGH HERE
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER SHL
      INTEGER LOOKUP,ENTER
      CURBLK = CURBLK + 1
      PROCTP(CURBLK)=PROCTP(CURBLK-1)
      IF (CURBLK .LE. MAXBLK) GO TO 100
          CALL ERROR(36,5)
          CURBLK = 1
100   BLOCK(CURBLK) = SYMTOP
      DOPAR(CURBLK) = 0
C     SAVE THE MACRO PARAMETERS
      MACBLK(CURBLK) = SHL(MACTOP,12) + CURMAC
      BLKSYM = SYMTOP
      RETURN
      END
      SUBROUTINE DUMPIN
C     DUMP THE INITIALIZATION TABLE
      INTEGER WRDATA
C     WRDATA(X) WRITES THE DATA AT LOCATION X IN SYMBOL TABLE
C     AND RETURNS THE NUMBER OF BYTES WRITTEN
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER RIGHT,SHL,SHR
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      IF(CONTRL(30).NE.2) GO TO 1000
      I = SYMABS+1
100   I = I - 1
      IF (I .LE. MAXSYM) GO TO 1000
          J = SYMBOL(I)
          JP = RIGHT(J,15)
          J = SHR(J,15)
          CALL PAD(0,1,1)
          CALL WRITEL(0)
          CALL FORM(0,MSSG,42,48,77)
          CALL PAD(1,30,1)
          CALL CONOUT(1,5,J,10)
          CALL PAD(1,1,1)
          CALL PAD(1,39,1)
200   IF (JP.LE.0) GO TO 100
          JP = JP - 1
          I  = I - 1
          CALL PAD(1,1,1)
          CALL PAD(1,30,1)
C         GET THE SYMBOL NUMBER
          K = SHR(SYMBOL(I),16)
          CALL CONOUT(1,5,K,10)
      GO TO 200
1000  CALL WRITEL(0)
      KT = CONTRL(26)
      CONTRL(26) = CONTRL(32)
      KQ = CONTRL(34)
      CONTRL(34) = CONTRL(33)
C     READY TO WRITE THE INITIALIZATION TABLE
      I = SYMABS+1
3000  CALL PAD(1,41,1)
3100  I = I - 1
      IF (I.LE.MAXSYM) GO TO 4000
          J = SYMBOL(I)
          JP = RIGHT(J,15)
          J = SHR(J,15)
C     WRITE SYMBOL NUMBERS
          DO 3300 K=1,3
          KP = MOD(J,32)+2
          CALL PAD(1,KP,1)
3300      J = J /32
C
C     WRITE OUT DATA CORRESPONDING TO EACH CONSTANT
3400  IF (JP.LE.0) GO TO 3000
      JP = JP - 1
      I = I - 1
      K = RIGHT(SYMBOL(I),16)
      K = WRDATA(K)
      GO TO 3400
C
4000  CALL PAD(1,41,1)
      CALL WRITEL(0)
      CONTRL(26) = KT
      CONTRL(34) = KQ
      RETURN
      END
      SUBROUTINE ERROR(I,LEVEL)
      INTEGER I,LEVEL
C     I IS ERROR NUMBER, LEVEL IS SEVERITY CODE
      INTEGER TERR(22)
      COMMON /TERRM/TERR
C     TERR CONTAINS THE TERMINAL ERROR MESSAGE - COMPILATION TERMINATED
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      CONTRL(1) = CONTRL(1) + 1
      CALL FORM(0,MSSG,21,21,41)
      CALL CONOUT(1,5,CONTRL(14),10)
      CALL FORM(1,MSSG,22,22,41)
      CALL PAD(1,1,2)
      CALL FORM(1,MSSG,16,20,41)
      CALL PAD(1,1,1)
      CALL CONOUT(2,-4,I,10)
      CALL PAD(1,1,2)
      CALL FORM(1,MSSG,23,26,41)
      CALL PAD(1,1,1)
      CALL FORM(1,ACCUM,1,ACCLEN,32)
      CALL WRITEL(0)
C     CHECK FOR TERMINAL ERROR - LEVEL GREATER THAN 4
      IF (LEVEL.LE.4) GO TO 999
C         TERMINATE COMPILATION
          CALL FORM(0,TERR,1,22,22)
          CALL WRITEL(0)
          COMPIL = .FALSE.
999   RETURN
      END
      INTEGER FUNCTION SHR(I,J)
      SHR = I/(2**J)
      RETURN
      END
      INTEGER FUNCTION SHL(I,J)
      SHL = I*(2**J)
      RETURN
      END
      INTEGER FUNCTION RIGHT(I,J)
      RIGHT = MOD(I,2**J)
      RETURN
      END
      SUBROUTINE SDUMP
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C     CHECK FOR STACK DUMP BYPASS
      IF (CONTRL(13).NE.0) GO TO 400
      CALL FORM(0,MSSG,29,41,41)
      IF (SP .LT. 5) GO TO 200
          DO 100 I=5,SP
          J = PSTACK(I)
          CALL PRSYM(1,J)
          CALL PAD(1,1,1)
100       CONTINUE
200   CALL WRITEL(0)
400   CONTINUE
      RETURN
      END
      SUBROUTINE REDPR(PROD,SYM)
      INTEGER SYM,PROD
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
      CALL CONOUT(0,-5,PROD,10)
      CALL PAD(1,1,2)
      CALL PRSYM(1,SYM)
      CALL PAD(1,1,1)
      CALL PAD(1,51,2)
      CALL PAD(1,39,1)
          DO 50 I=MP,SP
          CALL PAD(1,1,1)
50        CALL PRSYM(1,PSTACK(I))
      CALL WRITEL(0)
      RETURN
      END
      SUBROUTINE EMIT(VAL,TYP)
      INTEGER VAL,TYP
C     TYP      MEANING
C      0      OPERATOR
C      1      LOAD ADDRESS
C      2      LOAD VALUE
C      3      DEFINE LOCATION
C      4      LITERAL VALUE
C      5      LINE NUMBER
C      6      UNUSED
C      7        "
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      INTEGER POLISH(30),MAXPOL,POLTOP,POLCNT,POLCHR(18)
      COMMON /POLE/POLISH,MAXPOL,POLTOP,POLCNT,POLCHR
      INTEGER RIGHT,SHR,SHL
      POLTOP = POLTOP+1
      IF (POLTOP .LE. MAXPOL) GO TO 100
          CALL ERROR(37,1)
          POLTOP = 1
100   POLCNT = POLCNT + 1
      IF (CONTRL(18).EQ.0) GO TO 1200
          CALL CONOUT(0,-5,POLCNT,10)
          CALL PAD(1,1,1)
          I = (TYP*3)+1
          CALL FORM(1,POLCHR,I,I+2,18)
          CALL PAD(1,1,1)
          I = TYP+1
          J = 1
          GO TO (1000,1001,1001,1001,1004,1004),I
1000      J = OPCVAL(VAL+1)
              DO 200 I=1,3
              K = SHR(J,(3-I)*6)
              CALL PAD(1,RIGHT(K,6),1)
200           CONTINUE
          GO TO 1100
1001      CONTINUE
          J = 30
1004      CALL PAD(1,J,1)
          CALL CONOUT(1,5,VAL,10)
1100      CONTINUE
C
C     NOW STORE THE POLISH ELEMENT IN THE POLISH ARRAY.
C
      CALL WRITEL(0)
1200  POLISH(POLTOP) = SHL(VAL,3)+TYP
      LCODE = CONTRL(22)/3
      IF (POLTOP .LT. LCODE) GO TO 9999
C     WRITE THE CURRENT BUFFER
      CALL WRITEL(0)
      KP = CONTRL(34)
      CONTRL(34) = CONTRL(22)
      K = CONTRL(26)
      CONTRL(26) = CONTRL(21)
C
      JP = 0
          DO 2000 I=1,LCODE
          J = POLISH(I)
              DO 2000 L = 1,3
              LP = RIGHT(SHR(J,(3-L)*5),5)+2
              CALL PAD(JP,LP,1)
              JP = 1
2000          CONTINUE
C
      CALL WRITEL(0)
      CONTRL(34) = KP
      CONTRL(26) = K
      POLTOP = 0
9999  RETURN
      END
      BLOCK DATA
      INTEGER TITLE(10),VERS
      COMMON /TITL/TITLE,VERS
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      INTEGER ASCII(64)
      COMMON /ASC/ASCII
      INTEGER HENTRY(127),HCODE
      COMMON /HASH/HENTRY,HCODE
      INTEGER SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK(75),VAR(75),
     1    VARC(256),FIXV(75),FIXC(75),PRMASK(5)
      LOGICAL FAILSF,COMPIL
      COMMON /STACKS/SP,MP,MPP1,MSTACK,MVAR,VARTOP,PSTACK,VAR,
     1    VARC,FIXV,FIXC,PRMASK,FAILSF,COMPIL
C      GLOBAL TABLES
      INTEGER V(446),VLOC(107),VINDX(13),C1(364),C1TRI(243),PRTB(129),
     1PRDTB(129),HDTB(129),PRLEN(129),CONTC(129),LEFTC(5),LEFTI(57),
     2CONTT(1),TRIPI(57),PRIND(107),NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     3PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     4PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      COMMON /SYNTAX/V,VLOC,VINDX,C1,C1TRI,PRTB,PRDTB,HDTB,PRLEN,CONTC,
     1LEFTC,LEFTI,CONTT,TRIPI,PRIND,NSY,NT,VLEN,VIL,C1W,C1L,NC1TRI,
     2PRTBL,PRDTBL,HDTBL,PRLENL,CONCL,LEFTCL,LEFTIL,CONTL,TRIPL,PRIL,
     3PACK,TOKEN,IDENTV,NUMBV,STRV,DIVIDE,EOFILE,PROCV,SEMIV,
     *DECL,DOV,ENDV,GROUPV,STMTV,SLISTV
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,INPTR,
     1    INSTK(7),ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,INPTR,
     1    INSTK,ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
C     COMPILATION TERMINATED
      INTEGER TERR(22)
      COMMON /TERRM/TERR
      INTEGER MSSG(77)
      COMMON /MESSAG/MSSG
C
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE
      INTEGER MACROS(500),MAXMAC,CURMAC,MACTOP
      COMMON /MACRO/MACROS,MAXMAC,CURMAC,MACTOP
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER POLISH(30),MAXPOL,POLTOP,POLCNT,POLCHR(18)
      COMMON /POLE/POLISH,MAXPOL,POLTOP,POLCNT,POLCHR
      INTEGER BLOCK(30),DOPAR(30),MACBLK(30),CURBLK,MAXBLK,BLKSYM
      INTEGER PROCTP(30)
      COMMON /BLK/BLOCK,DOPAR,MACBLK,CURBLK,MAXBLK,BLKSYM
     1,PROCTP
C     THE '48' USED IN BLOCK INITIALIZATION AND IN SYMBOL TABLE
C     INITIALIZATION IS DERIVED FROM THE PROGRAM 'SYMCS' WHICH
C     BUILDS THE INITIAL SYMBOL TABLE.  IF THIS NUMBER CHANGES, BE
C     SURE TO ALTER 'BLOCK', 'BLKSYM', 'SYMTOP', AND 'SYMCNT'.
C     TWO ARRAYS, SYM1 AND SYM2, ARE EQUIVALENCED OVER THE
C     SYMBOL TABLE ARRAY IN ORDER TO LIMIT THE NUMBER OF
C     CONTINUATION CARDS IN SYMBOL TABLE INITIALIZATION
C     BELOW.  THE LENGTHS OF SYM1 AND SYM2, THEREFORE, MUST
C     TOTAL THE LENGTH OF THE SYMBOL TABLE.  CURRENTLY, THESE
C     ARRAYS ARE DECLARED AS FOLLOWS
C
C         SYM1(60) + SYM2(3940) = SYMBOL(4000)
C
C     IF YOU INCREASE (DECREASE) THE SIZE OF SYMBOL, YOU MUST
C     INCREASE (DECREASE) THE SIZE OF SYM2 AS WELL.
C
C     NOTE ALSO THAT THE REMAINING ENTRIES OF THE SYMBOL
C     TABLE ARE SET TO ZERO AT THE END OF THE DATA STATEMENT
C     FOR SYM2.  CURRENTLY, THIS IS ACCOMPLISHED WITH THE LAST
C     ENTRY IN THE DATA STATEMENT
C
C                   3880*0
C
C     AGAIN, IF YOU CHANGE THE SIZE OF SYMBOL, YOU MUST
C     ALSO CHANGE THIS LAST ENTRY.  IF FOR EXAMPLE, YOU ALTER
C     THE SIZE OF SYMBOL TO 3000, THE LAST ENTRY 1880*0 BECOMES
C
C                   2880*0
C
      INTEGER SYMBOL(4000),SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      COMMON /SYM/SYMBOL,SYMTOP,MAXSYM,SYMLOC,SYMLEN,SYMCNT,SYMABS,
     1    ACNT
      INTEGER SYM1(60),SYM2(3940)
      EQUIVALENCE (SYMBOL(1),SYM1(1)),(SYMBOL(61),SYM2(1))
      INTEGER OPCVAL(51),OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /OPCOD/ OPCVAL,OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,REM,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
C     SYNTAX ANALYZER TABLES
      INTEGER V0(254),V1(73),V2(68),V3(51)
      EQUIVALENCE (V(1),V0(1)),(V(255),V1(1)),(V(328),V2(1)),
     4(V(396),V3(1))
      INTEGER C10(110),C11(118),C12(136)
      EQUIVALENCE (C1(1),C10(1)),(C1(111),C11(1)),(C1(229),C12(1))
      INTEGER C1TRI0(93),C1TRI1(86),C1TRI2(64)
      EQUIVALENCE (C1TRI(1),C1TRI0(1)),(C1TRI(94),C1TRI1(1)),
     3(C1TRI(180),C1TRI2(1))
C     ... PLM1 VERS ...
      DATA TITLE/27,23,24, 3, 1,33,16,29,30, 1/
      DATA VERS/20/
      DATA INTPRO /8*0/
C     TRANSLATION TABLE FROM INTERNAL TO ASCII
      DATA ASCII /
     1    32,  48,49,50,51,52, 53,54,55,56,57,
     2    65,66,67,68,69,70,71,72,73,
     3    74,75,76,77,78,79,80,81,82,
     4    83,84,85,86,87,88,89,90,
     5    36,61,46, 47,40,41, 43,45,39, 42,44,60, 62,58,59,
     6    12*0/
      DATA CONTRL /64*0/
      DATA IBP/81/, OBP/0/,  INPTR /0/
      DATA OTRAN /1H ,1H0,1H1,1H2,1H3,1H4,
     1    1H5,1H6,1H7,1H8,1H9,1HA,1HB,1HC,1HD,1HE,1HF,
     2    1HG,1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,
     3    1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ,
     4    1H$,1H=,1H.,1H/,1H(,1H),1H+,1H-,1H',1H*,1H,,
     5    1H<,1H>,1H:,1H;,12*0/
C     COMPILATION TERMINATED
      DATA TERR /14,26,24,27,20,23,12,31,20,26,25, 1,
     1    31,16,29,24,20,25,12,31,16,15/
C     PASS-NO PROGRAM
C     ERROR
C     ()NEARAT
C     PARSE STACK
C     SYMBOL  ADDR WDS CHRS   LENGTH PR TY
      DATA MSSG /27,12,30,30,45,
     1    25,26,27,29,26,18,29,12,24,1,
     2    16,29,29,26,29,
     3    42,43,25,16,12,29,12,31,
     4    27,12,29,30,16,1,30,31,12,14,22,51,1,
     5    30,36,24,13,26,23, 1,1,  12,15,15,29, 1, 34,15,30, 1,
     6    14,19,29,30, 1,1,1, 23,16,25,18,31,19,  1,27,29,  1,31,36/
      DATA STYPE /0/, EOFLAG /1/, IDENT /2/, NUMB /3/,
     1    SPECL /4/, STR /5/, CONT /1/
C
      DATA MP /0/, MPP1 /1/, MSTACK /75/, VARTOP /1/,
     1    MVAR /256/, FAILSF /.FALSE./, COMPIL /.TRUE./
      DATA MACROS /500*0/, CURMAC /501/, MAXMAC /500/,
     1   MACTOP /1/
      DATA VARB /1/, INTR /2/, PROC /3/, LABEL /4/, LITER /5/
      DATA MAXPOL /30/, POLTOP /0/, POLCNT /0/
C     OPRADRVALDEFLITLIN
      DATA POLCHR /26,27,29, 12,15,29, 33,12,23, 15,16,17,
     1    23,20,31, 23,20,25/
      DATA BLOCK /1,120,28*0/, CURBLK /2/, MAXBLK /30/,
     1    BLKSYM /120/, DOPAR /30*0/, MACBLK /30*0/
     1,PROCTP/30*0/
      DATA SYM1 /
     1   5439488,     65536,      4101,        17, 221103907,   6815744,
     2    131074,      4100,        17, 608028224,   5046272,    196615,
     3      4100,        17, 491591168,   7471104,    262156,      8198,
     4        17, 439207134, 587202560,   7995392,    327697,      8198,
     5        17, 389903964, 587202560,    851968,    393239,      8200,
     6        33, 494449493, 444186624,   3866624,    458781,      4099,
     7       530, 476405760,   8126464,    524323,      4099,       530,
     8 476430336,   5373952,    589864,      4099,       530, 491347968,
     9   1310720,    655405,      4099,       530, 491372544,    131072,
     A    720946,      4099,       530, 490037248,   4390912,    786487/
      DATA SYM2 /
     B      4099,       530, 490061824,   5373996,    852028,      4100,
     C       258, 508392384,   7405568,    917569,      4100,       274,
     D 307041408,   7143424,    983110,      4099,       274, 375787520,
     E   5308416,   1048651,      4101,       274, 325167070,   3276800,
     F   1114192,      8198,       274, 427681439, 503316480,   1114112,
     G   1179733,      8198,       274, 373130334, 301989888,   1703936,
     H   1245275,      4100,       274, 372103040,   1900544,   1310817,
     I      4100,       770, 392561600,    589824,   1376358,      8198,
     J       290, 241562390, 251658240,    458752,   1441899,      4099,
     K       274, 238866432,   1507441,         0,         1,       117,
     L    3880*0/
      DATA SYMTOP /120/, MAXSYM /4000/, SYMABS /4000/,
     1    SYMCNT /23/, ACNT /0/
      DATA HENTRY /
     *0,54,0,0,0,0,112,0,106,0,0,0,28,0,0,0,90,0,0,49,0,0,0,0,0,96,0,
     10,101,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,84,0,0,0,0,0,0,0,
     20,34,0,0,0,0,0,0,0,59,0,0,0,0,0,0,0,0,0,11,0,0,0,79,64,1,0,0,0,
     30,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,6,0,0,0,0,74,0,0,0,69,16,0,0,
     40,0,0,0,0,22,0,39,0,0,0/
      DATA OPR /0/, ADR /1/, VLU /2/, DEF /3/, LIT /4/, LIN /5/,
     *NOP/ 0/,ADD/ 1/,ADC/ 2/,SUB/ 3/,SBC/ 4/,MUL/ 5/,DIV/ 6/,REM/ 7/,
     *NEG/ 8/,AND/ 9/,IOR/10/,XOR/11/,NOT/12/,EQL/13/,LSS/14/,GTR/15/,
     *NEQ/16/,LEQ/17/,GEQ/18/,INX/19/,TRA/20/,TRC/21/,PRO/22/,RET/23/,
     *STO/24/,STD/25/,XCH/26/,DEL/27/,DAT/28/,LOD/29/,BIF/30/,INC/31/,
     *CSE/32/,END/33/,ENB/34/,ENP/35/,HAL/36/,RTL/37/,RTR/38/,SFL/39/,
     *SFR/40/,HIV/41/,LOV/42/,CVA/43/,ORG/44/,DRT/45/,ENA/46/,DIS/47/,
     *AX1/48/,AX2/49/,AX3/50/
      DATA OPCVAL /
     * 104091,  50127,  50126, 124941, 123726, 100375,  62753, 119832,
     * 103442,  50767,  83613, 145053, 104095,  67351,  96158,  75741,
     * 103452,  95260,  74780,  83555, 128844, 128846, 112474, 119839,
     * 124890, 124879, 144275,  62487,  62239,  95887,  54545,  83534,
     *  59280,  67151,  67149,  67163,  78615, 120791, 120797, 123991,
     * 123997,  79137,  95905,  59468, 108370,  63327,  67148,  62750,
     *  51395,  51396,  51397/
      DATA V0/18,49,16,29,29,26,29,51,1,31,26,22,16,25,1,39,1,2,50,1,52,
     11,43,1,42,1,48,1,51,1,39,1,49,1,50,1,44,1,45,1,47,1,41,1,40,2,20,
     217,2,15,26,2,18,26,2,31,26,2,26,29,2,13,36,3,16,26,17,3,16,25,15,
     33,35,26,29,3,12,25,15,3,25,26,31,3,24,26,15,4,19,12,23,31,4,31,19,
     416,25,4,16,23,30,16,4,14,12,30,16,4,14,12,23,23,4,18,26,31,26,4,
     515,12,31,12,4,13,36,31,16,4,27,23,32,30,5,23,12,13,16,23,5,13,12,
     630,16,15,5,24,20,25,32,30,5,34,19,20,23,16,6,16,25,12,13,23,16,6,
     729,16,31,32,29,25,7,15,20,30,12,13,23,16,7,15,16,14,23,12,29,16,7,
     812,15,15,29,16,30,30,7,20,25,20,31,20,12,23,8,49,25,32,24,13,16,
     929,50,8,49,30,31,29,20,25,18,50,9,20,25,31,16,29,29,32,27,31,9,27,
     A29,26,14,16,15,32,29,16,9,23,20,31,16,29,12,23,23,36,12,49,20,15/
      DATA V1/16,25,31,20,17,20,16,29,50,813276224,808598592,813315727,
     1822083584,813233943,822083584,809879135,449052672,814032086,
     2264503296,809865246,432275456,809337747,407310336,812238417,
     3472742976,812709526,188021824,812238039,192035904,813741843,
     4187786225,808818205,506300337,812709259,508401201,813032158,
     5257750558,822083584,810352653,372111183,822083584,813287375,
     66862622,822083584,809023371,5846878,822083584,809023371,4780750,
     7822083584,811136030,6862622,822083584,808310611,291599320,
     8516161536,809379484,259380441,415498240,809879135,436282315,
     9247726080,808556504,234955723,247726080,810352669,506323927,
     A258075712,814032086,251712907,527760448,810386654,321740822/
      DATA V2/326495296,810386654,321740818,254602304,808761167,7665039,
     1226072369,813741843,187786176,405631985,808818205,506300288,
     2305968049,813032158,257750558,5846878,822083584,808760726,7725790,
     3257750558,822083584,812238413,255457039,4780750,822083584,
     4812238413,255457039,6337999,822083584,812168971,389931996,5846878,
     5822083584,812168971,389931996,4780750,822083584,808499023,
     6235012828,321701263,822083584,811177043,221077520,188081756,
     7822083584,813036317,225523358,4780750,822083584,808499027,
     8218224523,507343832,516161536,809865246,419551115,507343832,
     9516161536,813032410,3732499,407758041,415498240,810345432,
     A508363983,469853405,516161536,811177043,221077530,474837724/
      DATA V3/600047616,812709791,476055390,192476623,410718208,
     1811119375,369157072,325138323,425922560,813315727,3732310,
     2191936403,425922560,810410972,192493144,3511838,476408896,
     3811177043,221077533,255170062,192035904,811177043,221077519,
     4577356765,491623985,809038678,191936403,425722838,257750558,
     5822083584,812238413,255457039,3732499,407758041,415498240,
     6809038678,191936403,425723742,192476623,410718208,808305886,
     7308082579,218167450,473814867,425922560,810345432,508363983,
     8469882511,223151309,192493144,822083584/
      DATA VLOC /1,20,22,24,26,28,30,32,34,36,38,40,42,44,46,49,52,55,
     158,61,64,68,72,76,80,84,88,93,98,103,108,113,118,123,128,133,139,
     2145,151,157,164,171,179,187,195,203,212,221,231,241,251,131336,
     3131337,196874,196876,229646,229648,229650,262420,295190,295192,
     4295194,327964,327966,327968,360738,360741,360744,360747,360750,
     5360753,393524,393527,393530,393533,459072,459075,459078,459081,
     6491852,491855,491858,524629,524633,524637,524641,524645,524649,
     7524653,524657,524661,557433,557437,557441,557445,557449,590221,
     8590225,590229,623001,623005,655777,688549,721322,754095,754100,
     9852409/
      DATA VINDX /1,14,20,26,35,39,41,45,47,50,50,50,51/
      DATA C10/0,0,0,32768,688288,35815424,713162890,715827202,
     1673744896,991953792,196620,201326640,0,15740976,2129920,8388608,
     22563,134283266,671219840,671091360,545786880,204472320,805306368,
     3245952,541360640,0,40,33686536,134217728,0,10493968,16384,0,1281,
     44194308,0,0,335807488,1048576,0,81984,268435712,0,20,16842752,0,0,
     55246992,1064960,4194304,1281,67108864,1,4096,262144,4096,0,0,
     6536904192,131072,40,33619972,67108880,0,5247008,2129920,8388608,
     72562,67108865,335544384,335545680,268730368,0,0,64,268452096,
     865536,20,16842756,67108880,0,5246992,1064960,0,1281,4194308,0,0,
     9335822848,0,0,8,168,8232,174112,35651584,44040194,10485802,
     A545267728,1064960,4194304,1281,0,0,0,262144,0,0,131200,268435456/
      DATA C11/0,0,2129920,0,0,33554448,16384,0,1281,136314880,0,2,0,0,
     10,128,268435712,0,20,16908296,134217760,0,10494208,0,0,0,
     2138412292,1024,0,335822848,0,0,0,268435456,0,0,18907136,0,0,
     333554448,0,0,0,254192288,44081696,2129920,41514,713042442,
     4142606856,0,0,0,16,2228224,0,139264,134742016,0,0,256,201239200,
     544081696,27885576,1049600,68157440,268435456,81984,268452096,
     665536,20,19955712,0,0,33555080,715456680,168951816,134217728,
     767108864,0,0,1024,68157440,268435456,81984,0,0,16,18874368,0,0,0,
     82,0,0,4194564,1024,0,335847978,713042442,142606856,10,233482242,
     9673744896,136314880,2935466,537559688,536904192,16,1064960,0,1281,
     A134217730,671744128,671091360,537411584,344064,16859136,356581444/
      DATA C12/84,4116,87056,18907136,0,0,0,0,0,1280,0,0,0,311296,0,0,9,
     167108865,67109888,0,1048576,22021121,5242901,272633856,0,0,1024,
     2134217730,671744128,671091360,537411584,0,0,8,134217728,0,128,0,0,
     30,5243136,0,0,0,26214400,0,8912904,0,0,0,81924,84,37752852,87056,
     417825792,0,0,256,5376,263424,5571585,71303168,0,4456452,16793600,
     50,1088,1048576,0,0,0,16777216,0,0,4744,168,151126016,0,4194564,
     61024,0,335839232,688288,36864000,713162884,0,0,0,1048576,0,0,0,0,
     70,1,169869312,44081184,0,16384,0,0,4,84,4198420,87056,287342592,0,
     80,16777728,0,0,0,169869312,44081184,0,41472,9732,8388608,8,
     9134217728,0,0,1048576,0,0,260,0,0,0,169956608,44081184,1064960,
     A1024,0,1088,1048576/
      DATA C1TRI0/197379,197386,197389,197400,197421,197422,197426,
     1209411,329219,329226,329229,329240,329261,329262,329266,393987,
     2393994,393997,394008,394029,394030,394034,406019,590595,590602,
     3590605,590616,590637,590638,590642,602627,656131,656138,656141,
     4656152,656173,656174,656178,668163,721667,721674,721677,721688,
     5721709,721710,721714,733699,787203,787210,787213,787224,787245,
     6787246,787250,799235,864771,918275,918282,918285,918296,918317,
     7918318,918322,930307,995843,998918,1180419,1180426,1180429,
     81180440,1180461,1180462,1180466,1192451,1323523,1323525,1326596,
     91326598,1328897,1442563,1442570,1442573,1442584,1442605,1442606,
     A1442610,1454595,1508099,1508106,1508109,1508120,1508141,1508142/
      DATA C1TRI1/1508146,1520131,1573635,1573642,1573645,1573656,
     11573677,1573678,1573682,1585667,1639171,1639178,1639181,1639192,
     21639213,1639214,1639218,1651203,1901315,1901322,1901325,1901336,
     31901357,1901358,1901362,1913347,1978883,2228995,2229002,2229005,
     42229016,2229037,2229038,2229042,2241027,2425603,2425610,2425613,
     52425624,2425645,2425646,2425650,2437635,2622211,2622218,2622221,
     62622232,2622253,2622254,2622258,2634243,2949665,2949667,2949675,
     73091713,3343107,3343114,3343117,3343128,3343149,3343150,3343154,
     83355139,3408643,3408650,3408653,3408664,3408685,3408686,3408690,
     93420675,3670787,3670794,3670797,3670808,3670829,3670830,3670834,
     A3682819,3932931,3932938,3932941,3932952,3932973,3932974,3932978/
      DATA C1TRI2/3944963,4195075,4195082,4195085,4195096,4195117,
     14195118,4195122,4207107,4338179,4338181,4341252,4341254,4343553,
     24348700,4403715,4403717,4406788,4406790,4409089,4538114,4538116,
     34600323,4603396,4603398,4796931,4796933,4800004,4800006,4802305,
     44861186,5127938,5127940,5324546,5324548,5386755,5386757,5389828,
     55389830,5392129,5517827,5517829,5520900,5520902,5523201,5584129,
     65649665,5714434,5714436,5899011,5899018,5899021,5899032,5899053,
     75899054,5899058,5911043,6369795,6369797,6372868,6372870,6375169,
     86816771,6816818/
      DATA PRTB /0,5592629,5582637,21813,21846,3933,3916,3919,85,15,71,
     155,103,96,83,92,104,26,39,41,0,17727,20031,22322,24144,20799,840,
     223112,32,106,44,13,50,0,0,22322,17727,24144,20031,20799,23112,62,
     350,45,7,8,0,0,0,7,0,16,0,0,0,3656,91,0,0,0,50,0,0,0,57,0,12849,0,
     497,21,57,88,0,0,4861186,106,26889,26890,26914,26917,10,0,21586,97,
     573,13835,13836,13849,0,30,13,0,13,0,16963,82,73,66,0,50,70,
     63360820,15932,51,56,29,40,97,0,98,0,0,25874,25878,0,97,0,24,0,0,
     74078664,22807,0,4064518,0,26628,42,26944,0/
      DATA PRDTB /0,38,39,36,37,25,26,27,35,24,6,7,8,9,10,11,12,13,14,
     115,16,61,78,41,72,114,117,121,62,70,79,118,122,42,73,43,63,74,80,
     2119,123,84,47,48,100,101,96,83,97,99,98,54,126,127,44,21,22,55,67,
     369,77,128,49,68,53,125,59,124,40,45,52,76,75,120,65,64,103,104,
     4105,106,107,102,34,46,23,109,110,111,108,51,116,115,113,112,19,3,
     528,18,2,60,82,31,81,30,32,33,50,20,5,66,71,1,88,89,87,17,4,93,92,
     658,29,91,90,86,85,57,56,95,94/
      DATA HDTB /0,84,84,84,84,73,73,73,84,73,91,91,91,91,91,91,91,91,
     191,91,91,68,77,86,106,61,61,62,69,74,78,81,90,87,94,87,69,94,78,
     281,90,70,97,97,64,64,64,60,64,64,64,57,51,52,58,66,67,57,53,53,88,
     356,96,53,92,63,102,63,85,58,92,80,80,62,98,98,105,105,105,105,105,
     4105,103,58,55,54,54,54,54,83,61,61,61,61,75,82,73,75,82,102,71,99,
     571,99,76,79,96,75,65,98,106,59,101,101,101,91,65,100,100,102,93,
     689,89,72,72,104,104,95,95/
      DATA PRLEN /0,4,4,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,1,3,3,3,3,3,3,
     13,2,2,2,2,2,1,1,3,3,3,3,3,3,2,2,2,2,2,1,1,1,2,1,2,1,1,1,3,2,1,1,1,
     22,1,1,1,2,1,3,1,2,2,2,2,1,1,4,2,3,3,3,3,2,1,3,2,2,3,3,3,1,2,2,1,2,
     31,3,2,2,2,1,2,2,4,3,2,2,2,2,2,1,2,1,1,3,3,1,2,1,2,1,1,4,3,1,4,1,3,
     42,3,1/
      DATA CONTC /0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     10,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,
     20,0,0,0,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     30,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     40,0,0/
      DATA LEFTC /105,4,42,94,85/
      DATA LEFTI /0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,
     11,1,1,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5/
      DATA CONTT /0/
      DATA TRIPI /0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1/
      DATA PRIND /1,21,28,35,42,44,48,49,51,51,51,51,51,51,51,51,51,53,
     153,54,54,55,55,55,55,55,55,56,57,57,57,58,58,59,59,60,61,61,62,62,
     263,63,63,64,64,66,68,68,69,69,74,74,74,76,82,82,82,82,85,85,85,89,
     392,94,94,99,99,99,100,100,100,101,107,107,107,109,109,110,110,110,
     4111,111,112,112,112,112,112,112,112,115,115,117,117,117,117,119,
     5119,119,120,121,123,125,127,127,127,129,129/
      DATA NSY /106/, NT /50/, VLEN /445/, VIL /12/, C1W /102/,
     2C1L /363/, NC1TRI /242/, PRTBL /128/, PRDTBL /128/, HDTBL /128/,
     3PRLENL /128/, CONCL /128/, LEFTCL /4/, LEFTIL /56/, CONTL /0/,
     4TRIPL /56/, PRIL /106/, PACK /5/, TOKEN /0/, IDENTV /50/,
     5NUMBV /45/, STRV /46/, DIVIDE /0/, EOFILE /20/, PROCV /48/,
     6SEMIV /1/, DECL /42/, DOV /15/, ENDV /21/, GROUPV /55/,
     7STMTV /65/, SLISTV /82/
      END