![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to EXPR.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to EXPR.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
researchv10 Norman
INTEGER FUNCTION EXPR(LOGEX)
C
C LOGEX IS A DUMMY ARG , NEVER USED
C FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND
C PRE IS PRECEDENCE TABLE, PRE(I,J) GIVES ACTION TAKEN WHEN OP I
C IS ON THE STACK, OP J IN THE INPUT
C CUROP IS CURRENT TOKEN TYPE
C PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP)
C STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC)
C OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC)
C PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS
C
C*****EXPRS
C PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS
C FROM STACK(1))
C PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS
C FROM STACK(LSTACK))
C AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS
C AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J)
C RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS
C RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0
C EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION
C EX(I,J) = TYPE OF (TYPE I <**> TYPE J)
C
INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3),
* STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT,
* GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3,
* OUTUT4, PREF, REF
LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR
LOGICAL INTEXT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /EXPRS/ PT, PB, AO, RO, EX
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA K /0/
DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/,
* PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/,
* PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/,
* PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/,
* PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/,
* PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/,
* PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/,
* PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/,
* PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/,
* PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/,
* PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/,
* PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/,
* PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/,
* PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/
DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/,
* PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/,
* PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/,
* PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/,
* PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/,
* PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/,
* PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/,
* PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/,
* PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/,
* PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/,
* PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/,
* PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/,
* PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/,
* PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/,
* PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/,
* PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/,
* PRE(11,4) /-1/, PRE(11,11) /6/
DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2)
* /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4),
* PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12),
* PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12),
* PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/
DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4),
* IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6)
* /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/,
* JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8)
* /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/
DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1),
* ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/,
* ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/,
* ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3),
* ADJ(4,4) /3*0/, ADJ(4,2) /-1/
C
C CODES IN OPERAND STACK
C 0....DOUBLE PRECISION 1....REAL 2....INTEGER
C 3....COMPLEX 4....LOGICAL 5....HOLLERITH
C 6....PROCEDURE NAME
C CODES FOR OPERATORS
C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN(
C 17 /,* 18 , 19 .AND. 20 .OR. 21 .EQ. 22 UNARY -,+
C
PB = LSTACK
PT = 1
CALLST = .FALSE.
PREVOP = -1
CUROP = 0
PARENS = 0
FLUSH = .FALSE.
EXPR = -1
10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110
C
C FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN
C TYPE OF EXPRESSION
C
20 IF (PARENS.EQ.0) GO TO 40
30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37)
IF (FLUSH) GO TO 530
GO TO 80
40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60
50 CALL POP
IF (ERR) GO TO 530
IF (PB.LT.LSTACK) GO TO 50
60 IF (PT.NE.3) GO TO 90
IF (STACK(1).EQ.0) GO TO 70
I = IGATT1(STACK(1),8)
IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10)
70 EXPR = STACK(2)
80 PSTMT = K2
ERR = .FALSE.
RETURN
90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29)
IF (FLUSH) GO TO 530
GO TO 80
100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31)
GO TO 530
C
C CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN,
C
110 CUROP = GETTOK(PSTMT,K2)
IF (ERR) GO TO 80
C
C SEE END OF EXPRESSION: ")" <ID> OR <LABEL>; GETTOK RETURNS
C SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE
C
IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR.
* PREVOP.NE.12) GO TO 120
K2 = PSTMT
GO TO 20
C
C CHECK FOR ADJACENT OPERATORS OR OPERANDS.
C
120 IF (PREVOP.LE.6) GO TO 130
I = IBR(PREVOP-10)
GO TO 140
130 I = IBR(13)
IF(PREVOP.EQ.(-1)) I = IBR(14)
140 IF (CUROP.LE.6) GO TO 150
I2 = JBR(CUROP-10)
GO TO 160
150 I2 = JBR(13)
160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22
IF (ADJ(I,I2)) 170, 190, 180
170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44)
GO TO 530
180 CALL ERROR1(
* 54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54)
190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290
IF (CUROP.LT.6) GO TO 280
C
C PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY
C LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY
C TYPE IDENTIFIERS IF NECESSARY.
C
IF (CUROP.EQ.6) GO TO 200
K = LOOKUP(K2-1,.FALSE.)
GO TO 210
200 K = LOOKUP(K2,.FALSE.)
210 IF (SYSERR) GO TO 530
I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
C
C IMPLICITLY TYPE IDENTIFIERS AND FCNS
C
IF (I1.GT.0) GO TO 220
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
C
C SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF.
C
220 I1 = MOD(I1,8)
IF (CUROP.NE.16) GO TO 250
IF (I2.EQ.0) GO TO 240
C
C ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND PEEL OFF
C SUBSCRIPTS, CHECKING THEIR NUMBER
C
IF (ITYP.NE.31) GO TO 230
CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39)
230 CUROP = I1
I1 = CUROP + 16
PSTMT = K2
CALL SUBS(K2, I2)
IF (ERR .OR. SYSERR) GO TO 80
GO TO 270
C
C PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE
C IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED
C AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT.
C
240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13
* .OR. I3.EQ.14) GO TO 290
C
C ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH
C STORES CALL TEMPLATE
C
CALL ERROR1(18H ILLEGAL USE OF ID, 18)
GO TO 530
C
C VARIABLE, ARRAY, PROCEDURE NAME
C
250 IF (I2.EQ.0) GO TO 260
C
C ARRAY
C
CUROP = I1
I1 = CUROP + 8
IF (I3.EQ.0) CALL SATT1(K, 8, 10)
GO TO 270
C
C VARIABLE OR PROCEDURE
C LEAVE IDS USAGE UNSET
C THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING
C DEFINED AS FCN OR SUBROUTINE REFS BY FOLLOWING PGMS
C
260 IF (I3.EQ.0) GO TO 270
IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6
IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270
IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270
CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36)
GO TO 530
C
C ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK
C UPDATE PREVOP,PSTMT. ALSO ENTER SYMBOL TABLE INDEX FOR THESE
C PREVOP = 0,1,...6 FOR OPERANDS
C 11,12,...22 FOR OPERATORS
C
270 IF (PT+2.GE.PB) GO TO 100
STACK(PT) = K
STACK(PT+1) = I1
PT = PT + 2
PREVOP = CUROP
PSTMT = K2
GO TO 10
C
C ARE PROCESSING A CONSTANT
C
280 I1 = CUROP
K = 0
GO TO 270
C
C ARE PROCESSING AN OPERATER
C PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK
C AND OPERATOR J IN INPUT
C
290 KNAME = K
IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1
IF (CUROP.EQ.12) PARENS = PARENS - 1
IF (PARENS.GE.0) GO TO 300
FLUSH = .TRUE.
GO TO 30
C
C CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS
C
300 IF (PB.EQ.LSTACK) GO TO 460
I = STACK(PB+1) - 10
I2 = CUROP - 10
K = PRE(I,I2)
310 IF (-1.NE.K) GO TO 320
FLUSH = .TRUE.
GO TO 90
320 GO TO (330, 470, 520, 480, 480, 490, 510), K
C
C CREATE TEMPLATE FROM FCN CALL
C
330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE.
L1 = STACK(PB+2)
L2 = PT - 1
C
C CHECK FOR NO ARGS
C
IF (L2.GT.L1) GO TO 340
CALL ERROR1(18H MISSING ARGUMENTS, 18)
GO TO 450
C
C CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL
C VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG
C
340 DO 380 I=L1,L2,2
IF (STACK(I)) 350, 380, 350
350 IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32
I1 = IGATT1(STACK(I),4)
IF (I1) 380, 380, 360
360 I1 = IGATT1(STACK(I),6)
IF (I1) 380, 380, 370
370 STACK(I+1) = STACK(I+1) + 64
380 CONTINUE
C
C CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER
C OR VICE VERSA
C
I = STACK(PB+3)
L = IGATT1(I,8)
IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410
IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390
C
C FOUND AN INTRINSIC FCN
C CHECK NOT IN A CALL STMT USED AS A SUBROUTINE
C
IF (CALLST) GO TO 420
GO TO 450
C
C DEFINE FCN( USAGE IF UNSET
C SET USAGE OF ID USED AS A PROC
C
390 IF (CALLST) GO TO 400
CALL SATT1(I, 8, 5)
GO TO 430
400 CALL SATT1(I, 8, 6)
GO TO 430
C
C CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT
C
410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR.
* L.EQ.2)) GO TO 430
420 CALL ERROR1(18H ILLEGAL REFERENCE, 18)
GO TO 450
430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450
C
C LOAD INTO STACK COUNT OF WORDS IN DESCRIPTOR, INDEX OF FCN
C IN SYMBOL TABLE, STMT NO OF REFERENCE
C
IF (PT+3.GE.PB) GO TO 100
STACK(PT) = PT - STACK(PB+2)
STACK(PT+1) = STACK(PB+3)
STACK(PT+2) = NOST
STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8)
L3 = PT + 3
ICOD = 2
L = L2 - L1 + 5
IF (L.LE.LREF) GO TO 440
CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44)
GO TO 450
440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2)
C
C FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK
C
450 PT = STACK(PB+2)
I1 = IGATT1(STACK(PB+3),1)
STACK(PT) = 0
STACK(PT+1) = MOD(I1,8)
PT = PT + 2
PB = PB + 3
GO TO 520
C
C HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO
C OPERATOR STACK. FCN( HAS SPECIAL PUSH.
C
460 IF (CUROP.NE.16) GO TO 480
C
C FOUND "FCN(" CONSTRUCT ; STORE 3 THINGS IN STACK
C PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK ;
C OPERAND CODE FOR FCN(
C
470 IF (PB-3.LE.PT) GO TO 100
STACK(PB) = KNAME
STACK(PB-1) = PT
STACK(PB-2) = CUROP
PB = PB - 3
GO TO 520
C
C SIMPLE PUSH ONTO OPERATOR STACK
C
480 IF (PB-1.EQ.PT) GO TO 100
STACK(PB) = CUROP
PB = PB - 1
GO TO 520
C
C POP OPERATOR FROM STACK. IF STACK EMPTY, PUSH CUROP ONTO
C STACK. ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP).
C
490 CALL POP
IF (ERR) GO TO 530
IF (PB.LT.LSTACK) GO TO 500
GO TO 480
500 I = STACK(PB+1) - 10
K = PRE(I,CUROP-10)
GO TO 310
C
C POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION
C
510 CALL POP
IF (ERR) GO TO 530
C
C UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR
C
520 PREVOP = CUROP
PSTMT = K2
GO TO 10
C
C JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE
C EXPRESSION
C
530 K2 = PSTMT
ERR = .FALSE.
540 IF (K2.GE.NSTMT) GO TO 80
IF (STMT(K2).EQ.65) PARENS = PARENS + 1
IF (STMT(K2).NE.62) GO TO 550
PARENS = PARENS - 1
IF (PARENS.EQ.0) GO TO 560
550 K2 = K2 + 1
GO TO 540
560 I = GETTOK(K2,I2)
K2 = I2
IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80
GO TO 540
END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.