lang/fortran/comp/equiv.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   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.
  13
  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
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25
  26 LOCAL eqvcommon(), eqveqv(), nsubs();
  27
  28 /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
  29
  30 /* called at end of declarations section to process chains
  31    created by EQUIVALENCE statements
  32  */
  33 doequiv()
  34 {
  35         register int i;
  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) */
  41         int ovarno;
  42         ftnint comoffset;       /* Index into the COMMON block */
  43         ftnint offset;          /* Offset from array base */
  44         ftnint leng;
  45         register struct Equivblock *equivdecl;
  46         register struct Eqvchain *q;
  47         struct Primblock *primp;
  48         register Namep np;
  49         int k, k1, ns, pref, t;
  50         chainp cp;
  51         extern int type_pref[];
  52
  53         for(i = 0 ; i < nequiv ; ++i)
  54         {
  55
  56 /* Handle each equivalence declaration */
  57
  58                 equivdecl = &eqvclass[i];
  59                 equivdecl->eqvbottom = equivdecl->eqvtop = 0;
  60                 comno = -1;
  61
  62
  63
  64                 for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
  65                 {
  66                         offset = 0;
  67                         primp = q->eqvitem.eqvlhs;
  68                         vardcl(np = primp->namep);
  69                         if(primp->argsp || primp->fcharp)
  70                         {
  71                                 expptr offp, suboffset();
  72
  73 /* Pad ones onto the end of an array declaration when needed */
  74
  75                                 if(np->vdim!=NULL && np->vdim->ndim>1 &&
  76                                     nsubs(primp->argsp)==1 )
  77                                 {
  78                                         if(! ftn66flag)
  79                                                 warni
  80                         ("1-dim subscript in EQUIVALENCE, %d-dim declared",
  81                                                     np -> vdim -> ndim);
  82                                         cp = NULL;
  83                                         ns = np->vdim->ndim;
  84                                         while(--ns > 0)
  85                                                 cp = mkchain((char *)ICON(1), cp);
  86                                         primp->argsp->listp->nextp = cp;
  87                                 }
  88
  89                                 offp = suboffset(primp);
  90                                 if(ISICON(offp))
  91                                         offset = offp->constblock.Const.ci;
  92                                 else    {
  93                                         dclerr
  94                         ("nonconstant subscript in equivalence ",
  95                                             np);
  96                                         np = NULL;
  97                                 }
  98                                 frexpr(offp);
  99                         }
 100
 101 /* Free up the primblock, since we now have a hash table (Namep) entry */
 102
 103                         frexpr((expptr)primp);
 104
 105                         if(np && (leng = iarrlen(np))<0)
 106                         {
 107                                 dclerr("adjustable in equivalence", np);
 108                                 np = NULL;
 109                         }
 110
 111                         if(np) switch(np->vstg)
 112                         {
 113                         case STGUNKNOWN:
 114                         case STGBSS:
 115                         case STGEQUIV:
 116                                 break;
 117
 118                         case STGCOMMON:
 119
 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 */
 122
 123                                 comno = np->vardesc.varno;
 124                                 comoffset = np->voffset + offset;
 125                                 break;
 126
 127                         default:
 128                                 dclerr("bad storage class in equivalence", np);
 129                                 np = NULL;
 130                                 break;
 131                         }
 132
 133                         if(np)
 134                         {
 135                                 q->eqvoffset = offset;
 136
 137 /* eqvbottom   gets the largest difference between the array base address
 138    and the address specified in the EQUIV declaration */
 139
 140                                 equivdecl->eqvbottom =
 141                                     lmin(equivdecl->eqvbottom, -offset);
 142
 143 /* eqvtop   gets the largest difference between the end of the array and
 144    the address given in the EQUIVALENCE */
 145
 146                                 equivdecl->eqvtop =
 147                                     lmax(equivdecl->eqvtop, leng-offset);
 148                         }
 149                         q->eqvitem.eqvname = np;
 150                 }
 151
 152 /* Now all equivalenced variables are in the hash table with the proper
 153    offset, and   eqvtop and eqvbottom   are set. */
 154
 155                 if(comno >= 0)
 156
 157 /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
 158    */
 159
 160                         eqvcommon(equivdecl, comno, comoffset);
 161                 else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
 162                 {
 163                         if(np = q->eqvitem.eqvname)
 164                         {
 165                                 inequiv = NO;
 166                                 if(np->vstg==STGEQUIV)
 167                                         if( (ovarno = np->vardesc.varno) == i)
 168                                         {
 169
 170 /* Can't EQUIV different elements of the same array */
 171
 172                                                 if(np->voffset + q->eqvoffset != 0)
 173                                                         dclerr
 174                         ("inconsistent equivalence", np);
 175                                         }
 176                                         else    {
 177                                                 offset = np->voffset;
 178                                                 inequiv = YES;
 179                                         }
 180
 181                                 np->vstg = STGEQUIV;
 182                                 np->vardesc.varno = i;
 183                                 np->voffset = - q->eqvoffset;
 184
 185                                 if(inequiv)
 186
 187 /* Combine 2 equivalence declarations */
 188
 189                                         eqveqv(i, ovarno, q->eqvoffset + offset);
 190                         }
 191                 }
 192         }
 193
 194 /* Now each equivalence declaration is distinct (all connections have been
 195    merged in eqveqv()), and some may be empty. */
 196
 197         for(i = 0 ; i < nequiv ; ++i)
 198         {
 199                 equivdecl = & eqvclass[i];
 200                 if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
 201
 202 /* a live chain */
 203
 204                         k = TYCHAR;
 205                         pref = 1;
 206                         for(q = equivdecl->equivs ; q; q = q->eqvnextp)
 207                             if (np = q->eqvitem.eqvname){
 208                                 np->voffset -= equivdecl->eqvbottom;
 209                                 t = typealign[k1 = np->vtype];
 210                                 if (pref < type_pref[k1]) {
 211                                         k = k1;
 212                                         pref = type_pref[k1];
 213                                         }
 214                                 if(np->voffset % t != 0) {
 215                                         dclerr("bad alignment forced by equivalence", np);
 216                                         --nerr; /* don't give bad return code for this */
 217                                         }
 218                                 }
 219                         equivdecl->eqvtype = k;
 220                 }
 221                 freqchain(equivdecl);
 222         }
 223 }
 224
 225
 226
 227
 228
 229 /* put equivalence chain p at common block comno + comoffset */
 230
 231 LOCAL eqvcommon(p, comno, comoffset)
 232 struct Equivblock *p;
 233 int comno;
 234 ftnint comoffset;
 235 {
 236         int ovarno;
 237         ftnint k, offq;
 238         register Namep np;
 239         register struct Eqvchain *q;
 240
 241         if(comoffset + p->eqvbottom < 0)
 242         {
 243                 errstr("attempt to extend common %s backward",
 244                     extsymtab[comno].fextname);
 245                 freqchain(p);
 246                 return;
 247         }
 248
 249         if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
 250                 extsymtab[comno].extleng = k;
 251
 252
 253         for(q = p->equivs ; q ; q = q->eqvnextp)
 254                 if(np = q->eqvitem.eqvname)
 255                 {
 256                         switch(np->vstg)
 257                         {
 258                         case STGUNKNOWN:
 259                         case STGBSS:
 260                                 np->vstg = STGCOMMON;
 261                                 np->vcommequiv = 1;
 262                                 np->vardesc.varno = comno;
 263
 264 /* np -> voffset   will point to the base of the array */
 265
 266                                 np->voffset = comoffset - q->eqvoffset;
 267                                 break;
 268
 269                         case STGEQUIV:
 270                                 ovarno = np->vardesc.varno;
 271
 272 /* offq   will point to the current element, even if it's in an array */
 273
 274                                 offq = comoffset - q->eqvoffset - np->voffset;
 275                                 np->vstg = STGCOMMON;
 276                                 np->vcommequiv = 1;
 277                                 np->vardesc.varno = comno;
 278
 279 /* np -> voffset   will point to the base of the array */
 280
 281                                 np->voffset += offq;
 282                                 if(ovarno != (p - eqvclass))
 283                                         eqvcommon(&eqvclass[ovarno], comno, offq);
 284                                 break;
 285
 286                         case STGCOMMON:
 287                                 if(comno != np->vardesc.varno ||
 288                                     comoffset != np->voffset+q->eqvoffset)
 289                                         dclerr("inconsistent common usage", np);
 290                                 break;
 291
 292
 293                         default:
 294                                 badstg("eqvcommon", np->vstg);
 295                         }
 296                 }
 297
 298         freqchain(p);
 299         p->eqvbottom = p->eqvtop = 0;
 300 }
 301
 302
 303 /* Move all items on ovarno chain to the front of   nvarno   chain.
 304  * adjust offsets of ovarno elements and top and bottom of nvarno chain
 305  */
 306
 307 LOCAL eqveqv(nvarno, ovarno, delta)
 308 int ovarno, nvarno;
 309 ftnint delta;
 310 {
 311         register struct Equivblock *neweqv, *oldeqv;
 312         register Namep np;
 313         struct Eqvchain *q, *q1;
 314
 315         neweqv = eqvclass + nvarno;
 316         oldeqv = eqvclass + ovarno;
 317         neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
 318         neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
 319         oldeqv->eqvbottom = oldeqv->eqvtop = 0;
 320
 321         for(q = oldeqv->equivs ; q ; q = q1)
 322         {
 323                 q1 = q->eqvnextp;
 324                 if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
 325                 {
 326                         q->eqvnextp = neweqv->equivs;
 327                         neweqv->equivs = q;
 328                         q->eqvoffset += delta;
 329                         np->vardesc.varno = nvarno;
 330                         np->voffset -= delta;
 331                 }
 332                 else    free( (charptr) q);
 333         }
 334         oldeqv->equivs = NULL;
 335 }
 336
 337
 338
 339
 340 freqchain(p)
 341 register struct Equivblock *p;
 342 {
 343         register struct Eqvchain *q, *oq;
 344
 345         for(q = p->equivs ; q ; q = oq)
 346         {
 347                 oq = q->eqvnextp;
 348                 free( (charptr) q);
 349         }
 350         p->equivs = NULL;
 351 }
 352
 353
 354
 355
 356
 357 /* nsubs -- number of subscripts in this arglist (just the length of the
 358    list) */
 359
 360 LOCAL nsubs(p)
 361 register struct Listblock *p;
 362 {
 363         register int n;
 364         register chainp q;
 365
 366         n = 0;
 367         if(p)
 368                 for(q = p->listp ; q ; q = q->nextp)
 369                         ++n;
 370
 371         return(n);
 372 }