# To unbundle, sh this file echo ARDECL.f 1>&2 sed 's/.//' >ARDECL.f <<'//GO.SYSIN DD ARDECL.f' - LOGICAL FUNCTION ARDECL(K2, KK) -C -C K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT -C KK IS SYMBOL TABLE INDEX FOR THIS ARRAY -C PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS. -C CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE. -C ENTERS INTO SYMBOL TABLE AND TYPES ID; SETS USAGE ON ARRAY -C DECLARATOR -C CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS -C VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS. -C ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES -C IT OFF ARRAY SYMBOL TABLE ENTRY. -1 LENGTH INDICATES VARIABLE -C DIMENSION -C CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT. -C -C ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS -C FALSE FOR ARRAYS AND VARIABLES -C CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV. -C STMT ; IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS -C NEGATIVE. -C - LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH - INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA - COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) - COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT - COMMON /CTABL/ LDSA, PDSA, DSA(5000) - COMMON /FACTS/ NAME, NOST, ITYP, IASF - COMMON /DETECT/ ERR, SYSERR, ABORT - ERR = .FALSE. - FLUSH = .FALSE. - ARRY = .FALSE. - CORNER = .TRUE. - ARDECL = .FALSE. -C -C CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR; -C CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO -C ARRY=.TRUE. -C - ICNT = 0 - CALL NEXTOK(PSTMT, K2, I1) - IF (I1.EQ.0) GO TO 10 - CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) - ERR = .TRUE. - GO TO 280 - 10 IF (STMT(K2).EQ.65) ARRY = .TRUE. - KK = LOOKUP(K2,.FALSE.) - IF (SYSERR) GO TO 70 - ARDECL = .TRUE. - L = IGATT1(KK,8) - IF (L.EQ.0 .OR. L.EQ.10) GO TO 30 - IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30 - 20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45) - ERR = .TRUE. - GO TO 280 -C -C SET TYPE (EXPLICITLY FOR TYPE STMTS) -C - 30 I1 = IGATT1(KK,1) - IF (ITYP.GE.6) GO TO 50 -C -C TYPE EXPLICITLY -C - IF (I1.GE.8) GO TO 40 - CALL SATT1(KK, 1, ITYP+7) - GO TO 60 - 40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34) - GO TO 60 -C -C TYPE IMPLICITLY -C - 50 IF (I1.GT.0) GO TO 60 - I1 = 1 - IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 - CALL SATT1(KK, 1, I1) -C -C IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE -C -C CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT -C - 60 IF (ARRY) GO TO 80 - IF (IGATT1(KK,7).EQ.0) GO TO 65 - IF (ITYP.EQ.12) - 1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE - 2 , 46) - IF (ITYP.EQ.13) - 1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39) - 65 CONTINUE - I1 = IGATT1(KK,4) - IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR. - * ITYP.EQ.13))) GO TO 70 - ERR = .TRUE. - CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32) - 70 RETURN - 80 ISIZ = 1 - VAR = .FALSE. - IF (L.EQ.0) CALL SATT1(KK, 8, 10) -C -C LOOP TO FIND BOUNDS; CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS -C SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT -C ALREADY SET -C ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT. -C CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS -C - L = IGATT1(KK,7) - IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90 - IF (L.EQ.0) GO TO 100 - CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44) - ERR = .TRUE. - GO TO 270 - 90 IF (L.EQ.0) CALL ERROR1( - * 44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44) - 100 IF (K2+1.LT.NSTMT) GO TO 120 - 110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28) - GO TO 270 -C -C CHECK FOR POSITIVE INTEGER BOUND -C - 120 PSTMT = K2 + 1 - IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130 - IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL - IF (ITYP.NE.12) GO TO 170 - IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE. - GO TO 170 -C -C SEEK A VARIABLE BOUND -C - 130 CALL NEXTOK(PSTMT, I1, L) - IF (L.NE.0) GO TO 110 - IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140 - CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32) - ERR = .TRUE. - GO TO 270 - 140 VAR = .TRUE. - L = LOOKUP(I1,.FALSE.) - IF (SYSERR) GO TO 70 - N = IGATT1(L,8) - IF (N.NE.0 .AND. N.NE.10) GO TO 20 - I2 = IGATT1(L,4) - IF (I2.EQ.1) GO TO 150 - CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42) - ERR = .TRUE. - GO TO 270 - 150 I2 = IGATT1(KK,4) - IF (I2.EQ.1) GO TO 160 - CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT, - * 50) - ERR = .TRUE. - GO TO 270 - 160 CALL SATT1(L, 6, 1) - CALL SATT1(L, 8, 10) - N = IGATT1(L,1) - IF (N.GT.0) GO TO 170 - N = 1 - IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2 - CALL SATT1(L, 1, N) - GO TO 170 -C -C FIND "," AND ACCUMULATE LENGTH -C - 170 ICNT = ICNT + 1 - IF (ICNT.LE.3) GO TO 180 - ISIZ = ISIZ/LL - CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30) - ICNT = 3 - FLUSH = .TRUE. - GO TO 190 - 180 K2 = I1 - IF (STMT(K2).EQ.68) GO TO 100 -C -C FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT -C - IF (STMT(K2).NE.62) GO TO 110 - 190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260 - CALL SATT1(KK, 7, ICNT) -C -C STORE LENGTH OF ARRAY -C - IF (VAR) GO TO 240 - IF (DSA(KK+2).EQ.0) GO TO 200 - N = DSA(KK+2) - DSA(N) = ISIZ - GO TO 220 - 200 IF (NEXT+2.GE.BNEXT) GO TO 210 - DSA(KK+2) = NEXT - DSA(NEXT) = ISIZ - DSA(NEXT+1) = 0 - NEXT = NEXT + 2 - GO TO 220 - 210 SYSERR = .TRUE. - CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33) - 220 IF (FLUSH) GO TO 270 - 230 K2 = K2 + 1 - GO TO 70 -C -C FIXUP FOR VARIABLY DIMENSIONED ARRAYS -C - 240 IF (DSA(KK+2).EQ.0) GO TO 250 - N = DSA(KK+2) - DSA(N) = -1 - GO TO 220 - 250 IF (NEXT+2.GE.BNEXT) GO TO 210 - DSA(KK+2) = NEXT - DSA(NEXT) = -1 - DSA(NEXT+1) = 0 - NEXT = NEXT + 2 - GO TO 220 -C -C CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT -C - 260 IF (ITYP.NE.12) GO TO 220 - IF (CORNER) KK = -KK - GO TO 220 -C -C CODE TO FLUSH CONSTRUCT--TO NEXT ")" -C - 270 IF (K2.EQ.NSTMT) GO TO 70 - IF (STMT(K2).EQ.62) GO TO 230 - K2 = K2 + 1 - GO TO 270 -C -C CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/" -C - 280 K = 90 - IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67 - 290 IF (K2.EQ.NSTMT) GO TO 70 - L = STMT(K2) - IF (L.EQ.65) GO TO 270 - IF (L.EQ.68 .OR. L.EQ.K) GO TO 70 - K2 = K2 + 1 - GO TO 290 - END //GO.SYSIN DD ARDECL.f echo ASLEV.f 1>&2 sed 's/.//' >ASLEV.f <<'//GO.SYSIN DD ASLEV.f' - SUBROUTINE ASLEV(IPT) -C -C ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT))) -C AND READJUSTS THE LEVELS IN THE SUBLATTICE -C IN ACCORDANCE WITH NEW LEVEL AT ROOT -C NOTE, IPT LT 0 FROM CALL IN SETREF (EXT) AND FROM ACTUALS -C PASSED DOWN IN PROC -C - INTEGER PNODE, STACK, PLAT, FIND, SYMLEN - INTEGER ZERO(1) - LOGICAL SYSERR, ERR, ABORT, GR - COMMON /DETECT/ ERR, SYSERR, ABORT - COMMON /HEAD/ LNODE, PNODE, NODE(500) - COMMON /SCR1/ LINODE, INODE(500) - COMMON /SCR2/ LSTACK, STACK(500) - COMMON /GRAPH/ LLAT, PLAT, LAT(6000) - COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 - DATA ZERO(1) /0/ -C -C STACK (IS) IS SIGNED NODE INDEX OF SUBPGM -C IF GT 0, NODE IS ALONG A RED LINK TO PARENT -C IF LT 0, NODE IS ALONG A GREEN LINK TO PARENT -C -C STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS -C SUBPGM, OR 0 FOR END OF DESC LIST -C - K = IABS (IPT ) - K = SYMLEN + NODE(K) + 4 - STACK(2) = IPT - STACK (1) = IABS ( LAT(K) ) - IS = 2 -C DOES TOP OF STACK ENTRY HAVE UNVISITED DESC - 10 IF (STACK(IS-1).NE.0) GO TO 20 -C TEST IF ARE DONE WITH SUBLATTICE - IF (IS.EQ.2) RETURN -C POP UP A LEVEL IN PATH - IS = IS - 2 - GO TO 10 -C UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK - 20 K = STACK(IS-1) - STACK(IS-1) = IABS (LAT(K+1)) -C LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED -C SIGN INDICATES COLOR OF LINK TO PARENT, (I.E. -C NODE AT TOP OF STACK) -C LT 0 IS GREEN LINK, GT 0 IS RED LINK -C L IS INDEX IN NODE(*) OF DESC BEING PROCESSED -C KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED - LL = 1 - IF( LAT(K) .LT. 0) LL = -1 - KK = IABS(LAT(K)) - L = FIND(KK) -C SKIP ALL DESC WITH NEGATIVE LEVELS - IF (INODE(L).LT.0) GO TO 10 -C SEE IF STACK TOO SHORT FOR LOOPS - IF( IS.LE.2) GOTO 40 -C CHECK FOR LOOPS IN PATH STACK DESC - LOOP = 0 - GR = .FALSE. - IF(LL.EQ.(-1)) GR = .TRUE. - DO 60 I = 2,IS,2 - IF(LOOP) 70,70,90 - 90 IF(STACK(I).LT.0) GR = .TRUE. - GOTO 60 - 70 IF(L.EQ.IABS(STACK(I))) LOOP = I - 60 CONTINUE -C NO LOOPS - IF(LOOP.EQ.0) GOTO 40 -C LOOP OF MIXED COLORED LINKS -C DO NOT STACK DESC - IF(GR) GOTO 10 -C RECURSION - ABORT = .TRUE. - CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0) - DO 80 K=LOOP,IS,2 - KK = IABS(STACK(K)) - KK = NODE(KK) - 80 CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0) - CALL ERROR2(1H1, 0, ZERO, -3, 0, 1) - 30 RETURN -C TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR -C THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC - 40 K = IABS (STACK(IS)) - IF (INODE(L).GT.INODE(K)) GO TO 10 -C PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL - INODE(L) = INODE(K) + 1 -C TEST AGAINST LNODE BECAUSE SCRATCH ARRAY -C IS AS LONG AS NODE ARRAY - IF (IS+2.GT.LNODE) GO TO 50 - STACK(IS+2) = LL * L - K = NODE(L) + SYMLEN + 4 - STACK(IS+1) = IABS( LAT(K)) - IS = IS + 2 - GO TO 10 - 50 SYSERR = .TRUE. - CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43) - GO TO 30 - END //GO.SYSIN DD ASLEV.f echo ASSASF.f 1>&2 sed 's/.//' >ASSASF.f <<'//GO.SYSIN DD ASSASF.f' - 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 //GO.SYSIN DD ASSASF.f echo ASSIGN.f 1>&2 sed 's/.//' >ASSIGN.f <<'//GO.SYSIN DD ASSIGN.f' - SUBROUTINE ASSIGN - INTEGER PSTMT, STMT - LOGICAL TOKLAB, ERR, SYSERR, ABORT - COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) - COMMON /DETECT/ ERR, SYSERR, ABORT -C -C PROCESSES AN ASSIGN STMT: ASSIGN