![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to COMMON.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 COMMON.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE COMMON ! 2: INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4) ! 3: LOGICAL ERR, SYSERR, ABORT, ARDECL ! 4: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 5: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 7: COMMON /DETECT/ ERR, SYSERR, ABORT ! 8: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 9: DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/ ! 10: C ! 11: C PROCESSES A COMMON STMT ! 12: C FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE ! 13: C CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT ! 14: C ! 15: IF (STMT(PSTMT).EQ.67) GO TO 30 ! 16: C ! 17: C SET SYMBOL TABLE ENTRY FOR BLANK COMMON ! 18: C ! 19: 10 I1 = IGATT1(NAME,8) ! 20: IF (I1.EQ.11) GO TO 170 ! 21: IF (PSTMT.GE.NSTMT) GO TO 200 ! 22: L = PSTMT ! 23: DO 20 I1=1,4 ! 24: STMT(I1) = S(I1) ! 25: 20 CONTINUE ! 26: PSTMT = 1 ! 27: KK = LOOKUP(5,.FALSE.) ! 28: IF (SYSERR) GO TO 190 ! 29: PSTMT = L ! 30: CALL SATT1(KK, 8, 7) ! 31: GO TO 60 ! 32: 30 PSTMT = PSTMT + 1 ! 33: IF (STMT(PSTMT).NE.67) GO TO 40 ! 34: PSTMT = PSTMT + 1 ! 35: GO TO 10 ! 36: 40 IF (PSTMT.GE.NSTMT) GO TO 200 ! 37: CALL NEXTOK(PSTMT, K2, L) ! 38: IF (L.NE.0) GO TO 200 ! 39: KK = LOOKUP(K2,.FALSE.) ! 40: IF (SYSERR) GO TO 190 ! 41: I1 = IGATT1(KK,1) ! 42: N = IGATT1(KK,8) ! 43: IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50 ! 44: CALL ERROR1(20H ILLEGAL COMMON NAME, 20) ! 45: GO TO 190 ! 46: 50 CALL SATT1(KK, 8, 7) ! 47: I1 = IGATT1(NAME,8) ! 48: IF (I1.EQ.11) CALL SATT1(KK, 2, 1) ! 49: PSTMT = K2 + 1 ! 50: IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200 ! 51: C ! 52: C ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT ! 53: C VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM ! 54: C ! 55: 60 IF (ARDECL(K2,N)) GO TO 70 ! 56: CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR, ! 57: * 47) ! 58: GO TO 190 ! 59: 70 IF (SYSERR .OR. ERR) GO TO 190 ! 60: C ! 61: C SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON ! 62: C PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D ! 63: C WORD--FOR ARRAYS ! 64: C ! 65: I1 = IGATT1(N,2) ! 66: IF (I1.NE.0) GO TO 160 ! 67: CALL SATT1(N, 2, 1) ! 68: I1 = IGATT1(N,7) ! 69: IF (I1.EQ.0) GO TO 80 ! 70: L = DSA(N+2) ! 71: DSA(L+1) = KK ! 72: GO TO 90 ! 73: 80 CALL SATT1(N, 8, 10) ! 74: IF (NEXT+2.GE.BNEXT) GO TO 180 ! 75: DSA(N+2) = NEXT ! 76: DSA(NEXT) = 0 ! 77: DSA(NEXT+1) = KK ! 78: NEXT = NEXT + 2 ! 79: C ! 80: C SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE ! 81: C ENTRY OF COMMON NAME ! 82: C ! 83: 90 IF (DSA(KK+2).EQ.0) GO TO 130 ! 84: L = DSA(KK+2) ! 85: 100 IF (DSA(L+1).EQ.0) GO TO 110 ! 86: L = DSA(L+1) ! 87: GO TO 100 ! 88: 110 IF (NEXT+2.GE.BNEXT) GO TO 180 ! 89: DSA(L+1) = NEXT ! 90: 120 DSA(NEXT) = N ! 91: DSA(NEXT+1) = 0 ! 92: NEXT = NEXT + 2 ! 93: GO TO 140 ! 94: 130 IF (NEXT+2.GE.BNEXT) GO TO 180 ! 95: DSA(KK+2) = NEXT ! 96: GO TO 120 ! 97: C ! 98: C CHECK FOR END OF STMT ! 99: C ! 100: 140 IF (K2.EQ.NSTMT) GO TO 190 ! 101: IF (STMT(K2).NE.68) GO TO 150 ! 102: PSTMT = K2 + 1 ! 103: GO TO 60 ! 104: 150 IF (STMT(K2).NE.67) GO TO 200 ! 105: PSTMT = K2 ! 106: GO TO 30 ! 107: 160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23) ! 108: GO TO 140 ! 109: 170 CALL ERROR1( ! 110: * 51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51) ! 111: GO TO 190 ! 112: 180 SYSERR = .TRUE. ! 113: CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33) ! 114: 190 RETURN ! 115: 200 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 116: GO TO 190 ! 117: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.