![[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.