V10/cmd/pfort/EQUIV.f

      SUBROUTINE EQUIV
      INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD
      LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
C
C     PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY ,
C     IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER
C     ELEMENTS;  ARDECL CALLED TO PROCESS DECLARATORS
C     SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE
C     CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES.
C     E.G. A(1,1,1)
C
   10 IF (STMT(PSTMT).EQ.65) GO TO 30
   20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      GO TO 150
   30 TYPE = -1
      IPT = 1
      CORNR = .TRUE.
      SAME = .TRUE.
   40 PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 20
      IF (.NOT.ARDECL(K2,KK)) GO TO 150
      IF (SYSERR .OR. ERR) GO TO 150
C
C     KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT
C
      L = IGATT1(IABS(KK),7)
      IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE.
      KK = IABS(KK)
C
C     SET USAGE, IF UNSET
C
      L = IGATT1(KK,8)
      IF (L.EQ.0) CALL SATT1(KK, 8, 10)
C
C     STORE VARIABLE IN STACK, CHECK VARIABLE TYPE
C
      STACK(IPT) = KK
      IPT = IPT + 1
      CALL SATT1(KK, 3, 1)
      I = IGATT1(KK,1)
      I = MOD(I,8)
      IF (-1.EQ.TYPE) TYPE = I
      IF (TYPE.EQ.I) GO TO 50
      SAME = .FALSE.
C
C     END OF DELARATOR CHECKS; NEED , OR )
C
   50 IF (STMT(K2).NE.68) GO TO 60
      PSTMT = K2
      GO TO 40
   60 IF (STMT(K2).NE.62) GO TO 20
C
C     CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED
C
      IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1(
     *    53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53)
C
C     CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON
C     REGION APPEARS
C
      KK = IPT - 1
C
C     PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK
C
      DO 80 I=1,KK
        L = IGATT1(STACK(I),2)
        IF (L) 80, 80, 70
 70   IF(IPT+1.GT.LSTACK) GOTO 160
        L = STACK(I)
        L = DSA(L+2)
        STACK(IPT) = DSA(L+1)
        IPT = IPT + 1
   80 CONTINUE
      IF (KK+2.GE.IPT) GO TO 90
      CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40)
      GO TO 130
   90 IF (KK+1.EQ.IPT) GO TO 130
C
C     MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK
C     THAT ANY ONE OF THEM IS ACTUALLY  IN
C
      DO 120 I=1,KK
        L = IGATT1(STACK(I),2)
        IF (L.EQ.1) GO TO 120
        CALL SATT1(STACK(I), 2, 1)
        L = STACK(I)
        IF (DSA(L+2)) 100, 100, 110
 100  IF(NEXT+2.GE.BNEXT) GOTO 170
        DSA(L+2) = NEXT
        DSA(NEXT) = 0
        DSA(NEXT+1) = STACK(IPT-1)
        NEXT = NEXT + 2
        GO TO 120
  110   L = DSA(L+2)
        DSA(L+1) = STACK(IPT-1)
  120 CONTINUE
  130 IF (K2+1.EQ.NSTMT) GO TO 150
      IF (STMT(K2+1).NE.68) GO TO 20
      PSTMT = K2 + 2
      GO TO 10
  150 RETURN
 160  CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34)
 180  SYSERR = .TRUE.
      GOTO 150
 170  CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32)
      GOTO 180
      END