![[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] / researchv10no / cmd / f2c|
Return to equiv.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25:
26: LOCAL eqvcommon(), eqveqv(), nsubs();
27:
28: /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
29:
30: /* called at end of declarations section to process chains
31: created by EQUIVALENCE statements
32: */
33: doequiv()
34: {
35: register int i;
36: int inequiv; /* True if one namep occurs in
37: several EQUIV declarations */
38: int comno; /* Index into Extsym table of the last
39: COMMON block seen (implicitly assuming
40: that only one will be given) */
41: int ovarno;
42: ftnint comoffset; /* Index into the COMMON block */
43: ftnint offset; /* Offset from array base */
44: ftnint leng;
45: register struct Equivblock *equivdecl;
46: register struct Eqvchain *q;
47: struct Primblock *primp;
48: register Namep np;
49: int k, k1, ns, pref, t;
50: chainp cp;
51: extern int type_pref[];
52: char *s;
53:
54: for(i = 0 ; i < nequiv ; ++i)
55: {
56:
57: /* Handle each equivalence declaration */
58:
59: equivdecl = &eqvclass[i];
60: equivdecl->eqvbottom = equivdecl->eqvtop = 0;
61: comno = -1;
62:
63:
64:
65: for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
66: {
67: offset = 0;
68: primp = q->eqvitem.eqvlhs;
69: vardcl(np = primp->namep);
70: if(primp->argsp || primp->fcharp)
71: {
72: expptr offp, suboffset();
73:
74: /* Pad ones onto the end of an array declaration when needed */
75:
76: if(np->vdim!=NULL && np->vdim->ndim>1 &&
77: nsubs(primp->argsp)==1 )
78: {
79: if(! ftn66flag)
80: warni
81: ("1-dim subscript in EQUIVALENCE, %d-dim declared",
82: np -> vdim -> ndim);
83: cp = NULL;
84: ns = np->vdim->ndim;
85: while(--ns > 0)
86: cp = mkchain((char *)ICON(1), cp);
87: primp->argsp->listp->nextp = cp;
88: }
89:
90: offp = suboffset(primp);
91: if(ISICON(offp))
92: offset = offp->constblock.Const.ci;
93: else {
94: dclerr
95: ("nonconstant subscript in equivalence ",
96: np);
97: np = NULL;
98: }
99: frexpr(offp);
100: }
101:
102: /* Free up the primblock, since we now have a hash table (Namep) entry */
103:
104: frexpr((expptr)primp);
105:
106: if(np && (leng = iarrlen(np))<0)
107: {
108: dclerr("adjustable in equivalence", np);
109: np = NULL;
110: }
111:
112: if(np) switch(np->vstg)
113: {
114: case STGUNKNOWN:
115: case STGBSS:
116: case STGEQUIV:
117: if (in_vector(np->cvarname, st_fields,
118: n_st_fields) >= 0) {
119: k = strlen(np->cvarname);
120: strcpy(s = mem(k+2,0), np->cvarname);
121: s[k] = '_';
122: s[k+1] = 0;
123: np->cvarname = s;
124: }
125: break;
126:
127: case STGCOMMON:
128:
129: /* The code assumes that all COMMON references in a given EQUIVALENCE will
130: be to the same COMMON block, and will all be consistent */
131:
132: comno = np->vardesc.varno;
133: comoffset = np->voffset + offset;
134: break;
135:
136: default:
137: dclerr("bad storage class in equivalence", np);
138: np = NULL;
139: break;
140: }
141:
142: if(np)
143: {
144: q->eqvoffset = offset;
145:
146: /* eqvbottom gets the largest difference between the array base address
147: and the address specified in the EQUIV declaration */
148:
149: equivdecl->eqvbottom =
150: lmin(equivdecl->eqvbottom, -offset);
151:
152: /* eqvtop gets the largest difference between the end of the array and
153: the address given in the EQUIVALENCE */
154:
155: equivdecl->eqvtop =
156: lmax(equivdecl->eqvtop, leng-offset);
157: }
158: q->eqvitem.eqvname = np;
159: }
160:
161: /* Now all equivalenced variables are in the hash table with the proper
162: offset, and eqvtop and eqvbottom are set. */
163:
164: if(comno >= 0)
165:
166: /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
167: */
168:
169: eqvcommon(equivdecl, comno, comoffset);
170: else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
171: {
172: if(np = q->eqvitem.eqvname)
173: {
174: inequiv = NO;
175: if(np->vstg==STGEQUIV)
176: if( (ovarno = np->vardesc.varno) == i)
177: {
178:
179: /* Can't EQUIV different elements of the same array */
180:
181: if(np->voffset + q->eqvoffset != 0)
182: dclerr
183: ("inconsistent equivalence", np);
184: }
185: else {
186: offset = np->voffset;
187: inequiv = YES;
188: }
189:
190: np->vstg = STGEQUIV;
191: np->vardesc.varno = i;
192: np->voffset = - q->eqvoffset;
193:
194: if(inequiv)
195:
196: /* Combine 2 equivalence declarations */
197:
198: eqveqv(i, ovarno, q->eqvoffset + offset);
199: }
200: }
201: }
202:
203: /* Now each equivalence declaration is distinct (all connections have been
204: merged in eqveqv()), and some may be empty. */
205:
206: for(i = 0 ; i < nequiv ; ++i)
207: {
208: equivdecl = & eqvclass[i];
209: if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
210:
211: /* a live chain */
212:
213: k = TYCHAR;
214: pref = 1;
215: for(q = equivdecl->equivs ; q; q = q->eqvnextp)
216: if (np = q->eqvitem.eqvname){
217: np->voffset -= equivdecl->eqvbottom;
218: t = typealign[k1 = np->vtype];
219: if (pref < type_pref[k1]) {
220: k = k1;
221: pref = type_pref[k1];
222: }
223: if(np->voffset % t != 0) {
224: dclerr("bad alignment forced by equivalence", np);
225: --nerr; /* don't give bad return code for this */
226: }
227: }
228: equivdecl->eqvtype = k;
229: }
230: freqchain(equivdecl);
231: }
232: }
233:
234:
235:
236:
237:
238: /* put equivalence chain p at common block comno + comoffset */
239:
240: LOCAL eqvcommon(p, comno, comoffset)
241: struct Equivblock *p;
242: int comno;
243: ftnint comoffset;
244: {
245: int ovarno;
246: ftnint k, offq;
247: register Namep np;
248: register struct Eqvchain *q;
249:
250: if(comoffset + p->eqvbottom < 0)
251: {
252: errstr("attempt to extend common %s backward",
253: extsymtab[comno].fextname);
254: freqchain(p);
255: return;
256: }
257:
258: if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
259: extsymtab[comno].extleng = k;
260:
261:
262: for(q = p->equivs ; q ; q = q->eqvnextp)
263: if(np = q->eqvitem.eqvname)
264: {
265: switch(np->vstg)
266: {
267: case STGUNKNOWN:
268: case STGBSS:
269: np->vstg = STGCOMMON;
270: np->vcommequiv = 1;
271: np->vardesc.varno = comno;
272:
273: /* np -> voffset will point to the base of the array */
274:
275: np->voffset = comoffset - q->eqvoffset;
276: break;
277:
278: case STGEQUIV:
279: ovarno = np->vardesc.varno;
280:
281: /* offq will point to the current element, even if it's in an array */
282:
283: offq = comoffset - q->eqvoffset - np->voffset;
284: np->vstg = STGCOMMON;
285: np->vcommequiv = 1;
286: np->vardesc.varno = comno;
287:
288: /* np -> voffset will point to the base of the array */
289:
290: np->voffset += offq;
291: if(ovarno != (p - eqvclass))
292: eqvcommon(&eqvclass[ovarno], comno, offq);
293: break;
294:
295: case STGCOMMON:
296: if(comno != np->vardesc.varno ||
297: comoffset != np->voffset+q->eqvoffset)
298: dclerr("inconsistent common usage", np);
299: break;
300:
301:
302: default:
303: badstg("eqvcommon", np->vstg);
304: }
305: }
306:
307: freqchain(p);
308: p->eqvbottom = p->eqvtop = 0;
309: }
310:
311:
312: /* Move all items on ovarno chain to the front of nvarno chain.
313: * adjust offsets of ovarno elements and top and bottom of nvarno chain
314: */
315:
316: LOCAL eqveqv(nvarno, ovarno, delta)
317: int ovarno, nvarno;
318: ftnint delta;
319: {
320: register struct Equivblock *neweqv, *oldeqv;
321: register Namep np;
322: struct Eqvchain *q, *q1;
323:
324: neweqv = eqvclass + nvarno;
325: oldeqv = eqvclass + ovarno;
326: neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
327: neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
328: oldeqv->eqvbottom = oldeqv->eqvtop = 0;
329:
330: for(q = oldeqv->equivs ; q ; q = q1)
331: {
332: q1 = q->eqvnextp;
333: if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
334: {
335: q->eqvnextp = neweqv->equivs;
336: neweqv->equivs = q;
337: q->eqvoffset += delta;
338: np->vardesc.varno = nvarno;
339: np->voffset -= delta;
340: }
341: else free( (charptr) q);
342: }
343: oldeqv->equivs = NULL;
344: }
345:
346:
347:
348:
349: freqchain(p)
350: register struct Equivblock *p;
351: {
352: register struct Eqvchain *q, *oq;
353:
354: for(q = p->equivs ; q ; q = oq)
355: {
356: oq = q->eqvnextp;
357: free( (charptr) q);
358: }
359: p->equivs = NULL;
360: }
361:
362:
363:
364:
365:
366: /* nsubs -- number of subscripts in this arglist (just the length of the
367: list) */
368:
369: LOCAL nsubs(p)
370: register struct Listblock *p;
371: {
372: register int n;
373: register chainp q;
374:
375: n = 0;
376: if(p)
377: for(q = p->listp ; q ; q = q->nextp)
378: ++n;
379:
380: return(n);
381: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.