1 /* Id: equiv.c,v 1.11 2008/05/11 15:28:03 ragge Exp */
2 /* $NetBSD: equiv.c,v 1.1.1.2 2010/06/03 18:57:46 plunky Exp $ */
3 /*
4 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * Redistributions of source code and documentation must retain the above
11 * copyright notice, this list of conditions and the following disclaimer.
12 * Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditionsand the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 * All advertising materials mentioning features or use of this software
16 * must display the following acknowledgement:
17 * This product includes software developed or owned by Caldera
18 * International, Inc.
19 * Neither the name of Caldera International, Inc. nor the names of other
20 * contributors may be used to endorse or promote products derived from
21 * this software without specific prior written permission.
22 *
23 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
24 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
28 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
32 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
33 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 * POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "defines.h"
38 #include "defs.h"
39
40
41 /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
42 LOCAL void eqvcommon(struct equivblock *, int, ftnint);
43 LOCAL void eqveqv(int, int, ftnint);
44 LOCAL void freqchain(struct equivblock *p);
45 LOCAL int nsubs(struct bigblock *p);
46
47 /* called at end of declarations section to process chains
48 created by EQUIVALENCE statements
49 */
50 void
doequiv()51 doequiv()
52 {
53 register int i;
54 int inequiv, comno, ovarno;
55 ftnint comoffset, offset, leng;
56 register struct equivblock *p;
57 register chainp q;
58 struct bigblock *itemp;
59 register struct bigblock *np;
60 bigptr offp;
61 int ns;
62 chainp cp;
63
64 ovarno = comoffset = offset = 0; /* XXX gcc */
65 for(i = 0 ; i < nequiv ; ++i)
66 {
67 p = &eqvclass[i];
68 p->eqvbottom = p->eqvtop = 0;
69 comno = -1;
70
71 for(q = p->equivs ; q ; q = q->eqvchain.nextp)
72 {
73 itemp = q->eqvchain.eqvitem;
74 vardcl(np = itemp->b_prim.namep);
75 if(itemp->b_prim.argsp || itemp->b_prim.fcharp)
76 {
77 if(np->b_name.vdim!=NULL && np->b_name.vdim->ndim>1 &&
78 nsubs(itemp->b_prim.argsp)==1 )
79 {
80 if(! ftn66flag)
81 warn("1-dim subscript in EQUIVALENCE");
82 cp = NULL;
83 ns = np->b_name.vdim->ndim;
84 while(--ns > 0)
85 cp = mkchain( MKICON(1), cp);
86 itemp->b_prim.argsp->b_list.listp->chain.nextp = cp;
87 }
88 offp = suboffset(itemp);
89 }
90 else offp = MKICON(0);
91 if(ISICON(offp))
92 offset = q->eqvchain.eqvoffset = offp->b_const.fconst.ci;
93 else {
94 dclerr("nonconstant subscript in equivalence ", np);
95 np = NULL;
96 goto endit;
97 }
98 if( (leng = iarrlen(np)) < 0)
99 {
100 dclerr("adjustable in equivalence", np);
101 np = NULL;
102 goto endit;
103 }
104 p->eqvbottom = lmin(p->eqvbottom, -offset);
105 p->eqvtop = lmax(p->eqvtop, leng-offset);
106
107 switch(np->vstg)
108 {
109 case STGUNKNOWN:
110 case STGBSS:
111 case STGEQUIV:
112 break;
113
114 case STGCOMMON:
115 comno = np->b_name.vardesc.varno;
116 comoffset = np->b_name.voffset + offset;
117 break;
118
119 default:
120 dclerr("bad storage class in equivalence", np);
121 np = NULL;
122 goto endit;
123 }
124 endit:
125 frexpr(offp);
126 q->eqvchain.eqvitem = np;
127 }
128
129 if(comno >= 0)
130 eqvcommon(p, comno, comoffset);
131 else for(q = p->equivs ; q ; q = q->eqvchain.nextp)
132 {
133 if((np = q->eqvchain.eqvitem))
134 {
135 inequiv = NO;
136 if(np->vstg==STGEQUIV) {
137 if( (ovarno = np->b_name.vardesc.varno) == i)
138 {
139 if(np->b_name.voffset + q->eqvchain.eqvoffset != 0)
140 dclerr("inconsistent equivalence", np);
141 }
142 else {
143 offset = np->b_name.voffset;
144 inequiv = YES;
145 }
146 }
147 np->vstg = STGEQUIV;
148 np->b_name.vardesc.varno = i;
149 np->b_name.voffset = - q->eqvchain.eqvoffset;
150
151 if(inequiv)
152 eqveqv(i, ovarno, q->eqvchain.eqvoffset + offset);
153 }
154 }
155 }
156
157 for(i = 0 ; i < nequiv ; ++i)
158 {
159 p = & eqvclass[i];
160 if(p->eqvbottom!=0 || p->eqvtop!=0)
161 {
162 for(q = p->equivs ; q; q = q->eqvchain.nextp)
163 {
164 np = q->eqvchain.eqvitem;
165 np->b_name.voffset -= p->eqvbottom;
166 if(np->b_name.voffset % typealign[np->vtype] != 0)
167 dclerr("bad alignment forced by equivalence", np);
168 }
169 p->eqvtop -= p->eqvbottom;
170 p->eqvbottom = 0;
171 }
172 freqchain(p);
173 }
174 }
175
176
177
178
179
180 /* put equivalence chain p at common block comno + comoffset */
181
eqvcommon(p,comno,comoffset)182 LOCAL void eqvcommon(p, comno, comoffset)
183 struct equivblock *p;
184 int comno;
185 ftnint comoffset;
186 {
187 int ovarno;
188 ftnint k, offq;
189 register struct bigblock *np;
190 register chainp q;
191
192 if(comoffset + p->eqvbottom < 0)
193 {
194 err1("attempt to extend common %s backward",
195 nounder(XL, extsymtab[comno].extname) );
196 freqchain(p);
197 return;
198 }
199
200 if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
201 extsymtab[comno].extleng = k;
202
203 for(q = p->equivs ; q ; q = q->eqvchain.nextp)
204 if((np = q->eqvchain.eqvitem))
205 {
206 switch(np->vstg)
207 {
208 case STGUNKNOWN:
209 case STGBSS:
210 np->vstg = STGCOMMON;
211 np->b_name.vardesc.varno = comno;
212 np->b_name.voffset = comoffset - q->eqvchain.eqvoffset;
213 break;
214
215 case STGEQUIV:
216 ovarno = np->b_name.vardesc.varno;
217 offq = comoffset - q->eqvchain.eqvoffset - np->b_name.voffset;
218 np->vstg = STGCOMMON;
219 np->b_name.vardesc.varno = comno;
220 np->b_name.voffset = comoffset - q->eqvchain.eqvoffset;
221 if(ovarno != (p - eqvclass))
222 eqvcommon(&eqvclass[ovarno], comno, offq);
223 break;
224
225 case STGCOMMON:
226 if(comno != np->b_name.vardesc.varno ||
227 comoffset != np->b_name.voffset+q->eqvchain.eqvoffset)
228 dclerr("inconsistent common usage", np);
229 break;
230
231
232 default:
233 fatal1("eqvcommon: impossible vstg %d", np->vstg);
234 }
235 }
236
237 freqchain(p);
238 p->eqvbottom = p->eqvtop = 0;
239 }
240
241
242 /* put all items on ovarno chain on front of nvarno chain
243 * adjust offsets of ovarno elements and top and bottom of nvarno chain
244 */
245
eqveqv(nvarno,ovarno,delta)246 LOCAL void eqveqv(nvarno, ovarno, delta)
247 int ovarno, nvarno;
248 ftnint delta;
249 {
250 register struct equivblock *p0, *p;
251 register struct nameblock *np;
252 chainp q, q1;
253
254 p0 = eqvclass + nvarno;
255 p = eqvclass + ovarno;
256 p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta);
257 p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta);
258 p->eqvbottom = p->eqvtop = 0;
259
260 for(q = p->equivs ; q ; q = q1)
261 {
262 q1 = q->eqvchain.nextp;
263 if( (np = q->eqvchain.eqvitem) && np->vardesc.varno==ovarno)
264 {
265 q->eqvchain.nextp = p0->equivs;
266 p0->equivs = q;
267 q->eqvchain.eqvoffset -= delta;
268 np->vardesc.varno = nvarno;
269 np->voffset -= delta;
270 }
271 else ckfree(q);
272 }
273 p->equivs = NULL;
274 }
275
276
277
278
279 LOCAL void
freqchain(p)280 freqchain(p)
281 register struct equivblock *p;
282 {
283 register chainp q, oq;
284
285 for(q = p->equivs ; q ; q = oq)
286 {
287 oq = q->eqvchain.nextp;
288 ckfree(q);
289 }
290 p->equivs = NULL;
291 }
292
293
294
295
296
297 LOCAL int
nsubs(p)298 nsubs(p)
299 register struct bigblock *p;
300 {
301 register int n;
302 register chainp q;
303
304 n = 0;
305 if(p)
306 for(q = p->b_list.listp ; q ; q = q->chain.nextp)
307 ++n;
308
309 return(n);
310 }
311