Return to ASSASF.f CVS log

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

researchv10 Norman

      SUBROUTINE ASSASF(IGP)
      INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD
      LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
C
C     PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS
C     FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT
C
      CALL NEXTOK(PSTMT, K2, K)
      ASF = .FALSE.
      IF (K.NE.0) GO TO 180
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      I1 = IGATT1(K,1)
      IF (I1.NE.0) GO TO 10
      I1 = 1
      IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2
      CALL SATT1(K, 1, I1)
C
C     LOOK FOR A "("  ; FIND ARRAY = CASE AND SEND IT TO ERROR
C     FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO
C     ASSIGNMENT CODE
C
   10 I2 = IGATT1(K,7)
      I1 = MOD(I1,8)
      IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180
      IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240
C
C     ASF DEFN
C
      ITYP = 31
      ASF = .TRUE.
      IGP = 4
      NUM = 0
      IASF = K
   20 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
C
C     ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET
C
      CALL NEXTOK(PSTMT, K2, I)
      IF (I.EQ.0) GO TO 30
      CALL ERROR1(17H ILLEGAL ASF DEFN, 17)
      GO TO 190
   30 I = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      NUM = NUM + 1
      I2 = IGATT1(I,1)
      IF (I2.GT.0) GO TO 40
      I2 = 1
      IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2
      CALL SATT1(I, 1, I2)
   40 I2 = IGATT1(I,8)
      IF (I2.EQ.0) GO TO 50
      IF (I2.EQ.1) GO TO 60
      CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29)
      GO TO 210
   50 CALL SATT1(I, 8, 1)
C     STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL
C     TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE
   60 DSA(I+2) = K
C
C     LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA
C
      IF (DSA(K+2).EQ.0) GO TO 120
      L = DSA(K+2)
   70 IF (DSA(L+1).EQ.0) GO TO 80
      L = DSA(L+1)
      GO TO 70
   80 IF (NEXT+2.LT.BNEXT) GO TO 100
   90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33)
      SYSERR = .TRUE.
      GO TO 190
  100 DSA(L+1) = NEXT
  110 DSA(NEXT) = I
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 130
  120 IF (NEXT+2.GE.BNEXT) GO TO 90
      DSA(K+2) = NEXT
      GO TO 110
  130 IF (STMT(K2).NE.62) GO TO 170
C
C     CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID
C
      I2 = DSA(K+2)
      DO 160 I=1,NUM
        L = DSA(K+2)
        DO 150 J=1,NUM
          IF (I.EQ.J) GO TO 140
          IF (DSA(L).NE.DSA(I2)) GO TO 140
          CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18)
          CALL SATT1(K, 8, 0)
          GO TO 190
  140     L = DSA(L+1)
  150   CONTINUE
        I2 = DSA(I2+1)
  160 CONTINUE
      GO TO 200
  170 IF (STMT(K2).EQ.68) GO TO 20
  180 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
  190 RETURN
C
C     = AND EXPR CHECK
C
  200 PSTMT = K2 + 1
  210 IF (PSTMT.GE.NSTMT) GO TO 180
      IF (STMT(PSTMT).NE.63) GO TO 180
      PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
      L = EXPR(I)
      IF (SYSERR) GO TO 190
C
C     CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE
C
      IF (.NOT.ASF) GO TO 230
      I2 = IGATT1(K,8)
      IF (I2.EQ.0) GO TO 220
      CALL ERROR1(17H ILLEGAL ASF NAME, 17)
      GO TO 190
  220 CALL SATT1(K, 8, 2)
  230 IF (L/8.EQ.1) GO TO 280
      L = MOD(L,8)
C
C     COMPARE TYPES OF RHS AND LHS
C
      IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR.
     *    (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190
      IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL
     *    ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38)
      GO TO 190
C
C     PROCESSING  FOR ASSIGNMENT STMT
C
  240 I = IGATT1(K,8)
      IF (I.NE.0) GO TO 250
      I = 10
      CALL SATT1(K, 8, 10)
  250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260
      CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31)
      GO TO 190
  260 CALL SATT1(K, 5, 1)
      IF (STMT(K2).EQ.65) GO TO 270
      IF (DOVAR(K)) CALL ERROR1(
     *    57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
     *    57)
      PSTMT = K2
      GO TO 210
  270 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
      CALL SUBS(I, I2)
C
C     PEEL SUBSCRIPTS OFF
C
      IF (SYSERR .OR. ERR) GO TO 190
      PSTMT = I
      GO TO 210
  280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30)
      GO TO 190
      END

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