![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to SETNOD.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 SETNOD.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE SETNOD ! 2: INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM, ! 3: * SETARG, FINDND, FINDCM ! 4: LOGICAL ERR, SYSERR, ABORT ! 5: COMMON /COMS/ LCOM, PCOM, COM(300) ! 6: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 8: COMMON /DETECT/ ERR, SYSERR, ABORT ! 9: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 10: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 11: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 12: COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT ! 13: COMMON /SCR1/ LINODE, INODE(500) ! 14: C ! 15: C LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES ! 16: C PLAT-IS NEXT FREE WORD IN LAT ! 17: C LLAT-IS LENGTH OF LAT ! 18: C NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT ! 19: C (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES) ! 20: C PNODE-IS NEXT FREE WORD IN NODE ! 21: C LNODE-IS LENGTH OF NODE ! 22: C ! 23: C P.U. NODE IN LAT ! 24: C WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM ! 25: C WD2.....NUMBER OF ARGS ! 26: C WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF ! 27: C ARGUMENT NODES IN LAT ! 28: C WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES ! 29: C IN LAT ! 30: C WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN ! 31: C LAT OF ENTRIES FOR PARENT NODES ! 32: C WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN ! 33: C LAT OF ENTRIES FOR DESCENDENT NODES ! 34: C WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF ! 35: C BAD REFERENCES; INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR ! 36: C NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE ! 37: C TYPES OF BAD REFS ! 38: C WD8.....BITS 0-2 TYPE OF SUBPGM: 0 SUBR, 1 FCN, 2 BLOCK DATA, ! 39: C 3 MAIN, 4 ASF, 5 SUPEROOT ! 40: C BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL, ! 41: C 2 INT, 3 COMP, 4 LOG ! 42: C ! 43: C ARGUMENT NODE IN LAT ! 44: C WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP) ! 45: C WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO ! 46: C HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED ! 47: C WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF ! 48: C SUBPRGM IN WHICH THE ASSOC OCCURS ! 49: C WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS ! 50: C (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG) ! 51: C WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS ! 52: C (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH) ! 53: C WD 5.....PTR TO NEXT ARG NODE OR 0 ! 54: C ! 55: C COMMON NODE IN LAT ! 56: C WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM ! 57: C WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0 ! 58: C WD 3.....PTR TO NEXT COMMON NODE ! 59: C CREATE NODE PTR TO NEW NODE IN LAT ! 60: C ! 61: IF (PNODE.GT.LNODE) GO TO 170 ! 62: IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190 ! 63: C ! 64: C CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM ! 65: C OR A COMMON BLOCK ! 66: C ! 67: II = IGATT1(NAME,8) ! 68: IF (II.EQ.11) GO TO 10 ! 69: IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20 ! 70: 10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30 ! 71: 20 ERR = .TRUE. ! 72: 30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45, ! 73: * DSA(NAME+4), 1, 1, 1) ! 74: IF (.NOT.ERR) GO TO 40 ! 75: ERR = .FALSE. ! 76: ABORT = .TRUE. ! 77: GO TO 160 ! 78: 40 NODE(PNODE) = PLAT ! 79: IROOT = PNODE ! 80: PNODE = PNODE + 1 ! 81: C ! 82: C ENTER NAME INTO NODE ! 83: C ! 84: DO 50 I=1,SYMLEN ! 85: L = NAME + 3 + I ! 86: LL = PLAT - 1 + I ! 87: LAT(LL) = DSA(L) ! 88: 50 CONTINUE ! 89: C ! 90: C PP POINTS TO CURRENT RTNE NODE IN LAT ! 91: C ! 92: PP = PLAT ! 93: PLAT = LL + 6 ! 94: LL = LL + 1 ! 95: DO 60 I=LL,PLAT ! 96: LAT(I) = 0 ! 97: 60 CONTINUE ! 98: C ! 99: C 0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT ! 100: C ! 101: LAT(PLAT+1) = II/4 ! 102: C INITIALIZE LEVEL OF BLOCK DATA TO -2 ! 103: IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2 ! 104: IF (LAT(PLAT+1).NE.1) GO TO 70 ! 105: L = IGATT1(NAME,1) ! 106: LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8) ! 107: 70 PLAT = PLAT + 2 ! 108: C ! 109: C HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS ! 110: C ! 111: IF (DSA(NAME+2)) 80, 90, 80 ! 112: 80 L = PP + SYMLEN ! 113: LAT(L) = SETARG(PP,NAME) ! 114: IF (SYSERR) GO TO 160 ! 115: C ! 116: C READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS ! 117: C AND SETTING OF COMMON REGION ! 118: C ! 119: 90 K = SYMHD ! 120: 100 IF (K) 110, 160, 110 ! 121: 110 LL = IGATT1(K,8) ! 122: C ! 123: C CHECK FOR ASF AND COMMON DEFNS OR COMMON ! 124: C SETTING INFO ! 125: C ! 126: GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140, ! 127: * 140, 140, 140), LL ! 128: C ! 129: C CREATE ASF NODE ! 130: C ! 131: 120 CALL SETASF(PP, K) ! 132: IF (SYSERR) GO TO 160 ! 133: GO TO 140 ! 134: C ! 135: C CREATE COM ENTRY ! 136: C ! 137: 130 CALL SETCOM(PP, K) ! 138: IF (SYSERR) GO TO 160 ! 139: 140 K = DSA(K+3) ! 140: GO TO 100 ! 141: C ! 142: C CHECK IF ELEMENT IN COMMON ! 143: C ! 144: 150 LL = IGATT1(K,2) ! 145: L = IGATT1(K,5) ! 146: IF (L.NE.1 .OR. LL.NE.1) GO TO 140 ! 147: L = DSA(K+2) ! 148: L = DSA(L+1) ! 149: CALL MKCOM(PP, L) ! 150: IF (SYSERR) GO TO 160 ! 151: GO TO 140 ! 152: 160 RETURN ! 153: 170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34) ! 154: 180 SYSERR = .TRUE. ! 155: GO TO 160 ! 156: 190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33) ! 157: GO TO 180 ! 158: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.