Return to CHK2.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

researchv10 Norman

      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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.