2.9BSD - /usr/src/cmd/f77/equiv.c

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

Defined functions