V10/cmd/pfort/CHK2.f

      INTEGER FUNCTION CHK2(IR, IE)
C
C     PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
C     CHK2 RETURNS 1 IF REF IS OK, ELSE 0
C     CHECKS TYPE OF FCN IF FCN IS REFERENCED,
C      CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE
C     TYPE AND STRUCTURE OF VARIABLE
C     AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN
C     DUMMIES FOR SETTING INFO TRANSFER IN SCAN
C     BAD STRUCTURE MATCHING MAKES REF BAD
C     NO DUMMY LINKS CREATED IN THIS CASE
C
      INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1)
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      CHK2 = 1
C     CHECK TYPE OF FCN CALLED IF A FCN
      IF (REF(4).NE.1) GO TO 10
      I = IE + SYMLEN + 6
      IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10
      IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10
      CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39,
     *  LAT(IE), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C     CYCLE THROUGH ARGS IF ANY
   10 I = IE + SYMLEN
      IF (LAT(I).EQ.0) GO TO 170
      I = LAT(I)
      N = IE + SYMLEN + 1
      L = 5
      DO 160 K=1,I
        AER(1) = K
        L1 = IGATT2(LAT(N),8)
        IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90
C     CHECK STRUCTURE AND TYPE OF VARIABLES
C     AND ARRAY ARGUMENTS
        K1 = MOD(IGATT2(LAT(N),1),8)
        K2 = IGATT2(LAT(N),7)
        IF (K2.GT.1) K2 = 1
        L1 = MOD(REF(L+1),8)
        L2 = MOD(REF(L+1),32)/8
C
C     CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED
C     ALWAYS TO INTEGER ARRAYS
C
        IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20
        IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40
      CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0)
      CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        CHK2 = 0
        GO TO 150
   20   IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30
      CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0)
      CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C
C     CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE
C
   30   IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR.
     *      L2.EQ.0)) GO TO 40
      CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2,
     *  1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1,0,1)
        CHK2 = 0
        GO TO 150
C
C     CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT
C     IF SO CREATE ARGLINK.
C     NO ARGLINK CREATED IF FCN CALLED IS AN ASF
C
   40   IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150
        K1 = IGATT1(REF(L),4)
        IF (K1.EQ.0) GO TO 150
C
C     FIND REL. POSITION OF CALLING PGM
C     DUMMY , L1 PTS TO IT IN LAT
        L3 = DSA(NAME+2)
        KK = 0
   50   KK = KK + 1
        IF (DSA(L3).EQ.REF(L)) GO TO 60
        L3 = DSA(L3+1)
        GO TO 50
   60   K2 = 0
        L1 = IR + SYMLEN - 2
   70   L1 = LAT(L1+3)
        K2 = K2 + 1
        IF (K2.LT.KK) GO TO 70
C     FIND REL POSITION OF CALLED DUMMY ARG
C     L2 PTS TO IT IN LAT
        K1 = 0
        L2 = IE + SYMLEN - 2
   80   L2 = LAT(L2+3)
        K1 = K1 + 1
        IF (K1.LT.K) GO TO 80
        IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150
        IF (PLAT+2.GT.LLAT) GO TO 180
        LAT(PLAT) = L1
        LAT(PLAT+1) = LAT(L2+2)
        LAT(L2+2) = PLAT
        PLAT = PLAT + 2
        GO TO 150
C     CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE
C     LAT(N) PTS TO DUMMY ARG ENTRY IN LAT
C     REF(L) PTS TO CORRESP REF ARG IN DSA
   90   IF (IGATT1(REF(L),4).EQ.1) GO TO 110
C     REFERENCE CONTAINS AN AACTUAL PROC NAME
C     CHECK FOR MISSING SUBPROGRAM
        L3 = REF(L)
        L2 = FINDND(DSA(L3+4),L3)
        IF (L2.NE.0) GO TO 100
        L3 = REF(L) + 4
      CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        GO TO 150
C     CALL CHK3 TO PREFORM CHECKS
  100   L5 = L2 + SYMLEN + 6
      CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER)
        GO TO 150
C     REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS
C     WHICH CAN CORRESPOND TO THAT DUMMY
C     FIRST FIND ITS CORRESP ACTUAL, IF ANY
  110   L2 = REF(L)
        L2 = DSA(L2+2)
C      L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR)
C      OF THE DUMMY ARG AT REF(L)
        L3 = IR + SYMLEN + 1
        L3 = LAT(L3)
        IF (L2.EQ.1) GO TO 130
        DO 120 L4=2,L2
          L3 = LAT(L3+3)
  120   CONTINUE
C     L3 PTS TO DUMMY ARG IN CALLING RTNE
  130   L3 = LAT(L3+1)
C     L3 CONTAINS OFFSET FOR PROC ACTUALS
C     MATCHED TO THIS DUMMY ARG
C     IN TEMPLATED OFF LAT(IR)
        L2 = IR + SYMLEN + 5
        IF (LAT(L2).NE.0) GO TO 140
        L3 = REF(L) + 4
        CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35,
     *  DSA(L3), 1, 1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        GO TO 150
C      L2 PTS TO ACTUALS TEMPLATE
  140   L2 = LAT(L2)
        L4 = L2 + L3
C      LAT(L4) IS ACTUAL PAIRED TO REF(L)
        L5 = LAT(L4) + SYMLEN + 6
      CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER)
C     CYCLE TO NEXT ACTUAL
        L2 = LAT(L2) + L2
        IF (LAT(L2)) 150, 150, 140
  150   L = L + 2
        N = LAT(N) + 3
  160 CONTINUE
  170 RETURN
  180 SYSERR = .TRUE.
      CHK2 = 0
      CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31)
      GO TO 170
      END