![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ASSASF.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to ASSASF.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE ASSASF(IGP) ! 2: INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD ! 3: LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR ! 4: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 5: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 7: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 8: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 9: C ! 10: C PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS ! 11: C FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT ! 12: C ! 13: CALL NEXTOK(PSTMT, K2, K) ! 14: ASF = .FALSE. ! 15: IF (K.NE.0) GO TO 180 ! 16: K = LOOKUP(K2,.FALSE.) ! 17: IF (SYSERR) GO TO 190 ! 18: I1 = IGATT1(K,1) ! 19: IF (I1.NE.0) GO TO 10 ! 20: I1 = 1 ! 21: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2 ! 22: CALL SATT1(K, 1, I1) ! 23: C ! 24: C LOOK FOR A "(" ; FIND ARRAY = CASE AND SEND IT TO ERROR ! 25: C FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO ! 26: C ASSIGNMENT CODE ! 27: C ! 28: 10 I2 = IGATT1(K,7) ! 29: I1 = MOD(I1,8) ! 30: IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180 ! 31: IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240 ! 32: C ! 33: C ASF DEFN ! 34: C ! 35: ITYP = 31 ! 36: ASF = .TRUE. ! 37: IGP = 4 ! 38: NUM = 0 ! 39: IASF = K ! 40: 20 PSTMT = K2 + 1 ! 41: IF (PSTMT.GE.NSTMT) GO TO 180 ! 42: C ! 43: C ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET ! 44: C ! 45: CALL NEXTOK(PSTMT, K2, I) ! 46: IF (I.EQ.0) GO TO 30 ! 47: CALL ERROR1(17H ILLEGAL ASF DEFN, 17) ! 48: GO TO 190 ! 49: 30 I = LOOKUP(K2,.FALSE.) ! 50: IF (SYSERR) GO TO 190 ! 51: NUM = NUM + 1 ! 52: I2 = IGATT1(I,1) ! 53: IF (I2.GT.0) GO TO 40 ! 54: I2 = 1 ! 55: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2 ! 56: CALL SATT1(I, 1, I2) ! 57: 40 I2 = IGATT1(I,8) ! 58: IF (I2.EQ.0) GO TO 50 ! 59: IF (I2.EQ.1) GO TO 60 ! 60: CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29) ! 61: GO TO 210 ! 62: 50 CALL SATT1(I, 8, 1) ! 63: C STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL ! 64: C TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE ! 65: 60 DSA(I+2) = K ! 66: C ! 67: C LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA ! 68: C ! 69: IF (DSA(K+2).EQ.0) GO TO 120 ! 70: L = DSA(K+2) ! 71: 70 IF (DSA(L+1).EQ.0) GO TO 80 ! 72: L = DSA(L+1) ! 73: GO TO 70 ! 74: 80 IF (NEXT+2.LT.BNEXT) GO TO 100 ! 75: 90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33) ! 76: SYSERR = .TRUE. ! 77: GO TO 190 ! 78: 100 DSA(L+1) = NEXT ! 79: 110 DSA(NEXT) = I ! 80: DSA(NEXT+1) = 0 ! 81: NEXT = NEXT + 2 ! 82: GO TO 130 ! 83: 120 IF (NEXT+2.GE.BNEXT) GO TO 90 ! 84: DSA(K+2) = NEXT ! 85: GO TO 110 ! 86: 130 IF (STMT(K2).NE.62) GO TO 170 ! 87: C ! 88: C CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID ! 89: C ! 90: I2 = DSA(K+2) ! 91: DO 160 I=1,NUM ! 92: L = DSA(K+2) ! 93: DO 150 J=1,NUM ! 94: IF (I.EQ.J) GO TO 140 ! 95: IF (DSA(L).NE.DSA(I2)) GO TO 140 ! 96: CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18) ! 97: CALL SATT1(K, 8, 0) ! 98: GO TO 190 ! 99: 140 L = DSA(L+1) ! 100: 150 CONTINUE ! 101: I2 = DSA(I2+1) ! 102: 160 CONTINUE ! 103: GO TO 200 ! 104: 170 IF (STMT(K2).EQ.68) GO TO 20 ! 105: 180 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 106: 190 RETURN ! 107: C ! 108: C = AND EXPR CHECK ! 109: C ! 110: 200 PSTMT = K2 + 1 ! 111: 210 IF (PSTMT.GE.NSTMT) GO TO 180 ! 112: IF (STMT(PSTMT).NE.63) GO TO 180 ! 113: PSTMT = PSTMT + 1 ! 114: IF (PSTMT.GE.NSTMT) GO TO 180 ! 115: L = EXPR(I) ! 116: IF (SYSERR) GO TO 190 ! 117: C ! 118: C CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE ! 119: C ! 120: IF (.NOT.ASF) GO TO 230 ! 121: I2 = IGATT1(K,8) ! 122: IF (I2.EQ.0) GO TO 220 ! 123: CALL ERROR1(17H ILLEGAL ASF NAME, 17) ! 124: GO TO 190 ! 125: 220 CALL SATT1(K, 8, 2) ! 126: 230 IF (L/8.EQ.1) GO TO 280 ! 127: L = MOD(L,8) ! 128: C ! 129: C COMPARE TYPES OF RHS AND LHS ! 130: C ! 131: IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR. ! 132: * (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190 ! 133: IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL ! 134: * ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38) ! 135: GO TO 190 ! 136: C ! 137: C PROCESSING FOR ASSIGNMENT STMT ! 138: C ! 139: 240 I = IGATT1(K,8) ! 140: IF (I.NE.0) GO TO 250 ! 141: I = 10 ! 142: CALL SATT1(K, 8, 10) ! 143: 250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260 ! 144: CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31) ! 145: GO TO 190 ! 146: 260 CALL SATT1(K, 5, 1) ! 147: IF (STMT(K2).EQ.65) GO TO 270 ! 148: IF (DOVAR(K)) CALL ERROR1( ! 149: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, ! 150: * 57) ! 151: PSTMT = K2 ! 152: GO TO 210 ! 153: 270 PSTMT = K2 + 1 ! 154: IF (PSTMT.GE.NSTMT) GO TO 180 ! 155: CALL SUBS(I, I2) ! 156: C ! 157: C PEEL SUBSCRIPTS OFF ! 158: C ! 159: IF (SYSERR .OR. ERR) GO TO 190 ! 160: PSTMT = I ! 161: GO TO 210 ! 162: 280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30) ! 163: GO TO 190 ! 164: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.