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