Return to COMMON.f CVS log

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

researchv10 Norman

      SUBROUTINE COMMON
      INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4)
      LOGICAL ERR, SYSERR, ABORT, ARDECL
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/
C
C     PROCESSES A COMMON STMT
C     FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE
C     CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT
C
      IF (STMT(PSTMT).EQ.67) GO TO 30
C
C     SET SYMBOL TABLE ENTRY FOR BLANK COMMON
C
   10 I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) GO TO 170
      IF (PSTMT.GE.NSTMT) GO TO 200
      L = PSTMT
      DO 20 I1=1,4
        STMT(I1) = S(I1)
   20 CONTINUE
      PSTMT = 1
      KK = LOOKUP(5,.FALSE.)
      IF (SYSERR) GO TO 190
      PSTMT = L
      CALL SATT1(KK, 8, 7)
      GO TO 60
   30 PSTMT = PSTMT + 1
      IF (STMT(PSTMT).NE.67) GO TO 40
      PSTMT = PSTMT + 1
      GO TO 10
   40 IF (PSTMT.GE.NSTMT) GO TO 200
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 200
      KK = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      I1 = IGATT1(KK,1)
      N = IGATT1(KK,8)
      IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50
      CALL ERROR1(20H ILLEGAL COMMON NAME, 20)
      GO TO 190
   50 CALL SATT1(KK, 8, 7)
      I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) CALL SATT1(KK, 2, 1)
      PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200
C
C     ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT
C     VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM
C
   60 IF (ARDECL(K2,N)) GO TO 70
      CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR,
     *    47)
      GO TO 190
   70 IF (SYSERR .OR. ERR) GO TO 190
C
C     SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON
C     PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D
C     WORD--FOR ARRAYS
C
      I1 = IGATT1(N,2)
      IF (I1.NE.0) GO TO 160
      CALL SATT1(N, 2, 1)
      I1 = IGATT1(N,7)
      IF (I1.EQ.0) GO TO 80
      L = DSA(N+2)
      DSA(L+1) = KK
      GO TO 90
   80 CALL SATT1(N, 8, 10)
      IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(N+2) = NEXT
      DSA(NEXT) = 0
      DSA(NEXT+1) = KK
      NEXT = NEXT + 2
C
C     SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE
C     ENTRY OF COMMON NAME
C
   90 IF (DSA(KK+2).EQ.0) GO TO 130
      L = DSA(KK+2)
  100 IF (DSA(L+1).EQ.0) GO TO 110
      L = DSA(L+1)
      GO TO 100
  110 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(L+1) = NEXT
  120 DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 140
  130 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(KK+2) = NEXT
      GO TO 120
C
C     CHECK FOR END OF STMT
C
  140 IF (K2.EQ.NSTMT) GO TO 190
      IF (STMT(K2).NE.68) GO TO 150
      PSTMT = K2 + 1
      GO TO 60
  150 IF (STMT(K2).NE.67) GO TO 200
      PSTMT = K2
      GO TO 30
  160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23)
      GO TO 140
  170 CALL ERROR1(
     *    51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51)
      GO TO 190
  180 SYSERR = .TRUE.
      CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33)
  190 RETURN
  200 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      GO TO 190
      END

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