![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to CHK2.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 CHK2.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: INTEGER FUNCTION CHK2(IR, IE)
2: C
3: C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
4: C CHK2 RETURNS 1 IF REF IS OK, ELSE 0
5: C CHECKS TYPE OF FCN IF FCN IS REFERENCED,
6: C CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE
7: C TYPE AND STRUCTURE OF VARIABLE
8: C AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN
9: C DUMMIES FOR SETTING INFO TRANSFER IN SCAN
10: C BAD STRUCTURE MATCHING MAKES REF BAD
11: C NO DUMMY LINKS CREATED IN THIS CASE
12: C
13: INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1)
14: LOGICAL ERR, SYSERR, ABORT
15: COMMON /DETECT/ ERR, SYSERR, ABORT
16: COMMON /CREF/ LREF, PREF, REF(100)
17: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
18: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
19: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
20: COMMON /FACTS/ NAME, NOST, ITYP, IASF
21: CHK2 = 1
22: C CHECK TYPE OF FCN CALLED IF A FCN
23: IF (REF(4).NE.1) GO TO 10
24: I = IE + SYMLEN + 6
25: IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10
26: IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10
27: CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39,
28: * LAT(IE), 1, 1, 0)
29: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
30: C CYCLE THROUGH ARGS IF ANY
31: 10 I = IE + SYMLEN
32: IF (LAT(I).EQ.0) GO TO 170
33: I = LAT(I)
34: N = IE + SYMLEN + 1
35: L = 5
36: DO 160 K=1,I
37: AER(1) = K
38: L1 = IGATT2(LAT(N),8)
39: IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90
40: C CHECK STRUCTURE AND TYPE OF VARIABLES
41: C AND ARRAY ARGUMENTS
42: K1 = MOD(IGATT2(LAT(N),1),8)
43: K2 = IGATT2(LAT(N),7)
44: IF (K2.GT.1) K2 = 1
45: L1 = MOD(REF(L+1),8)
46: L2 = MOD(REF(L+1),32)/8
47: C
48: C CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED
49: C ALWAYS TO INTEGER ARRAYS
50: C
51: IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20
52: IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40
53: CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0)
54: CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0)
55: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
56: CHK2 = 0
57: GO TO 150
58: 20 IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30
59: CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0)
60: CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0)
61: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
62: C
63: C CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE
64: C
65: 30 IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR.
66: * L2.EQ.0)) GO TO 40
67: CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2,
68: * 1, 0)
69: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0)
70: CALL ERROR2(1H1, 0, REF(3), -1,0,1)
71: CHK2 = 0
72: GO TO 150
73: C
74: C CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT
75: C IF SO CREATE ARGLINK.
76: C NO ARGLINK CREATED IF FCN CALLED IS AN ASF
77: C
78: 40 IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150
79: K1 = IGATT1(REF(L),4)
80: IF (K1.EQ.0) GO TO 150
81: C
82: C FIND REL. POSITION OF CALLING PGM
83: C DUMMY , L1 PTS TO IT IN LAT
84: L3 = DSA(NAME+2)
85: KK = 0
86: 50 KK = KK + 1
87: IF (DSA(L3).EQ.REF(L)) GO TO 60
88: L3 = DSA(L3+1)
89: GO TO 50
90: 60 K2 = 0
91: L1 = IR + SYMLEN - 2
92: 70 L1 = LAT(L1+3)
93: K2 = K2 + 1
94: IF (K2.LT.KK) GO TO 70
95: C FIND REL POSITION OF CALLED DUMMY ARG
96: C L2 PTS TO IT IN LAT
97: K1 = 0
98: L2 = IE + SYMLEN - 2
99: 80 L2 = LAT(L2+3)
100: K1 = K1 + 1
101: IF (K1.LT.K) GO TO 80
102: IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150
103: IF (PLAT+2.GT.LLAT) GO TO 180
104: LAT(PLAT) = L1
105: LAT(PLAT+1) = LAT(L2+2)
106: LAT(L2+2) = PLAT
107: PLAT = PLAT + 2
108: GO TO 150
109: C CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE
110: C LAT(N) PTS TO DUMMY ARG ENTRY IN LAT
111: C REF(L) PTS TO CORRESP REF ARG IN DSA
112: 90 IF (IGATT1(REF(L),4).EQ.1) GO TO 110
113: C REFERENCE CONTAINS AN AACTUAL PROC NAME
114: C CHECK FOR MISSING SUBPROGRAM
115: L3 = REF(L)
116: L2 = FINDND(DSA(L3+4),L3)
117: IF (L2.NE.0) GO TO 100
118: L3 = REF(L) + 4
119: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0)
120: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
121: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
122: GO TO 150
123: C CALL CHK3 TO PREFORM CHECKS
124: 100 L5 = L2 + SYMLEN + 6
125: CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER)
126: GO TO 150
127: C REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS
128: C WHICH CAN CORRESPOND TO THAT DUMMY
129: C FIRST FIND ITS CORRESP ACTUAL, IF ANY
130: 110 L2 = REF(L)
131: L2 = DSA(L2+2)
132: C L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR)
133: C OF THE DUMMY ARG AT REF(L)
134: L3 = IR + SYMLEN + 1
135: L3 = LAT(L3)
136: IF (L2.EQ.1) GO TO 130
137: DO 120 L4=2,L2
138: L3 = LAT(L3+3)
139: 120 CONTINUE
140: C L3 PTS TO DUMMY ARG IN CALLING RTNE
141: 130 L3 = LAT(L3+1)
142: C L3 CONTAINS OFFSET FOR PROC ACTUALS
143: C MATCHED TO THIS DUMMY ARG
144: C IN TEMPLATED OFF LAT(IR)
145: L2 = IR + SYMLEN + 5
146: IF (LAT(L2).NE.0) GO TO 140
147: L3 = REF(L) + 4
148: CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35,
149: * DSA(L3), 1, 1, 0)
150: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
151: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
152: GO TO 150
153: C L2 PTS TO ACTUALS TEMPLATE
154: 140 L2 = LAT(L2)
155: L4 = L2 + L3
156: C LAT(L4) IS ACTUAL PAIRED TO REF(L)
157: L5 = LAT(L4) + SYMLEN + 6
158: CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER)
159: C CYCLE TO NEXT ACTUAL
160: L2 = LAT(L2) + L2
161: IF (LAT(L2)) 150, 150, 140
162: 150 L = L + 2
163: N = LAT(N) + 3
164: 160 CONTINUE
165: 170 RETURN
166: 180 SYSERR = .TRUE.
167: CHK2 = 0
168: CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31)
169: GO TO 170
170: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.