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