![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to END.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 END.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE END ! 2: C ! 3: C ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS ! 4: C CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S ! 5: C CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING; ! 6: C CHECKS SUCH BOUNDS FOR TYPE INTEGER ! 7: C CALLS OUTSYM TO PRINT SYMBOL TABLE ! 8: C CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS, ! 9: C PROPER BRANCHING THROUGHOUT PGM, ! 10: C FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED ! 11: C SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET ! 12: C RESETS FCN USAGE IN FCN SUBPROGRAM ! 13: C ! 14: INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4 ! 15: INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA ! 16: LOGICAL OPT, P1ERR ! 17: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 18: * OUTUT4 ! 19: COMMON /OPTNS/ OPT(5), P1ERR ! 20: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 21: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 22: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 23: COMMON /CEXPRS/ LSTACK, STACK(620) ! 24: I = IGATT1(NAME,8) ! 25: IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40 ! 26: C ! 27: C ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS ! 28: C ! 29: LL = 1 ! 30: L = DSA(NAME+2) ! 31: NPAR = 0 ! 32: 10 IF (L.EQ.0) GO TO 40 ! 33: NPAR = NPAR + 1 ! 34: C CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT ! 35: C IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY ! 36: I = IGATT1(DSA(L),8) ! 37: IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20 ! 38: I = DSA(L) ! 39: DSA(I+2) = NPAR ! 40: GO TO 30 ! 41: 20 I = IGATT1(DSA(L),6) ! 42: IF (I.EQ.0) GO TO 30 ! 43: I = IGATT1(DSA(L),7) ! 44: IF (I.NE.0) GO TO 30 ! 45: I = IGATT1(DSA(L),5) ! 46: K = DSA(L) ! 47: IF (I.GT.0) CALL ERROR2( ! 48: * 57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING , ! 49: * 57, DSA(K+4), 1, 1, 1) ! 50: I = IGATT1(K,1) ! 51: IF (MOD(I,8).NE.2) CALL ERROR2( ! 52: * 47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47 ! 53: * , DSA(K+4), 1, 1, 1) ! 54: 30 L = DSA(L+1) ! 55: GO TO 10 ! 56: C ! 57: C OUTPUT TABLE ! 58: C ! 59: 40 CALL DOCHK(1) ! 60: C ! 61: C CHECK LABELS DEFINED AND WITHIN SCOPE ! 62: C ! 63: I = LABHD ! 64: 50 IF (I.EQ.0) GO TO 110 ! 65: L = IGATT1(I,2) ! 66: IF (L.EQ.1) GO TO 60 ! 67: CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1) ! 68: GO TO 100 ! 69: 60 L = IGATT1(I,1) ! 70: IF (L.NE.1) GO TO 100 ! 71: L = DSA(I+2) ! 72: L1 = DSA(L) ! 73: KK = DSA(L+1) ! 74: L2 = DSA(I+1) ! 75: C ! 76: C L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST ! 77: C ! 78: L3 = L2 ! 79: 70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90 ! 80: IF (DSA(L2).LT.0) GO TO 80 ! 81: CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1) ! 82: GO TO 90 ! 83: 80 DSA(L2) = IABS(DSA(L2)) ! 84: 90 L2 = DSA(L2+1) ! 85: IF (L2.NE.L3) GO TO 70 ! 86: 100 I = DSA(I+3) ! 87: GO TO 50 ! 88: C ! 89: C SET <ID> USAGE IF NOT YET SET ! 90: C ! 91: 110 I = SYMHD ! 92: 120 IF (I.EQ.0) GO TO 150 ! 93: K = IGATT1(I,8) ! 94: IF (K.NE.0) GO TO 130 ! 95: CALL SATT1(I, 8, 10) ! 96: GO TO 140 ! 97: 130 IF (K.NE.6) GO TO 140 ! 98: IF (IGATT1(I,1)/8.NE.1) GO TO 140 ! 99: CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4), ! 100: * 1, 1, 1) ! 101: 140 I = DSA(I+3) ! 102: GO TO 120 ! 103: C ! 104: C RESET FCN USAGE IN FCN PROGRAM UNIT ! 105: C ! 106: 150 I = IGATT1(NAME,8) ! 107: IF (I.NE.10) GO TO 160 ! 108: CALL SATT1(NAME, 8, 4) ! 109: I = IGATT1(NAME,5) ! 110: IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23) ! 111: C ! 112: C SAVE BINARY COPY OF SYMBOL TABLE ! 113: C ! 114: 160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170 ! 115: CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36) ! 116: K = 3 ! 117: L = 1 ! 118: WRITE(OUTUT2) L,K,L ! 119: WRITE(OUTUT3) L,K,L ! 120: GOTO 180 ! 121: 170 K = 1 ! 122: L = NEXT - 1 ! 123: I = L + 3 ! 124: WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD ! 125: L = 3 ! 126: WRITE (OUTUT3) K, L, K ! 127: 180 CALL OUTSYM ! 128: RETURN ! 129: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.