UNIX 7th Ed. - /usr/src/cmd/f77/equiv.c

   1: #include "defs"
   2: 
   3: /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
   4: 
   5: /* called at end of declarations section to process chains
   6:    created by EQUIVALENCE statements
   7:  */
   8: doequiv()
   9: {
  10: register int i;
  11: int inequiv, comno, ovarno;
  12: ftnint comoffset, offset, leng, iarrlen(), lmin(), lmax();
  13: register struct equivblock *p;
  14: register struct eqvchain *q;
  15: struct primblock *itemp;
  16: register struct nameblock *np;
  17: expptr offp, suboffset();
  18: int ns, nsubs();
  19: chainp cp;
  20: 
  21: for(i = 0 ; i < nequiv ; ++i)
  22:     {
  23:     p = &eqvclass[i];
  24:     p->eqvbottom = p->eqvtop = 0;
  25:     comno = -1;
  26: 
  27:     for(q = p->equivs ; q ; q = q->nextp)
  28:         {
  29:         itemp = q->eqvitem;
  30:         vardcl(np = itemp->namep);
  31:         if(itemp->argsp || itemp->fcharp)
  32:             {
  33:             if(np->vdim!=NULL && np->vdim->ndim>1 &&
  34:                nsubs(itemp->argsp)==1 )
  35:                 {
  36:                 if(! ftn66flag)
  37:                     warn("1-dim subscript in EQUIVALENCE");
  38:                 cp = NULL;
  39:                 ns = np->vdim->ndim;
  40:                 while(--ns > 0)
  41:                     cp = mkchain( ICON(1), cp);
  42:                 itemp->argsp->listp->nextp = cp;
  43:                 }
  44:             offp = suboffset(itemp);
  45:             }
  46:         else    offp = ICON(0);
  47:         if(ISICON(offp))
  48:             offset = q->eqvoffset = offp->const.ci;
  49:         else    {
  50:             dclerr("nonconstant subscript in equivalence ", np);
  51:             np = NULL;
  52:             goto endit;
  53:             }
  54:         if( (leng = iarrlen(np)) < 0)
  55:             {
  56:             dclerr("adjustable in equivalence", np);
  57:             np = NULL;
  58:             goto endit;
  59:             }
  60:         p->eqvbottom = lmin(p->eqvbottom, -offset);
  61:         p->eqvtop = lmax(p->eqvtop, leng-offset);
  62: 
  63:         switch(np->vstg)
  64:             {
  65:             case STGUNKNOWN:
  66:             case STGBSS:
  67:             case STGEQUIV:
  68:                 break;
  69: 
  70:             case STGCOMMON:
  71:                 comno = np->vardesc.varno;
  72:                 comoffset = np->voffset + offset;
  73:                 break;
  74: 
  75:             default:
  76:                 dclerr("bad storage class in equivalence", np);
  77:                 np = NULL;
  78:                 goto endit;
  79:             }
  80:     endit:
  81:         frexpr(offp);
  82:         q->eqvitem = np;
  83:         }
  84: 
  85:     if(comno >= 0)
  86:         eqvcommon(p, comno, comoffset);
  87:     else  for(q = p->equivs ; q ; q = q->nextp)
  88:         {
  89:         if(np = q->eqvitem)
  90:             {
  91:             inequiv = NO;
  92:             if(np->vstg==STGEQUIV)
  93:                 if( (ovarno = np->vardesc.varno) == i)
  94:                     {
  95:                     if(np->voffset + q->eqvoffset != 0)
  96:                         dclerr("inconsistent equivalence", np);
  97:                     }
  98:                 else    {
  99:                     offset = np->voffset;
 100:                     inequiv = YES;
 101:                     }
 102: 
 103:             np->vstg = STGEQUIV;
 104:             np->vardesc.varno = i;
 105:             np->voffset = - q->eqvoffset;
 106: 
 107:             if(inequiv)
 108:                 eqveqv(i, ovarno, q->eqvoffset + offset);
 109:             }
 110:         }
 111:     }
 112: 
 113: for(i = 0 ; i < nequiv ; ++i)
 114:     {
 115:     p = & eqvclass[i];
 116:     if(p->eqvbottom!=0 || p->eqvtop!=0)
 117:         {
 118:         for(q = p->equivs ; q; q = q->nextp)
 119:             {
 120:             np = q->eqvitem;
 121:             np->voffset -= p->eqvbottom;
 122:             if(np->voffset % typealign[np->vtype] != 0)
 123:                 dclerr("bad alignment forced by equivalence", np);
 124:             }
 125:         p->eqvtop -= p->eqvbottom;
 126:         p->eqvbottom = 0;
 127:         }
 128:     freqchain(p);
 129:     }
 130: }
 131: 
 132: 
 133: 
 134: 
 135: 
 136: /* put equivalence chain p at common block comno + comoffset */
 137: 
 138: LOCAL eqvcommon(p, comno, comoffset)
 139: struct equivblock *p;
 140: int comno;
 141: ftnint comoffset;
 142: {
 143: int ovarno;
 144: ftnint k, offq;
 145: register struct nameblock *np;
 146: register struct eqvchain *q;
 147: 
 148: if(comoffset + p->eqvbottom < 0)
 149:     {
 150:     err1("attempt to extend common %s backward",
 151:         nounder(XL, extsymtab[comno].extname) );
 152:     freqchain(p);
 153:     return;
 154:     }
 155: 
 156: if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
 157:     extsymtab[comno].extleng = k;
 158: 
 159: for(q = p->equivs ; q ; q = q->nextp)
 160:     if(np = q->eqvitem)
 161:         {
 162:         switch(np->vstg)
 163:             {
 164:             case STGUNKNOWN:
 165:             case STGBSS:
 166:                 np->vstg = STGCOMMON;
 167:                 np->vardesc.varno = comno;
 168:                 np->voffset = comoffset - q->eqvoffset;
 169:                 break;
 170: 
 171:             case STGEQUIV:
 172:                 ovarno = np->vardesc.varno;
 173:                 offq = comoffset - q->eqvoffset - np->voffset;
 174:                 np->vstg = STGCOMMON;
 175:                 np->vardesc.varno = comno;
 176:                 np->voffset = comoffset - q->eqvoffset;
 177:                 if(ovarno != (p - eqvclass))
 178:                     eqvcommon(&eqvclass[ovarno], comno, offq);
 179:                 break;
 180: 
 181:             case STGCOMMON:
 182:                 if(comno != np->vardesc.varno ||
 183:                    comoffset != np->voffset+q->eqvoffset)
 184:                     dclerr("inconsistent common usage", np);
 185:                 break;
 186: 
 187: 
 188:             default:
 189:                 fatal1("eqvcommon: impossible vstg %d", np->vstg);
 190:             }
 191:         }
 192: 
 193: freqchain(p);
 194: p->eqvbottom = p->eqvtop = 0;
 195: }
 196: 
 197: 
 198: /* put all items on ovarno chain on front of nvarno chain
 199:  * adjust offsets of ovarno elements and top and bottom of nvarno chain
 200:  */
 201: 
 202: LOCAL eqveqv(nvarno, ovarno, delta)
 203: int ovarno, nvarno;
 204: ftnint delta;
 205: {
 206: register struct equivblock *p0, *p;
 207: register struct nameblock *np;
 208: struct eqvchain *q, *q1;
 209: 
 210: p0 = eqvclass + nvarno;
 211: p = eqvclass + ovarno;
 212: p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta);
 213: p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta);
 214: p->eqvbottom = p->eqvtop = 0;
 215: 
 216: for(q = p->equivs ; q ; q = q1)
 217:     {
 218:     q1 = q->nextp;
 219:     if( (np = q->eqvitem) && np->vardesc.varno==ovarno)
 220:         {
 221:         q->nextp = p0->equivs;
 222:         p0->equivs = q;
 223:         q->eqvoffset -= delta;
 224:         np->vardesc.varno = nvarno;
 225:         np->voffset -= delta;
 226:         }
 227:     else    free(q);
 228:     }
 229: p->equivs = NULL;
 230: }
 231: 
 232: 
 233: 
 234: 
 235: LOCAL freqchain(p)
 236: register struct equivblock *p;
 237: {
 238: register struct eqvchain *q, *oq;
 239: 
 240: for(q = p->equivs ; q ; q = oq)
 241:     {
 242:     oq = q->nextp;
 243:     free(q);
 244:     }
 245: p->equivs = NULL;
 246: }
 247: 
 248: 
 249: 
 250: 
 251: 
 252: LOCAL nsubs(p)
 253: register struct listblock *p;
 254: {
 255: register int n;
 256: register chainp q;
 257: 
 258: n = 0;
 259: if(p)
 260:     for(q = p->listp ; q ; q = q->nextp)
 261:         ++n;
 262: 
 263: return(n);
 264: }

Defined functions