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