compilers/pcc/pcc-1.0.0/f77/fcom/equiv.c

   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 }