![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ARDECL.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 ARDECL.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: LOGICAL FUNCTION ARDECL(K2, KK) ! 2: C ! 3: C K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT ! 4: C KK IS SYMBOL TABLE INDEX FOR THIS ARRAY ! 5: C PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS. ! 6: C CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE. ! 7: C ENTERS INTO SYMBOL TABLE AND TYPES ID; SETS USAGE ON ARRAY ! 8: C DECLARATOR ! 9: C CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS ! 10: C VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS. ! 11: C ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES ! 12: C IT OFF ARRAY SYMBOL TABLE ENTRY. -1 LENGTH INDICATES VARIABLE ! 13: C DIMENSION ! 14: C CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT. ! 15: C ! 16: C ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS ! 17: C FALSE FOR ARRAYS AND VARIABLES ! 18: C CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV. ! 19: C STMT ; IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS ! 20: C NEGATIVE. ! 21: C ! 22: LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH ! 23: INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA ! 24: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 25: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 26: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 27: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 28: COMMON /DETECT/ ERR, SYSERR, ABORT ! 29: ERR = .FALSE. ! 30: FLUSH = .FALSE. ! 31: ARRY = .FALSE. ! 32: CORNER = .TRUE. ! 33: ARDECL = .FALSE. ! 34: C ! 35: C CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR; ! 36: C CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO ! 37: C ARRY=.TRUE. ! 38: C ! 39: ICNT = 0 ! 40: CALL NEXTOK(PSTMT, K2, I1) ! 41: IF (I1.EQ.0) GO TO 10 ! 42: CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 43: ERR = .TRUE. ! 44: GO TO 280 ! 45: 10 IF (STMT(K2).EQ.65) ARRY = .TRUE. ! 46: KK = LOOKUP(K2,.FALSE.) ! 47: IF (SYSERR) GO TO 70 ! 48: ARDECL = .TRUE. ! 49: L = IGATT1(KK,8) ! 50: IF (L.EQ.0 .OR. L.EQ.10) GO TO 30 ! 51: IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30 ! 52: 20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45) ! 53: ERR = .TRUE. ! 54: GO TO 280 ! 55: C ! 56: C SET TYPE (EXPLICITLY FOR TYPE STMTS) ! 57: C ! 58: 30 I1 = IGATT1(KK,1) ! 59: IF (ITYP.GE.6) GO TO 50 ! 60: C ! 61: C TYPE EXPLICITLY ! 62: C ! 63: IF (I1.GE.8) GO TO 40 ! 64: CALL SATT1(KK, 1, ITYP+7) ! 65: GO TO 60 ! 66: 40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34) ! 67: GO TO 60 ! 68: C ! 69: C TYPE IMPLICITLY ! 70: C ! 71: 50 IF (I1.GT.0) GO TO 60 ! 72: I1 = 1 ! 73: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 74: CALL SATT1(KK, 1, I1) ! 75: C ! 76: C IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE ! 77: C ! 78: C CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT ! 79: C ! 80: 60 IF (ARRY) GO TO 80 ! 81: IF (IGATT1(KK,7).EQ.0) GO TO 65 ! 82: IF (ITYP.EQ.12) ! 83: 1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE ! 84: 2 , 46) ! 85: IF (ITYP.EQ.13) ! 86: 1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39) ! 87: 65 CONTINUE ! 88: I1 = IGATT1(KK,4) ! 89: IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR. ! 90: * ITYP.EQ.13))) GO TO 70 ! 91: ERR = .TRUE. ! 92: CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32) ! 93: 70 RETURN ! 94: 80 ISIZ = 1 ! 95: VAR = .FALSE. ! 96: IF (L.EQ.0) CALL SATT1(KK, 8, 10) ! 97: C ! 98: C LOOP TO FIND BOUNDS; CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS ! 99: C SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT ! 100: C ALREADY SET ! 101: C ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT. ! 102: C CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS ! 103: C ! 104: L = IGATT1(KK,7) ! 105: IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90 ! 106: IF (L.EQ.0) GO TO 100 ! 107: CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44) ! 108: ERR = .TRUE. ! 109: GO TO 270 ! 110: 90 IF (L.EQ.0) CALL ERROR1( ! 111: * 44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44) ! 112: 100 IF (K2+1.LT.NSTMT) GO TO 120 ! 113: 110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28) ! 114: GO TO 270 ! 115: C ! 116: C CHECK FOR POSITIVE INTEGER BOUND ! 117: C ! 118: 120 PSTMT = K2 + 1 ! 119: IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130 ! 120: IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL ! 121: IF (ITYP.NE.12) GO TO 170 ! 122: IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE. ! 123: GO TO 170 ! 124: C ! 125: C SEEK A VARIABLE BOUND ! 126: C ! 127: 130 CALL NEXTOK(PSTMT, I1, L) ! 128: IF (L.NE.0) GO TO 110 ! 129: IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140 ! 130: CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32) ! 131: ERR = .TRUE. ! 132: GO TO 270 ! 133: 140 VAR = .TRUE. ! 134: L = LOOKUP(I1,.FALSE.) ! 135: IF (SYSERR) GO TO 70 ! 136: N = IGATT1(L,8) ! 137: IF (N.NE.0 .AND. N.NE.10) GO TO 20 ! 138: I2 = IGATT1(L,4) ! 139: IF (I2.EQ.1) GO TO 150 ! 140: CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42) ! 141: ERR = .TRUE. ! 142: GO TO 270 ! 143: 150 I2 = IGATT1(KK,4) ! 144: IF (I2.EQ.1) GO TO 160 ! 145: CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT, ! 146: * 50) ! 147: ERR = .TRUE. ! 148: GO TO 270 ! 149: 160 CALL SATT1(L, 6, 1) ! 150: CALL SATT1(L, 8, 10) ! 151: N = IGATT1(L,1) ! 152: IF (N.GT.0) GO TO 170 ! 153: N = 1 ! 154: IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2 ! 155: CALL SATT1(L, 1, N) ! 156: GO TO 170 ! 157: C ! 158: C FIND "," AND ACCUMULATE LENGTH ! 159: C ! 160: 170 ICNT = ICNT + 1 ! 161: IF (ICNT.LE.3) GO TO 180 ! 162: ISIZ = ISIZ/LL ! 163: CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30) ! 164: ICNT = 3 ! 165: FLUSH = .TRUE. ! 166: GO TO 190 ! 167: 180 K2 = I1 ! 168: IF (STMT(K2).EQ.68) GO TO 100 ! 169: C ! 170: C FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT ! 171: C ! 172: IF (STMT(K2).NE.62) GO TO 110 ! 173: 190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260 ! 174: CALL SATT1(KK, 7, ICNT) ! 175: C ! 176: C STORE LENGTH OF ARRAY ! 177: C ! 178: IF (VAR) GO TO 240 ! 179: IF (DSA(KK+2).EQ.0) GO TO 200 ! 180: N = DSA(KK+2) ! 181: DSA(N) = ISIZ ! 182: GO TO 220 ! 183: 200 IF (NEXT+2.GE.BNEXT) GO TO 210 ! 184: DSA(KK+2) = NEXT ! 185: DSA(NEXT) = ISIZ ! 186: DSA(NEXT+1) = 0 ! 187: NEXT = NEXT + 2 ! 188: GO TO 220 ! 189: 210 SYSERR = .TRUE. ! 190: CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33) ! 191: 220 IF (FLUSH) GO TO 270 ! 192: 230 K2 = K2 + 1 ! 193: GO TO 70 ! 194: C ! 195: C FIXUP FOR VARIABLY DIMENSIONED ARRAYS ! 196: C ! 197: 240 IF (DSA(KK+2).EQ.0) GO TO 250 ! 198: N = DSA(KK+2) ! 199: DSA(N) = -1 ! 200: GO TO 220 ! 201: 250 IF (NEXT+2.GE.BNEXT) GO TO 210 ! 202: DSA(KK+2) = NEXT ! 203: DSA(NEXT) = -1 ! 204: DSA(NEXT+1) = 0 ! 205: NEXT = NEXT + 2 ! 206: GO TO 220 ! 207: C ! 208: C CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT ! 209: C ! 210: 260 IF (ITYP.NE.12) GO TO 220 ! 211: IF (CORNER) KK = -KK ! 212: GO TO 220 ! 213: C ! 214: C CODE TO FLUSH CONSTRUCT--TO NEXT ")" ! 215: C ! 216: 270 IF (K2.EQ.NSTMT) GO TO 70 ! 217: IF (STMT(K2).EQ.62) GO TO 230 ! 218: K2 = K2 + 1 ! 219: GO TO 270 ! 220: C ! 221: C CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/" ! 222: C ! 223: 280 K = 90 ! 224: IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67 ! 225: 290 IF (K2.EQ.NSTMT) GO TO 70 ! 226: L = STMT(K2) ! 227: IF (L.EQ.65) GO TO 270 ! 228: IF (L.EQ.68 .OR. L.EQ.K) GO TO 70 ! 229: K2 = K2 + 1 ! 230: GO TO 290 ! 231: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.