1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
26 LOCAL eqvcommon(), eqveqv(), nsubs();
28 /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
30 /* called at end of declarations section to process chains
31 created by EQUIVALENCE statements
36 int inequiv; /* True if one namep occurs in
37 several EQUIV declarations */
38 int comno; /* Index into Extsym table of the last
39 COMMON block seen (implicitly assuming
40 that only one will be given) */
42 ftnint comoffset; /* Index into the COMMON block */
43 ftnint offset; /* Offset from array base */
45 register struct Equivblock *equivdecl;
46 register struct Eqvchain *q;
47 struct Primblock *primp;
49 int k, k1, ns, pref, t;
51 extern int type_pref[];
53 for(i = 0 ; i < nequiv ; ++i)
56 /* Handle each equivalence declaration */
58 equivdecl = &eqvclass[i];
59 equivdecl->eqvbottom = equivdecl->eqvtop = 0;
64 for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
67 primp = q->eqvitem.eqvlhs;
68 vardcl(np = primp->namep);
69 if(primp->argsp || primp->fcharp)
71 expptr offp, suboffset();
73 /* Pad ones onto the end of an array declaration when needed */
75 if(np->vdim!=NULL && np->vdim->ndim>1 &&
76 nsubs(primp->argsp)==1 )
80 ("1-dim subscript in EQUIVALENCE, %d-dim declared",
85 cp = mkchain((char *)ICON(1), cp);
86 primp->argsp->listp->nextp = cp;
89 offp = suboffset(primp);
91 offset = offp->constblock.Const.ci;
94 ("nonconstant subscript in equivalence ",
101 /* Free up the primblock, since we now have a hash table (Namep) entry */
103 frexpr((expptr)primp);
105 if(np && (leng = iarrlen(np))<0)
107 dclerr("adjustable in equivalence", np);
111 if(np) switch(np->vstg)
120 /* The code assumes that all COMMON references in a given EQUIVALENCE will
121 be to the same COMMON block, and will all be consistent */
123 comno = np->vardesc.varno;
124 comoffset = np->voffset + offset;
128 dclerr("bad storage class in equivalence", np);
135 q->eqvoffset = offset;
137 /* eqvbottom gets the largest difference between the array base address
138 and the address specified in the EQUIV declaration */
140 equivdecl->eqvbottom =
141 lmin(equivdecl->eqvbottom, -offset);
143 /* eqvtop gets the largest difference between the end of the array and
144 the address given in the EQUIVALENCE */
147 lmax(equivdecl->eqvtop, leng-offset);
149 q->eqvitem.eqvname = np;
152 /* Now all equivalenced variables are in the hash table with the proper
153 offset, and eqvtop and eqvbottom are set. */
157 /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
160 eqvcommon(equivdecl, comno, comoffset);
161 else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
163 if(np = q->eqvitem.eqvname)
166 if(np->vstg==STGEQUIV)
167 if( (ovarno = np->vardesc.varno) == i)
170 /* Can't EQUIV different elements of the same array */
172 if(np->voffset + q->eqvoffset != 0)
174 ("inconsistent equivalence", np);
177 offset = np->voffset;
182 np->vardesc.varno = i;
183 np->voffset = - q->eqvoffset;
187 /* Combine 2 equivalence declarations */
189 eqveqv(i, ovarno, q->eqvoffset + offset);
194 /* Now each equivalence declaration is distinct (all connections have been
195 merged in eqveqv()), and some may be empty. */
197 for(i = 0 ; i < nequiv ; ++i)
199 equivdecl = & eqvclass[i];
200 if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
206 for(q = equivdecl->equivs ; q; q = q->eqvnextp)
208 np = q->eqvitem.eqvname;
209 np->voffset -= equivdecl->eqvbottom;
210 t = typealign[k1 = np->vtype];
211 if (pref < type_pref[k1]) {
213 pref = type_pref[k1];
215 if(np->voffset % t != 0)
216 dclerr("bad alignment forced by equivalence", np);
218 equivdecl->eqvtype = k;
220 freqchain(equivdecl);
228 /* put equivalence chain p at common block comno + comoffset */
230 LOCAL eqvcommon(p, comno, comoffset)
231 struct Equivblock *p;
238 register struct Eqvchain *q;
240 if(comoffset + p->eqvbottom < 0)
242 errstr("attempt to extend common %s backward",
243 extsymtab[comno].fextname);
248 if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
249 extsymtab[comno].extleng = k;
252 for(q = p->equivs ; q ; q = q->eqvnextp)
253 if(np = q->eqvitem.eqvname)
259 np->vstg = STGCOMMON;
261 np->vardesc.varno = comno;
263 /* np -> voffset will point to the base of the array */
265 np->voffset = comoffset - q->eqvoffset;
269 ovarno = np->vardesc.varno;
271 /* offq will point to the current element, even if it's in an array */
273 offq = comoffset - q->eqvoffset - np->voffset;
274 np->vstg = STGCOMMON;
276 np->vardesc.varno = comno;
278 /* np -> voffset will point to the base of the array */
280 np->voffset = comoffset - q->eqvoffset;
281 if(ovarno != (p - eqvclass))
282 eqvcommon(&eqvclass[ovarno], comno, offq);
286 if(comno != np->vardesc.varno ||
287 comoffset != np->voffset+q->eqvoffset)
288 dclerr("inconsistent common usage", np);
293 badstg("eqvcommon", np->vstg);
298 p->eqvbottom = p->eqvtop = 0;
302 /* Move all items on ovarno chain to the front of nvarno chain.
303 * adjust offsets of ovarno elements and top and bottom of nvarno chain
306 LOCAL eqveqv(nvarno, ovarno, delta)
310 register struct Equivblock *neweqv, *oldeqv;
312 struct Eqvchain *q, *q1;
314 neweqv = eqvclass + nvarno;
315 oldeqv = eqvclass + ovarno;
316 neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
317 neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
318 oldeqv->eqvbottom = oldeqv->eqvtop = 0;
320 for(q = oldeqv->equivs ; q ; q = q1)
323 if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
325 q->eqvnextp = neweqv->equivs;
327 q->eqvoffset -= delta;
328 np->vardesc.varno = nvarno;
329 np->voffset -= delta;
331 else free( (charptr) q);
333 oldeqv->equivs = NULL;
340 register struct Equivblock *p;
342 register struct Eqvchain *q, *oq;
344 for(q = p->equivs ; q ; q = oq)
356 /* nsubs -- number of subscripts in this arglist (just the length of the
360 register struct Listblock *p;
367 for(q = p->listp ; q ; q = q->nextp)