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