Return to EQUIV.f CVS log

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

researchv10 Norman

      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

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