![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to EQUIV.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 EQUIV.f CVS log | Up to [Research Unix] / researchv10dc / cmd / pfort |
1.1 root 1: SUBROUTINE EQUIV
2: INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD
3: LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT
4: COMMON /DETECT/ ERR, SYSERR, ABORT
5: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
6: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
7: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
8: COMMON /CEXPRS/ LSTACK, STACK(620)
9: C
10: C PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY ,
11: C IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER
12: C ELEMENTS; ARDECL CALLED TO PROCESS DECLARATORS
13: C SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE
14: C CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES.
15: C E.G. A(1,1,1)
16: C
17: 10 IF (STMT(PSTMT).EQ.65) GO TO 30
18: 20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
19: GO TO 150
20: 30 TYPE = -1
21: IPT = 1
22: CORNR = .TRUE.
23: SAME = .TRUE.
24: 40 PSTMT = PSTMT + 1
25: IF (PSTMT.GE.NSTMT) GO TO 20
26: IF (.NOT.ARDECL(K2,KK)) GO TO 150
27: IF (SYSERR .OR. ERR) GO TO 150
28: C
29: C KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT
30: C
31: L = IGATT1(IABS(KK),7)
32: IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE.
33: KK = IABS(KK)
34: C
35: C SET USAGE, IF UNSET
36: C
37: L = IGATT1(KK,8)
38: IF (L.EQ.0) CALL SATT1(KK, 8, 10)
39: C
40: C STORE VARIABLE IN STACK, CHECK VARIABLE TYPE
41: C
42: STACK(IPT) = KK
43: IPT = IPT + 1
44: CALL SATT1(KK, 3, 1)
45: I = IGATT1(KK,1)
46: I = MOD(I,8)
47: IF (-1.EQ.TYPE) TYPE = I
48: IF (TYPE.EQ.I) GO TO 50
49: SAME = .FALSE.
50: C
51: C END OF DELARATOR CHECKS; NEED , OR )
52: C
53: 50 IF (STMT(K2).NE.68) GO TO 60
54: PSTMT = K2
55: GO TO 40
56: 60 IF (STMT(K2).NE.62) GO TO 20
57: C
58: C CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED
59: C
60: IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1(
61: * 53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53)
62: C
63: C CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON
64: C REGION APPEARS
65: C
66: KK = IPT - 1
67: C
68: C PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK
69: C
70: DO 80 I=1,KK
71: L = IGATT1(STACK(I),2)
72: IF (L) 80, 80, 70
73: 70 IF(IPT+1.GT.LSTACK) GOTO 160
74: L = STACK(I)
75: L = DSA(L+2)
76: STACK(IPT) = DSA(L+1)
77: IPT = IPT + 1
78: 80 CONTINUE
79: IF (KK+2.GE.IPT) GO TO 90
80: CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40)
81: GO TO 130
82: 90 IF (KK+1.EQ.IPT) GO TO 130
83: C
84: C MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK
85: C THAT ANY ONE OF THEM IS ACTUALLY IN
86: C
87: DO 120 I=1,KK
88: L = IGATT1(STACK(I),2)
89: IF (L.EQ.1) GO TO 120
90: CALL SATT1(STACK(I), 2, 1)
91: L = STACK(I)
92: IF (DSA(L+2)) 100, 100, 110
93: 100 IF(NEXT+2.GE.BNEXT) GOTO 170
94: DSA(L+2) = NEXT
95: DSA(NEXT) = 0
96: DSA(NEXT+1) = STACK(IPT-1)
97: NEXT = NEXT + 2
98: GO TO 120
99: 110 L = DSA(L+2)
100: DSA(L+1) = STACK(IPT-1)
101: 120 CONTINUE
102: 130 IF (K2+1.EQ.NSTMT) GO TO 150
103: IF (STMT(K2+1).NE.68) GO TO 20
104: PSTMT = K2 + 2
105: GO TO 10
106: 150 RETURN
107: 160 CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34)
108: 180 SYSERR = .TRUE.
109: GOTO 150
110: 170 CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32)
111: GOTO 180
112: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.