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