seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-22 07:54:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM81.FOR
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

3656 lines
124 KiB
Fortran
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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

Reference in New Issue View Git Blame Copy Permalink