sources/f2c/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                         {
 208                                 np = q->eqvitem.eqvname;
 209                                 np->voffset -= equivdecl->eqvbottom;
 210                                 t = typealign[k1 = np->vtype];
 211                                 if (pref < type_pref[k1]) {
 212                                         k = k1;
 213                                         pref = type_pref[k1];
 214                                         }
 215                                 if(np->voffset % t != 0)
 216                                         dclerr("bad alignment forced by equivalence", np);
 217                         }
 218                         equivdecl->eqvtype = k;
 219                 }
 220                 freqchain(equivdecl);
 221         }
 222 }
 223
 224
 225
 226
 227
 228 /* put equivalence chain p at common block comno + comoffset */
 229
 230 LOCAL eqvcommon(p, comno, comoffset)
 231 struct Equivblock *p;
 232 int comno;
 233 ftnint comoffset;
 234 {
 235         int ovarno;
 236         ftnint k, offq;
 237         register Namep np;
 238         register struct Eqvchain *q;
 239
 240         if(comoffset + p->eqvbottom < 0)
 241         {
 242                 errstr("attempt to extend common %s backward",
 243                     extsymtab[comno].fextname);
 244                 freqchain(p);
 245                 return;
 246         }
 247
 248         if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
 249                 extsymtab[comno].extleng = k;
 250
 251
 252         for(q = p->equivs ; q ; q = q->eqvnextp)
 253                 if(np = q->eqvitem.eqvname)
 254                 {
 255                         switch(np->vstg)
 256                         {
 257                         case STGUNKNOWN:
 258                         case STGBSS:
 259                                 np->vstg = STGCOMMON;
 260                                 np->vcommequiv = 1;
 261                                 np->vardesc.varno = comno;
 262
 263 /* np -> voffset   will point to the base of the array */
 264
 265                                 np->voffset = comoffset - q->eqvoffset;
 266                                 break;
 267
 268                         case STGEQUIV:
 269                                 ovarno = np->vardesc.varno;
 270
 271 /* offq   will point to the current element, even if it's in an array */
 272
 273                                 offq = comoffset - q->eqvoffset - np->voffset;
 274                                 np->vstg = STGCOMMON;
 275                                 np->vcommequiv = 1;
 276                                 np->vardesc.varno = comno;
 277
 278 /* np -> voffset   will point to the base of the array */
 279
 280                                 np->voffset = comoffset - q->eqvoffset;
 281                                 if(ovarno != (p - eqvclass))
 282                                         eqvcommon(&eqvclass[ovarno], comno, offq);
 283                                 break;
 284
 285                         case STGCOMMON:
 286                                 if(comno != np->vardesc.varno ||
 287                                     comoffset != np->voffset+q->eqvoffset)
 288                                         dclerr("inconsistent common usage", np);
 289                                 break;
 290
 291
 292                         default:
 293                                 badstg("eqvcommon", np->vstg);
 294                         }
 295                 }
 296
 297         freqchain(p);
 298         p->eqvbottom = p->eqvtop = 0;
 299 }
 300
 301
 302 /* Move all items on ovarno chain to the front of   nvarno   chain.
 303  * adjust offsets of ovarno elements and top and bottom of nvarno chain
 304  */
 305
 306 LOCAL eqveqv(nvarno, ovarno, delta)
 307 int ovarno, nvarno;
 308 ftnint delta;
 309 {
 310         register struct Equivblock *neweqv, *oldeqv;
 311         register Namep np;
 312         struct Eqvchain *q, *q1;
 313
 314         neweqv = eqvclass + nvarno;
 315         oldeqv = eqvclass + ovarno;
 316         neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
 317         neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
 318         oldeqv->eqvbottom = oldeqv->eqvtop = 0;
 319
 320         for(q = oldeqv->equivs ; q ; q = q1)
 321         {
 322                 q1 = q->eqvnextp;
 323                 if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
 324                 {
 325                         q->eqvnextp = neweqv->equivs;
 326                         neweqv->equivs = q;
 327                         q->eqvoffset -= delta;
 328                         np->vardesc.varno = nvarno;
 329                         np->voffset -= delta;
 330                 }
 331                 else    free( (charptr) q);
 332         }
 333         oldeqv->equivs = NULL;
 334 }
 335
 336
 337
 338
 339 freqchain(p)
 340 register struct Equivblock *p;
 341 {
 342         register struct Eqvchain *q, *oq;
 343
 344         for(q = p->equivs ; q ; q = oq)
 345         {
 346                 oq = q->eqvnextp;
 347                 free( (charptr) q);
 348         }
 349         p->equivs = NULL;
 350 }
 351
 352
 353
 354
 355
 356 /* nsubs -- number of subscripts in this arglist (just the length of the
 357    list) */
 358
 359 LOCAL nsubs(p)
 360 register struct Listblock *p;
 361 {
 362         register int n;
 363         register chainp q;
 364
 365         n = 0;
 366         if(p)
 367                 for(q = p->listp ; q ; q = q->nextp)
 368                         ++n;
 369
 370         return(n);
 371 }