home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
MISC
/
PLM80.ARK
/
PLM81.FOR
< prev
next >
Wrap
Text File
|
1989-04-05
|
130KB
|
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