![[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.