![[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.