![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to LOOKUP.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 LOOKUP.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: INTEGER FUNCTION LOOKUP(K1, LABEL)
2: C
3: C STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
4: C LABEL IS TRUE IF SYMBOL IS A LABEL. ROUTINE
5: C RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
6: C A NEW ENTRY ID NESESSARY. IT ENTERS SYMBOL INTO
7: C SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
8: C ENTRY FOR THE CURRENT STATMT NUMBER
9: C
10: INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
11: INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
12: INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
13: LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
14: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
15: * OUTUT4
16: COMMON /DETECT/ ERR, SYSERR, ABORT
17: COMMON /FACTS/ NAME, NOST, ITYP, IASF
18: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
19: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
20: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
21: COMMON /CHASH/ LHASH, HASH(401)
22: COMMON /TRANS/ Q
23: COMMON /OPTNS/ OPT(5), P1ERR
24: DATA BLANK /1H /
25: K = K1 - PSTMT
26: IF (K.LE.6) GO TO 10
27: CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
28: K = 6
29: 10 KK = K
30: DO 20 I=1,K
31: II = PSTMT + I - 1
32: J = STMT(II) + 1
33: LL(I) = Q(J)
34: 20 CONTINUE
35: DO 30 I=1,SYMLEN
36: L(I) = BLANK
37: 30 CONTINUE
38: CALL S5PACK(LL, L, K)
39: C
40: C HAVE PACKED SYMBOL;NOW CALCULATE HASH
41: C HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
42: C
43: IF (KK.LT.3) GO TO 50
44: IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
45: 40 IHASHS = MOD(IHASHS,LHASH)
46: ISAVE = IHASHS
47: IHASH = IHASHS + 1
48: GO TO 80
49: 50 IHASHS = STMT(PSTMT)
50: GO TO (60, 70), KK
51: 60 IHASHS = IHASHS*69 + 69
52: GO TO 40
53: 70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
54: GO TO 40
55: 80 IF (HASH(IHASH).EQ.0) GO TO 140
56: C
57: C IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
58: C ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
59: C TABLE AFTER RESOLVING COLLISION
60: C
61: DO 90 J=1,SYMLEN
62: II = HASH(IHASH) + 3 + J
63: IF (L(J).NE.DSA(II)) GO TO 100
64: 90 CONTINUE
65: LOOKUP = HASH(IHASH)
66: IF (DSA(LOOKUP+1)) 190, 190, 200
67: C
68: C RESOLVE CONFLICTS BY LINEAR CONGRUENCE
69: C
70: 100 IHASHS = MOD(IHASHS+1,LHASH)
71: IF (IHASHS.EQ.ISAVE) GO TO 110
72: IHASH = IHASHS + 1
73: GO TO 80
74: 110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
75: 120 SYSERR = .TRUE.
76: RETURN
77: 130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
78: GO TO 120
79: C
80: C CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
81: C
82: 140 HASH(IHASH) = NEXT
83: IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
84: LOOKUP = NEXT
85: C
86: C*****DSA
87: C 1ST WORD..... ATTRIBUTE WORD
88: C FIELD 1
89: C
90: C BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
91: C 3 COMPLEX,4 LOGICAL, 5 HOLLERITH
92: C TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
93: C 3 FORMAT STMT
94: C BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
95: C FIELD 2
96: C BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
97: C (FOR LABEL) DEFINED 1, REFERENCED 0
98: C (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
99: C FIELD 3
100: C BIT 5****EQUIVALENCED 1
101: C FIELD 4
102: C BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
103: C FIELD 5
104: C BIT 7****VALUE SET BY P.U. 1
105: C FIELD 6
106: C BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
107: C FIELD 7
108: C BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
109: C FIELD 8
110: C BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
111: C SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
112: C COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
113: C CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
114: C 13, INTRINSIC FCN 14
115: C BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
116: C ATTRIBUTE MENTIONED
117: C
118: C 2ND WD..... XREF LIST TAIL POINTER
119: C 3D WORD.....EXTRA INFO POINTER
120: C
121: C FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
122: C CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
123: C DIMENSIONED ARRAY); SECOND WORD CONTAINING INDEX OF COMMON
124: C ENTRY IN DSA;
125: C FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
126: C LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
127: C IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
128: C NESTING LEVEL; WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
129: C ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
130: C OF LAST STMT AT THAT NESTING LEVEL;
131: C FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
132: C OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
133: C FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
134: C A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
135: C DUMMIES OF THAT SUBPGM;
136: C
137: C 4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
138: C OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
139: C 5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
140: C
141: J = NEXT + 2
142: DO 150 I=NEXT,J
143: DSA(I) = 0
144: 150 CONTINUE
145: J = J + 1
146: DO 160 I=1,SYMLEN
147: II = I + J
148: DSA(II) = L(I)
149: 160 CONTINUE
150: C
151: C SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
152: C
153: IF (LABEL) GO TO 170
154: DSA(J) = SYMHD
155: SYMHD = NEXT
156: GO TO 180
157: 170 DSA(J) = LABHD
158: LABHD = NEXT
159: 180 NEXT = 4 + SYMLEN + NEXT
160: C
161: C BEGINNEW XREF LIST
162: C
163: 190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
164: IF (NEXT+2.GE.BNEXT) GO TO 130
165: DSA(BNEXT-1) = NOST
166: DSA(LOOKUP+1) = BNEXT - 1
167: DSA(BNEXT) = BNEXT - 1
168: BNEXT = BNEXT - 2
169: GO TO 210
170: C
171: C XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
172: C THERE
173: C
174: 200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
175: IF (NEXT+2.GE.BNEXT) GO TO 130
176: J = DSA(LOOKUP+1)
177: IF (DSA(J).EQ.NOST) GO TO 210
178: DSA(BNEXT) = DSA(J+1)
179: DSA(J+1) = BNEXT - 1
180: DSA(LOOKUP+1) = BNEXT - 1
181: DSA(BNEXT-1) = NOST
182: BNEXT = BNEXT - 2
183: 210 RETURN
184: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.