Commit | Line | Data |
---|---|---|
dc5f2268 KB |
1 | /*- |
2 | * Copyright (c) 1980 The Regents of the University of California. | |
3 | * All rights reserved. | |
4 | * | |
5 | * %sccs.include.proprietary.c% | |
099b7138 KM |
6 | */ |
7 | ||
8 | #ifndef lint | |
dc5f2268 KB |
9 | static char sccsid[] = "@(#)equiv.c 5.3 (Berkeley) %G%"; |
10 | #endif /* not lint */ | |
099b7138 KM |
11 | |
12 | /* | |
13 | * equiv.c | |
14 | * | |
15 | * Routines related to equivalence class processing, f77 compiler, 4.2 BSD. | |
16 | * | |
17 | * University of Utah CS Dept modification history: | |
18 | * | |
19 | * Revision 3.2 85/01/14 00:14:12 donn | |
20 | * Fixed bug in eqvcommon that was causing the calculations of multilevel | |
21 | * equivalences to be screwed up. | |
22 | * | |
23 | * Revision 3.1 84/10/13 01:16:08 donn | |
24 | * Installed Jerry Berkman's version; added UofU comment header. | |
25 | * | |
26 | */ | |
27 | ||
28 | ||
29 | #include "defs.h" | |
30 | ||
31 | #ifdef SDB | |
32 | # include <a.out.h> | |
33 | # ifndef N_SO | |
34 | # include <stab.h> | |
35 | # endif | |
36 | #endif | |
37 | ||
38 | /* called at end of declarations section to process chains | |
39 | created by EQUIVALENCE statements | |
40 | */ | |
41 | ||
42 | doequiv() | |
43 | { | |
44 | register int i; | |
45 | int inequiv, comno, ovarno; | |
46 | ftnint comoffset, offset, leng; | |
47 | register struct Equivblock *p; | |
48 | register struct Eqvchain *q; | |
49 | struct Primblock *itemp; | |
50 | register Namep np; | |
51 | expptr offp, suboffset(); | |
52 | int ns, nsubs(); | |
53 | chainp cp; | |
54 | char *memname(); | |
55 | int doeqverr = 0; | |
56 | ||
57 | for(i = 0 ; i < nequiv ; ++i) | |
58 | { | |
59 | p = &eqvclass[i]; | |
60 | p->eqvbottom = p->eqvtop = 0; | |
61 | comno = -1; | |
62 | ||
63 | for(q = p->equivs ; q ; q = q->eqvnextp) | |
64 | { | |
65 | offset = 0; | |
66 | itemp = q->eqvitem.eqvlhs; | |
67 | if( itemp == NULL ) fatal("error processing equivalence"); | |
68 | equivdcl = YES; | |
69 | vardcl(np = itemp->namep); | |
70 | equivdcl = NO; | |
71 | if(itemp->argsp || itemp->fcharp) | |
72 | { | |
73 | if(np->vdim!=NULL && np->vdim->ndim>1 && | |
74 | nsubs(itemp->argsp)==1 ) | |
75 | { | |
76 | if(! ftn66flag) | |
77 | warn("1-dim subscript in EQUIVALENCE"); | |
78 | cp = NULL; | |
79 | ns = np->vdim->ndim; | |
80 | while(--ns > 0) | |
81 | cp = mkchain( ICON(1), cp); | |
82 | itemp->argsp->listp->nextp = cp; | |
83 | } | |
84 | ||
85 | offp = suboffset(itemp); | |
86 | if(ISICON(offp)) | |
9868d2fe | 87 | offset = offp->constblock.constant.ci; |
099b7138 KM |
88 | else { |
89 | dclerr("illegal subscript in equivalence ", | |
90 | np); | |
91 | np = NULL; | |
92 | doeqverr = 1; | |
93 | } | |
94 | frexpr(offp); | |
95 | } | |
96 | frexpr(itemp); | |
97 | ||
98 | if(np && (leng = iarrlen(np))<0) | |
99 | { | |
100 | dclerr("argument in equivalence", np); | |
101 | np = NULL; | |
102 | doeqverr =1; | |
103 | } | |
104 | ||
105 | if(np) switch(np->vstg) | |
106 | { | |
107 | case STGUNKNOWN: | |
108 | case STGBSS: | |
109 | case STGEQUIV: | |
110 | break; | |
111 | ||
112 | case STGCOMMON: | |
113 | comno = np->vardesc.varno; | |
114 | comoffset = np->voffset + offset; | |
115 | break; | |
116 | ||
117 | default: | |
118 | dclerr("bad storage class in equivalence", np); | |
119 | np = NULL; | |
120 | doeqverr = 1; | |
121 | break; | |
122 | } | |
123 | ||
124 | if(np) | |
125 | { | |
126 | q->eqvoffset = offset; | |
127 | p->eqvbottom = lmin(p->eqvbottom, -offset); | |
128 | p->eqvtop = lmax(p->eqvtop, leng-offset); | |
129 | } | |
130 | q->eqvitem.eqvname = np; | |
131 | } | |
132 | ||
133 | if(comno >= 0) | |
134 | eqvcommon(p, comno, comoffset); | |
135 | else for(q = p->equivs ; q ; q = q->eqvnextp) | |
136 | { | |
137 | if(np = q->eqvitem.eqvname) | |
138 | { | |
139 | inequiv = NO; | |
140 | if(np->vstg==STGEQUIV) | |
141 | if( (ovarno = np->vardesc.varno) == i) | |
142 | { | |
143 | if(np->voffset + q->eqvoffset != 0) | |
144 | dclerr("inconsistent equivalence", np); | |
145 | doeqverr = 1; | |
146 | } | |
147 | else { | |
148 | offset = np->voffset; | |
149 | inequiv = YES; | |
150 | } | |
151 | ||
152 | np->vstg = STGEQUIV; | |
153 | np->vardesc.varno = i; | |
154 | np->voffset = - q->eqvoffset; | |
155 | ||
156 | if(inequiv) | |
157 | eqveqv(i, ovarno, q->eqvoffset + offset); | |
158 | } | |
159 | } | |
160 | } | |
161 | ||
162 | if( !doeqverr ) | |
163 | for(i = 0 ; i < nequiv ; ++i) | |
164 | { | |
165 | p = & eqvclass[i]; | |
166 | if(p->eqvbottom!=0 || p->eqvtop!=0) /* a live chain */ | |
167 | { | |
168 | for(q = p->equivs ; q; q = q->eqvnextp) | |
169 | { | |
170 | np = q->eqvitem.eqvname; | |
171 | np->voffset -= p->eqvbottom; | |
172 | if(np->voffset % typealign[np->vtype] != 0) | |
173 | dclerr("bad alignment forced by equivalence", np); | |
174 | } | |
175 | p->eqvtop -= p->eqvbottom; | |
176 | p->eqvbottom = 0; | |
177 | } | |
178 | freqchain(p); | |
179 | } | |
180 | } | |
181 | ||
182 | ||
183 | ||
184 | ||
185 | ||
186 | /* put equivalence chain p at common block comno + comoffset */ | |
187 | ||
188 | LOCAL eqvcommon(p, comno, comoffset) | |
189 | struct Equivblock *p; | |
190 | int comno; | |
191 | ftnint comoffset; | |
192 | { | |
193 | int ovarno; | |
194 | ftnint k, offq; | |
195 | register Namep np; | |
196 | register struct Eqvchain *q; | |
197 | ||
198 | if(comoffset + p->eqvbottom < 0) | |
199 | { | |
200 | errstr("attempt to extend common %s backward", | |
201 | nounder(XL, extsymtab[comno].extname) ); | |
202 | freqchain(p); | |
203 | return; | |
204 | } | |
205 | ||
206 | if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) | |
207 | extsymtab[comno].extleng = k; | |
208 | ||
209 | #ifdef SDB | |
210 | if(sdbflag) | |
211 | prstab( varstr(XL,extsymtab[comno].extname), N_BCOMM,0,0); | |
212 | #endif | |
213 | ||
214 | for(q = p->equivs ; q ; q = q->eqvnextp) | |
215 | if(np = q->eqvitem.eqvname) | |
216 | { | |
217 | switch(np->vstg) | |
218 | { | |
219 | case STGUNKNOWN: | |
220 | case STGBSS: | |
221 | np->vstg = STGCOMMON; | |
222 | np->vardesc.varno = comno; | |
223 | np->voffset = comoffset - q->eqvoffset; | |
224 | #ifdef SDB | |
225 | if(sdbflag) | |
226 | { | |
227 | namestab(np); | |
228 | } | |
229 | #endif | |
230 | break; | |
231 | ||
232 | case STGEQUIV: | |
233 | ovarno = np->vardesc.varno; | |
234 | offq = comoffset - q->eqvoffset - np->voffset; | |
235 | np->vstg = STGCOMMON; | |
236 | np->vardesc.varno = comno; | |
237 | np->voffset = comoffset + q->eqvoffset; | |
238 | if(ovarno != (p - eqvclass)) | |
239 | eqvcommon(&eqvclass[ovarno], comno, offq); | |
240 | #ifdef SDB | |
241 | if(sdbflag) | |
242 | { | |
243 | namestab(np); | |
244 | } | |
245 | #endif | |
246 | break; | |
247 | ||
248 | case STGCOMMON: | |
249 | if(comno != np->vardesc.varno || | |
250 | comoffset != np->voffset+q->eqvoffset) | |
251 | dclerr("inconsistent common usage", np); | |
252 | break; | |
253 | ||
254 | ||
255 | default: | |
256 | badstg("eqvcommon", np->vstg); | |
257 | } | |
258 | } | |
259 | ||
260 | #ifdef SDB | |
261 | if(sdbflag) | |
262 | prstab( varstr(XL,extsymtab[comno].extname), N_ECOMM,0,0); | |
263 | #endif | |
264 | ||
265 | freqchain(p); | |
266 | p->eqvbottom = p->eqvtop = 0; | |
267 | } | |
268 | ||
269 | ||
270 | /* put all items on ovarno chain on front of nvarno chain | |
271 | * adjust offsets of ovarno elements and top and bottom of nvarno chain | |
272 | */ | |
273 | ||
274 | LOCAL eqveqv(nvarno, ovarno, delta) | |
275 | int ovarno, nvarno; | |
276 | ftnint delta; | |
277 | { | |
278 | register struct Equivblock *p0, *p; | |
279 | register Namep np; | |
280 | struct Eqvchain *q, *q1; | |
281 | ||
282 | p0 = eqvclass + nvarno; | |
283 | p = eqvclass + ovarno; | |
284 | p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta); | |
285 | p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta); | |
286 | p->eqvbottom = p->eqvtop = 0; | |
287 | ||
288 | for(q = p->equivs ; q ; q = q1) | |
289 | { | |
290 | q1 = q->eqvnextp; | |
291 | if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) | |
292 | { | |
293 | q->eqvnextp = p0->equivs; | |
294 | p0->equivs = q; | |
295 | q->eqvoffset -= delta; | |
296 | np->vardesc.varno = nvarno; | |
297 | np->voffset -= delta; | |
298 | } | |
299 | else free( (charptr) q); | |
300 | } | |
301 | p->equivs = NULL; | |
302 | } | |
303 | ||
304 | ||
305 | ||
306 | ||
307 | LOCAL freqchain(p) | |
308 | register struct Equivblock *p; | |
309 | { | |
310 | register struct Eqvchain *q, *oq; | |
311 | ||
312 | for(q = p->equivs ; q ; q = oq) | |
313 | { | |
314 | oq = q->eqvnextp; | |
315 | free( (charptr) q); | |
316 | } | |
317 | p->equivs = NULL; | |
318 | } | |
319 | ||
320 | ||
321 | ||
322 | ||
323 | ||
324 | LOCAL nsubs(p) | |
325 | register struct Listblock *p; | |
326 | { | |
327 | register int n; | |
328 | register chainp q; | |
329 | ||
330 | n = 0; | |
331 | if(p) | |
332 | for(q = p->listp ; q ; q = q->nextp) | |
333 | ++n; | |
334 | ||
335 | return(n); | |
336 | } |