source: mainline/uspace/app/pcc/f77/fcom/equiv.c@ 7eaeec1

lfn serial ticket/834-toolchain-update topic/msim-upgrade topic/simplify-dev-export
Last change on this file since 7eaeec1 was a7de7182, checked in by Jiří Zárevúcky <zarevucky.jiri@…>, 14 years ago

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