![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to PU.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 PU.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE PU
2: INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA
3: INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4
4: INTEGER Q(70)
5: LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF
6: LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT
7: LOGICAL P2, QBR
8: COMMON /OPTNS/ OPT(5), P1ERR
9: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
10: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
11: * OUTUT4
12: COMMON /CEXPRS/ LSTACK, STACK(620)
13: COMMON /FACTS/ NAME, NOST, ITYP, IASF
14: COMMON /DETECT/ ERR, SYSERR, ABORT
15: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
16: COMMON /CHASH/ LHASH, HASH(401)
17: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
18: COMMON /DOS/ DOPT, LDO, DOLIST(192)
19: COMMON /TRANS/ Q
20: COMMON /PASS/ P2, QBR
21: C
22: C ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT. NEW IS
23: C USED TO HANDLE P.U.'S WITHOUT END STMTS. FLUSHING OF STMTS
24: C TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING
25: C LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS
26: C EOF OF INPUT FILE
27: C ERR USED AS ERROR DIAGNOSTIC INDICATOR
28: C NEWRD, NEW USED TO CONTROL INPUT
29: C
30: EOF = .FALSE.
31: NEW = .FALSE.
32: C
33: C INTER-PROGRAM INITIALIZATION
34: C NOST CONTAINS CURRENT STATEMENT NUMBER
35: C ITYP CONTAINS TYPE OF STMT
36: C BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE
37: C EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN
38: C PROGRAM UNIT EXISTING
39: C NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME
40: C P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR
41: C PASS 2
42: C RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE
43: C NEXT, BNEXT POINT INTO DSA
44: C LABHD POINTS TO HEAD OF LABELS LIST IN DSA
45: C SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA
46: C KGP, IGP USED TO CHECK STMT SEQUENCING
47: C DOPT,DOLIST USED TO CHECK DO LOOP NESTING
48: C
49: 10 NOST = 0
50: ITYP = 0
51: LTYP = 0
52: BLKD = .FALSE.
53: EXECUT = .FALSE.
54: NAME = 0
55: P1ERR = .FALSE.
56: RET = .FALSE.
57: NEXT = 1
58: BNEXT = LDSA
59: LABHD = 0
60: SYMHD = 0
61: KGP = 0
62: DOPT = 1
63: DOLIST(1) = 1
64: DO 20 I=2,6
65: DOLIST(I) = 0
66: 20 CONTINUE
67: DO 30 I=1,LHASH
68: HASH(I) = 0
69: 30 CONTINUE
70: C
71: C DONT GOTO NEW PAGE IF NOT PRODUCING LISTING
72: C
73: IF (.NOT.OPT(4)) GO TO 40
74: WRITE (OUTUT,99999)
75: 99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //)
76: C
77: C INPUT NEW STMT; RETURN WHEN HIT EOF STMT
78: C FIND LABELS
79: C
80: C HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END
81: C
82: 40 IF (.NOT.NEW) GO TO 70
83: NEW = .FALSE.
84: NOST = 1
85: IF (.NOT.OPT(4)) GO TO 80
86: K = NSTMT - 1
87: DO 50 I=1,K
88: II = STMT(I) + 1
89: STACK(I) = Q(II)
90: 50 CONTINUE
91: WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K)
92: 99998 FORMAT (1H , I5, 5X, 80A1)
93: GO TO 80
94: 60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
95: ERR = .FALSE.
96: 70 CALL INSTMT(EOF, NCARD)
97: IF (EOF) GO TO 400
98: 80 LAB = .FALSE.
99: C
100: C TYPST TYPES THE CURRENT STAMT
101: C ITYP IS NO 1-30 TELLING STMT WE HAVE
102: C KGP IS LEVEL NO 0-6 OF STMT.
103: C ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP)
104: C
105: PSTMT = 6
106: CALL TYPST(ITYP, IGP, ICNT)
107: IF (ERR) GO TO 60
108: PSTMT = 6 + ICNT
109: IF (ITYP.GE.6) GO TO 100
110: I = ITYP - 1
111: CALL TYPST(ITYP, II, K2)
112: IF (ITYP.NE.10) GO TO 90
113: PSTMT = PSTMT + K2
114: IGP = II
115: GO TO 110
116: 90 ITYP = I + 1
117: 100 I = -1
118: 110 II = 1
119: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2
120: IF (ITYP.EQ.29) II = 3
121: KEEP = PSTMT
122: PSTMT = 1
123: IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE.
124: IF (SYSERR) GO TO 450
125: C
126: C CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS
127: C
128: IF (NAME) 140, 120, 140
129: 120 IF (IGP) 130, 150, 130
130: 130 CALL SETNAM(12)
131: GO TO 150
132: 140 IF (IGP.EQ.0) GO TO 490
133: C
134: C CHECK SEQUENCING OF STMTS
135: C
136: 150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160
137: IF (IGP.GE.KGP) GO TO 170
138: CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24)
139: GO TO 450
140: 160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32)
141: GO TO 450
142: C
143: C CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT.
144: C TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE
145: C
146: 170 IF (EXECUT .OR. IGP.LT.4) GO TO 180
147: EXECUT = .TRUE.
148: K = IGATT1(NAME,8)
149: IF (K.EQ.4) CALL SATT1(NAME, 8, 10)
150: 180 PSTMT = KEEP
151: LOGIF2 = .FALSE.
152: C
153: C VALUES OF ITYP
154: C 1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG
155: C 6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION
156: C 8 COMMON
157: C 9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA
158: C 12 EQUIVALENCE
159: C 13 DATA
160: C 14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN,
161: C 17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE,
162: C 23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30
163: C ASSIGNMENT, 32 LOGICAL IF
164: C 28 END
165: C 29 FORMAT
166: C 31 ASF DEFN
167: C CLASS CODES
168: C 0-HEADING STMTS
169: C 1-SPECIFICATION STMTS (INCLUDING TYPE STMTS)
170: C 2-EQUIVALENCE
171: C 3-DATA
172: C 4-ASF DEF
173: C 5-EXECUTABLE STMTS AND FORMAT STMTS
174: C 6-END STMT
175: C
176: 190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240,
177: * 270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340,
178: * 340, 340, 340, 340, 410, 390, 290), ITYP
179: C
180: C TYPE STMTS (SYSERR)
181: C
182: 200 CALL TYPE
183: GO TO 430
184: C
185: C EXTERNAL STMT (SYSERR)
186: C
187: 210 CALL EXTERN
188: GO TO 430
189: C
190: C DIMENSION STMT(SYSERR)
191: C
192: 220 CALL DIMENS
193: GO TO 430
194: C
195: C SUBR/FCN DEFNS (SYSERR)
196: C
197: 230 CALL SUBFCN(I)
198: GO TO 430
199: C
200: C BLOCK DATA STMT (SYSERR)
201: C
202: 240 CALL SETNAM(11)
203: BLKD = .TRUE.
204: GO TO 430
205: C
206: C COMMON STMT
207: C
208: 250 CALL COMMON
209: GO TO 430
210: 260 CALL DATA
211: GO TO 430
212: 270 CALL EQUIV
213: GO TO 430
214: 280 CALL DOSTMT
215: GO TO 430
216: 290 CALL ASSASF(IGP)
217: IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320
218: GO TO 430
219: C
220: C IF STMTS
221: C
222: 300 CALL IFS(LOGIF1)
223: C
224: C FOUND AN ARITH. IF
225: C
226: IF (.NOT.LOGIF1) GO TO 430
227: C
228: C FOUND LOGICAL IF WITHIN LOGICAL IF
229: C
230: IF (LOGIF1 .AND. LOGIF2) GO TO 320
231: C
232: C FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT
233: C
234: LOGIF2 = .TRUE.
235: CALL TYPST(ITYP, K, K2)
236: IF (.NOT.ERR) GO TO 310
237: CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
238: GO TO 430
239: 310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320
240: PSTMT = PSTMT + K2
241: GO TO 190
242: 320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27)
243: GO TO 430
244: C
245: C GOTO STMTS
246: C
247: 330 CALL GOTO
248: GO TO 430
249: C
250: C I-O STMTS
251: C
252: 340 CALL IO
253: GO TO 430
254: C
255: C ASSIGN STMT
256: C
257: 350 CALL ASSIGN
258: GO TO 430
259: C
260: C RETURN CANNOT APPEAR IN MAIN PGM
261: C
262: 360 I = IGATT1(NAME,8)
263: IF (I.EQ.12) CALL ERROR1(
264: * 44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44)
265: RET = .TRUE.
266: GO TO 380
267: C
268: C CALL STMT
269: C
270: 370 CALL CALLS
271: GO TO 430
272: C
273: C CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS
274: C
275: 380 IF (PSTMT.NE.NSTMT) CALL ERROR1(
276: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
277: GO TO 430
278: C
279: C FORMAT
280: C
281: 390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26)
282: CALL FORMAT
283: GO TO 430
284: C
285: C CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT
286: C
287: 400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500
288: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
289: LAB = .FALSE.
290: ITYP = 28
291: 410 CALL END
292: C
293: C CHECK FOR NO CONTINUATION
294: C
295: IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION,
296: * 34)
297: C
298: C CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN
299: C
300: IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20)
301: * .OR. BLKD) GO TO 420
302: CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29)
303: C
304: C CHECK THERE HAVE BEEN EXECUTABLE STMTS
305: C CHECK FOR A RETURN STMT IF NECESSARY
306: C
307: 420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1(
308: * 42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42)
309: I = IGATT1(NAME,8)
310: IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430
311: CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36)
312: C
313: C CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE
314: C CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2
315: C DUE TO ERRORS IN THIS PGM UNIT
316: C
317: 430 KGP = IGP
318: IF (ITYP.NE.29) LTYP = ITYP
319: IF (LOGIF2) LTYP = 32
320: IF (SYSERR) GO TO 450
321: IF (.NOT.LAB) GO TO 440
322: CALL DOCHK(KK)
323: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1(
324: * 37H WARNING - LABELED NONEXECUTABLE STMT, 37)
325: 440 IF (EOF) GO TO 500
326: ERR = .FALSE.
327: IF (ITYP.EQ.28) GO TO 10
328: GO TO 70
329: C
330: C FLUSH CODE TO NEXT HEADR OR END SMT
331: C
332: 450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44)
333: P1ERR = .TRUE.
334: IF (SYSERR) SYSERR = .FALSE.
335: LAB = .FALSE.
336: 460 CALL INSTMT(EOF, NCARD)
337: IF (EOF) GO TO 500
338: PSTMT = 6
339: CALL TYPST(ITYP, IGP, ICNT)
340: IF (.NOT.ERR) GO TO 470
341: ERR = .FALSE.
342: GO TO 460
343: 470 IF (ITYP.EQ.28) GO TO 410
344: IF (ITYP.GT.5) GO TO 480
345: PSTMT = PSTMT + ICNT
346: CALL TYPST(ITYP, IGP, ICNT)
347: IF (ERR) ERR = .FALSE.
348: IF (ITYP.EQ.10) GO TO 490
349: GO TO 460
350: 480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460
351: C
352: C HAVE FOUND A HEADER STMT; SIMULATE AN END STMT
353: C
354: 490 NEW = .TRUE.
355: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
356: ITYP = 28
357: LAB = .FALSE.
358: GO TO 410
359: C
360: C PUT ENDING MARKER ON THE DATA FOR PASS2
361: C
362: 500 I = 1
363: II = 4
364: WRITE (OUTUT3) I, II, I
365: WRITE (OUTUT2) I, II, I
366: RETURN
367: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.