![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ASSASF.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 ASSASF.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE ASSASF(IGP)
2: INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD
3: LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR
4: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
5: COMMON /DETECT/ ERR, SYSERR, ABORT
6: COMMON /FACTS/ NAME, NOST, ITYP, IASF
7: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
8: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
9: C
10: C PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS
11: C FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT
12: C
13: CALL NEXTOK(PSTMT, K2, K)
14: ASF = .FALSE.
15: IF (K.NE.0) GO TO 180
16: K = LOOKUP(K2,.FALSE.)
17: IF (SYSERR) GO TO 190
18: I1 = IGATT1(K,1)
19: IF (I1.NE.0) GO TO 10
20: I1 = 1
21: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2
22: CALL SATT1(K, 1, I1)
23: C
24: C LOOK FOR A "(" ; FIND ARRAY = CASE AND SEND IT TO ERROR
25: C FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO
26: C ASSIGNMENT CODE
27: C
28: 10 I2 = IGATT1(K,7)
29: I1 = MOD(I1,8)
30: IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180
31: IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240
32: C
33: C ASF DEFN
34: C
35: ITYP = 31
36: ASF = .TRUE.
37: IGP = 4
38: NUM = 0
39: IASF = K
40: 20 PSTMT = K2 + 1
41: IF (PSTMT.GE.NSTMT) GO TO 180
42: C
43: C ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET
44: C
45: CALL NEXTOK(PSTMT, K2, I)
46: IF (I.EQ.0) GO TO 30
47: CALL ERROR1(17H ILLEGAL ASF DEFN, 17)
48: GO TO 190
49: 30 I = LOOKUP(K2,.FALSE.)
50: IF (SYSERR) GO TO 190
51: NUM = NUM + 1
52: I2 = IGATT1(I,1)
53: IF (I2.GT.0) GO TO 40
54: I2 = 1
55: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2
56: CALL SATT1(I, 1, I2)
57: 40 I2 = IGATT1(I,8)
58: IF (I2.EQ.0) GO TO 50
59: IF (I2.EQ.1) GO TO 60
60: CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29)
61: GO TO 210
62: 50 CALL SATT1(I, 8, 1)
63: C STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL
64: C TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE
65: 60 DSA(I+2) = K
66: C
67: C LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA
68: C
69: IF (DSA(K+2).EQ.0) GO TO 120
70: L = DSA(K+2)
71: 70 IF (DSA(L+1).EQ.0) GO TO 80
72: L = DSA(L+1)
73: GO TO 70
74: 80 IF (NEXT+2.LT.BNEXT) GO TO 100
75: 90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33)
76: SYSERR = .TRUE.
77: GO TO 190
78: 100 DSA(L+1) = NEXT
79: 110 DSA(NEXT) = I
80: DSA(NEXT+1) = 0
81: NEXT = NEXT + 2
82: GO TO 130
83: 120 IF (NEXT+2.GE.BNEXT) GO TO 90
84: DSA(K+2) = NEXT
85: GO TO 110
86: 130 IF (STMT(K2).NE.62) GO TO 170
87: C
88: C CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID
89: C
90: I2 = DSA(K+2)
91: DO 160 I=1,NUM
92: L = DSA(K+2)
93: DO 150 J=1,NUM
94: IF (I.EQ.J) GO TO 140
95: IF (DSA(L).NE.DSA(I2)) GO TO 140
96: CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18)
97: CALL SATT1(K, 8, 0)
98: GO TO 190
99: 140 L = DSA(L+1)
100: 150 CONTINUE
101: I2 = DSA(I2+1)
102: 160 CONTINUE
103: GO TO 200
104: 170 IF (STMT(K2).EQ.68) GO TO 20
105: 180 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
106: 190 RETURN
107: C
108: C = AND EXPR CHECK
109: C
110: 200 PSTMT = K2 + 1
111: 210 IF (PSTMT.GE.NSTMT) GO TO 180
112: IF (STMT(PSTMT).NE.63) GO TO 180
113: PSTMT = PSTMT + 1
114: IF (PSTMT.GE.NSTMT) GO TO 180
115: L = EXPR(I)
116: IF (SYSERR) GO TO 190
117: C
118: C CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE
119: C
120: IF (.NOT.ASF) GO TO 230
121: I2 = IGATT1(K,8)
122: IF (I2.EQ.0) GO TO 220
123: CALL ERROR1(17H ILLEGAL ASF NAME, 17)
124: GO TO 190
125: 220 CALL SATT1(K, 8, 2)
126: 230 IF (L/8.EQ.1) GO TO 280
127: L = MOD(L,8)
128: C
129: C COMPARE TYPES OF RHS AND LHS
130: C
131: IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR.
132: * (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190
133: IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL
134: * ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38)
135: GO TO 190
136: C
137: C PROCESSING FOR ASSIGNMENT STMT
138: C
139: 240 I = IGATT1(K,8)
140: IF (I.NE.0) GO TO 250
141: I = 10
142: CALL SATT1(K, 8, 10)
143: 250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260
144: CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31)
145: GO TO 190
146: 260 CALL SATT1(K, 5, 1)
147: IF (STMT(K2).EQ.65) GO TO 270
148: IF (DOVAR(K)) CALL ERROR1(
149: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
150: * 57)
151: PSTMT = K2
152: GO TO 210
153: 270 PSTMT = K2 + 1
154: IF (PSTMT.GE.NSTMT) GO TO 180
155: CALL SUBS(I, I2)
156: C
157: C PEEL SUBSCRIPTS OFF
158: C
159: IF (SYSERR .OR. ERR) GO TO 190
160: PSTMT = I
161: GO TO 210
162: 280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30)
163: GO TO 190
164: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.