2.11BSD#431 - /usr/src/usr.bin/f77/equiv.c

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

Defined functions