| 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 */
|
|---|
| 41 | LOCAL void eqvcommon(struct equivblock *, int, ftnint);
|
|---|
| 42 | LOCAL void eqveqv(int, int, ftnint);
|
|---|
| 43 | LOCAL void freqchain(struct equivblock *p);
|
|---|
| 44 | LOCAL int nsubs(struct bigblock *p);
|
|---|
| 45 |
|
|---|
| 46 | /* called at end of declarations section to process chains
|
|---|
| 47 | created by EQUIVALENCE statements
|
|---|
| 48 | */
|
|---|
| 49 | void
|
|---|
| 50 | doequiv()
|
|---|
| 51 | {
|
|---|
| 52 | register int i;
|
|---|
| 53 | int inequiv, comno, ovarno;
|
|---|
| 54 | ftnint comoffset, offset, leng;
|
|---|
| 55 | register struct equivblock *p;
|
|---|
| 56 | register chainp q;
|
|---|
| 57 | struct bigblock *itemp;
|
|---|
| 58 | register struct bigblock *np;
|
|---|
| 59 | bigptr offp;
|
|---|
| 60 | int ns;
|
|---|
| 61 | chainp cp;
|
|---|
| 62 |
|
|---|
| 63 | ovarno = comoffset = offset = 0; /* XXX gcc */
|
|---|
| 64 | for(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 |
|
|---|
| 156 | for(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 |
|
|---|
| 181 | LOCAL void eqvcommon(p, comno, comoffset)
|
|---|
| 182 | struct equivblock *p;
|
|---|
| 183 | int comno;
|
|---|
| 184 | ftnint comoffset;
|
|---|
| 185 | {
|
|---|
| 186 | int ovarno;
|
|---|
| 187 | ftnint k, offq;
|
|---|
| 188 | register struct bigblock *np;
|
|---|
| 189 | register chainp q;
|
|---|
| 190 |
|
|---|
| 191 | if(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 |
|
|---|
| 199 | if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
|
|---|
| 200 | extsymtab[comno].extleng = k;
|
|---|
| 201 |
|
|---|
| 202 | for(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 |
|
|---|
| 236 | freqchain(p);
|
|---|
| 237 | p->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 |
|
|---|
| 245 | LOCAL void eqveqv(nvarno, ovarno, delta)
|
|---|
| 246 | int ovarno, nvarno;
|
|---|
| 247 | ftnint delta;
|
|---|
| 248 | {
|
|---|
| 249 | register struct equivblock *p0, *p;
|
|---|
| 250 | register struct nameblock *np;
|
|---|
| 251 | chainp q, q1;
|
|---|
| 252 |
|
|---|
| 253 | p0 = eqvclass + nvarno;
|
|---|
| 254 | p = eqvclass + ovarno;
|
|---|
| 255 | p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta);
|
|---|
| 256 | p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta);
|
|---|
| 257 | p->eqvbottom = p->eqvtop = 0;
|
|---|
| 258 |
|
|---|
| 259 | for(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 | }
|
|---|
| 272 | p->equivs = NULL;
|
|---|
| 273 | }
|
|---|
| 274 |
|
|---|
| 275 |
|
|---|
| 276 |
|
|---|
| 277 |
|
|---|
| 278 | LOCAL void
|
|---|
| 279 | freqchain(p)
|
|---|
| 280 | register struct equivblock *p;
|
|---|
| 281 | {
|
|---|
| 282 | register chainp q, oq;
|
|---|
| 283 |
|
|---|
| 284 | for(q = p->equivs ; q ; q = oq)
|
|---|
| 285 | {
|
|---|
| 286 | oq = q->eqvchain.nextp;
|
|---|
| 287 | ckfree(q);
|
|---|
| 288 | }
|
|---|
| 289 | p->equivs = NULL;
|
|---|
| 290 | }
|
|---|
| 291 |
|
|---|
| 292 |
|
|---|
| 293 |
|
|---|
| 294 |
|
|---|
| 295 |
|
|---|
| 296 | LOCAL int
|
|---|
| 297 | nsubs(p)
|
|---|
| 298 | register struct bigblock *p;
|
|---|
| 299 | {
|
|---|
| 300 | register int n;
|
|---|
| 301 | register chainp q;
|
|---|
| 302 |
|
|---|
| 303 | n = 0;
|
|---|
| 304 | if(p)
|
|---|
| 305 | for(q = p->b_list.listp ; q ; q = q->chain.nextp)
|
|---|
| 306 | ++n;
|
|---|
| 307 |
|
|---|
| 308 | return(n);
|
|---|
| 309 | }
|
|---|
