![[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] / researchv10dc / cmd / pfort|
Return to PU.f CVS log | Up to [Research Unix] / researchv10dc / 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.