]>
Commit | Line | Data |
---|---|---|
8e5578ea | 1 | /* equiv.c -- Implementation File (module.c template V1.0) |
2 | Copyright (C) 1995, 1996, 1997, 1998, 2003 | |
3 | Free Software Foundation, Inc. | |
4 | Contributed by James Craig Burley. | |
5 | ||
6 | This file is part of GNU Fortran. | |
7 | ||
8 | GNU Fortran is free software; you can redistribute it and/or modify | |
9 | it under the terms of the GNU General Public License as published by | |
10 | the Free Software Foundation; either version 2, or (at your option) | |
11 | any later version. | |
12 | ||
13 | GNU Fortran is distributed in the hope that it will be useful, | |
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | GNU General Public License for more details. | |
17 | ||
18 | You should have received a copy of the GNU General Public License | |
19 | along with GNU Fortran; see the file COPYING. If not, write to | |
20 | the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA | |
21 | 02111-1307, USA. | |
22 | ||
23 | Related Modules: | |
24 | None | |
25 | ||
26 | Description: | |
27 | Handles the EQUIVALENCE relationships in a program unit. | |
28 | ||
29 | Modifications: | |
30 | */ | |
31 | ||
32 | #define FFEEQUIV_DEBUG 0 | |
33 | ||
34 | /* Include files. */ | |
35 | ||
36 | #include "proj.h" | |
37 | #include "equiv.h" | |
38 | #include "bad.h" | |
39 | #include "bld.h" | |
40 | #include "com.h" | |
41 | #include "data.h" | |
42 | #include "global.h" | |
43 | #include "lex.h" | |
44 | #include "malloc.h" | |
45 | #include "symbol.h" | |
46 | ||
47 | /* Externals defined here. */ | |
48 | ||
49 | ||
50 | /* Simple definitions and enumerations. */ | |
51 | ||
52 | ||
53 | /* Internal typedefs. */ | |
54 | ||
55 | ||
56 | /* Private include files. */ | |
57 | ||
58 | ||
59 | /* Internal structure definitions. */ | |
60 | ||
61 | struct _ffeequiv_list_ | |
62 | { | |
63 | ffeequiv first; | |
64 | ffeequiv last; | |
65 | }; | |
66 | ||
67 | /* Static objects accessed by functions in this module. */ | |
68 | ||
69 | static struct _ffeequiv_list_ ffeequiv_list_; | |
70 | ||
71 | /* Static functions (internal). */ | |
72 | ||
73 | static void ffeequiv_destroy_ (ffeequiv eq); | |
74 | static void ffeequiv_layout_local_ (ffeequiv eq); | |
75 | static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s, | |
76 | ffebld expr, bool subtract, | |
77 | ffetargetOffset adjust, bool no_precede); | |
78 | ||
79 | /* Internal macros. */ | |
80 | \f | |
81 | ||
82 | static void | |
83 | ffeequiv_destroy_ (ffeequiv victim) | |
84 | { | |
85 | ffebld list; | |
86 | ffebld item; | |
87 | ffebld expr; | |
88 | ||
89 | for (list = victim->list; list != NULL; list = ffebld_trail (list)) | |
90 | { | |
91 | for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) | |
92 | { | |
93 | ffesymbol sym; | |
94 | ||
95 | expr = ffebld_head (item); | |
96 | sym = ffeequiv_symbol (expr); | |
97 | if (sym == NULL) | |
98 | continue; | |
99 | if (ffesymbol_equiv (sym) != NULL) | |
100 | ffesymbol_set_equiv (sym, NULL); | |
101 | } | |
102 | } | |
103 | ffeequiv_kill (victim); | |
104 | } | |
105 | ||
106 | /* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars | |
107 | ||
108 | ffeequiv eq; | |
109 | ffeequiv_layout_local_(eq); | |
110 | ||
111 | Makes a single master ffestorag object that contains all the vars | |
112 | in the equivalence, and makes subordinate ffestorag objects for the | |
113 | vars with the correct offsets. | |
114 | ||
115 | The resulting var offsets are relative not necessarily to 0 -- the | |
116 | are relative to the offset of the master area, which might be 0 or | |
117 | negative, but should never be positive. */ | |
118 | ||
119 | static void | |
120 | ffeequiv_layout_local_ (ffeequiv eq) | |
121 | { | |
122 | ffestorag st; /* Equivalence storage area. */ | |
123 | ffebld list; /* List of list of equivalences. */ | |
124 | ffebld item; /* List of equivalences. */ | |
125 | ffebld root_exp; /* Expression for root sym. */ | |
126 | ffestorag root_st; /* Storage for root. */ | |
127 | ffesymbol root_sym; /* Root itself. */ | |
128 | ffebld rooted_exp; /* Expression for rooted sym in an eqlist. */ | |
129 | ffestorag rooted_st; /* Storage for rooted. */ | |
130 | ffesymbol rooted_sym; /* Rooted symbol itself. */ | |
131 | ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */ | |
132 | ffetargetAlign alignment; | |
133 | ffetargetAlign modulo; | |
134 | ffetargetAlign pad; | |
135 | ffetargetOffset size; | |
136 | ffetargetOffset num_elements; | |
137 | bool new_storage; /* Established new storage info. */ | |
138 | bool need_storage; /* Have need for more storage info. */ | |
139 | bool init; | |
140 | ||
141 | assert (eq != NULL); | |
142 | ||
143 | if (ffeequiv_common (eq) != NULL) | |
144 | { /* Put in common due to programmer error. */ | |
145 | ffeequiv_destroy_ (eq); | |
146 | return; | |
147 | } | |
148 | ||
149 | /* Find the symbol for the first valid item in the list of lists, use that | |
150 | as the root symbol. Doesn't matter if it won't end up at the beginning | |
151 | of the list, though. */ | |
152 | ||
153 | #if FFEEQUIV_DEBUG | |
154 | fprintf (stderr, "Equiv1:\n"); | |
155 | #endif | |
156 | ||
157 | root_sym = NULL; | |
158 | root_exp = NULL; | |
159 | ||
160 | for (list = ffeequiv_list (eq); | |
161 | list != NULL; | |
162 | list = ffebld_trail (list)) | |
163 | { /* For every equivalence list in the list of | |
164 | equivs */ | |
165 | for (item = ffebld_head (list); | |
166 | item != NULL; | |
167 | item = ffebld_trail (item)) | |
168 | { /* For every equivalence item in the list */ | |
169 | ffetargetOffset ign; /* Ignored. */ | |
170 | ||
171 | root_exp = ffebld_head (item); | |
172 | root_sym = ffeequiv_symbol (root_exp); | |
173 | if (root_sym == NULL) | |
174 | continue; /* Ignore me. */ | |
175 | ||
176 | assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */ | |
177 | ||
178 | if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE)) | |
179 | { | |
180 | /* We can't just eliminate this one symbol from the list | |
181 | of candidates, because it might be the only one that | |
182 | ties all these equivs together. So just destroy the | |
183 | whole list. */ | |
184 | ||
185 | ffeequiv_destroy_ (eq); | |
186 | return; | |
187 | } | |
188 | ||
189 | break; /* Use first valid eqv expr for root exp/sym. */ | |
190 | } | |
191 | if (root_sym != NULL) | |
192 | break; | |
193 | } | |
194 | ||
195 | if (root_sym == NULL) | |
196 | { | |
197 | ffeequiv_destroy_ (eq); | |
198 | return; | |
199 | } | |
200 | ||
201 | ||
202 | #if FFEEQUIV_DEBUG | |
203 | fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym)); | |
204 | #endif | |
205 | ||
206 | /* We've got work to do, so make the LOCAL storage object that'll hold all | |
207 | the equivalenced vars inside it. */ | |
208 | ||
209 | st = ffestorag_new (ffestorag_list_master ()); | |
210 | ffestorag_set_parent (st, NULL); /* Initializations happen here. */ | |
211 | ffestorag_set_init (st, NULL); | |
212 | ffestorag_set_accretion (st, NULL); | |
213 | ffestorag_set_offset (st, 0); /* Assume equiv will be at root offset 0 for now. */ | |
214 | ffestorag_set_alignment (st, 1); | |
215 | ffestorag_set_modulo (st, 0); | |
216 | ffestorag_set_type (st, FFESTORAG_typeLOCAL); | |
217 | ffestorag_set_basictype (st, ffesymbol_basictype (root_sym)); | |
218 | ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym)); | |
219 | ffestorag_set_typesymbol (st, root_sym); | |
220 | ffestorag_set_is_save (st, ffeequiv_is_save (eq)); | |
221 | if (ffesymbol_is_save (root_sym)) | |
222 | ffestorag_update_save (st); | |
223 | ffestorag_set_is_init (st, ffeequiv_is_init (eq)); | |
224 | if (ffesymbol_is_init (root_sym)) | |
225 | ffestorag_update_init (st); | |
226 | ffestorag_set_symbol (st, root_sym); /* Assume this will be the root until | |
227 | we know better (used only to generate | |
228 | the internal name for the aggregate area, | |
229 | e.g. for debugging). */ | |
230 | ||
231 | /* Make the EQUIV storage object for the root symbol. */ | |
232 | ||
233 | if (ffesymbol_rank (root_sym) == 0) | |
234 | num_elements = 1; | |
235 | else | |
236 | num_elements = ffebld_constant_integerdefault (ffebld_conter | |
237 | (ffesymbol_arraysize (root_sym))); | |
238 | ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size, | |
239 | ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym), | |
240 | ffesymbol_size (root_sym), num_elements); | |
241 | ffestorag_set_size (st, size); /* Set initial size of aggregate area. */ | |
242 | ||
243 | pad = ffetarget_align (ffestorag_ptr_to_alignment (st), | |
244 | ffestorag_ptr_to_modulo (st), 0, alignment, | |
245 | modulo); | |
246 | assert (pad == 0); | |
247 | ||
248 | root_st = ffestorag_new (ffestorag_list_equivs (st)); | |
249 | ffestorag_set_parent (root_st, st); /* Initializations happen there. */ | |
250 | ffestorag_set_init (root_st, NULL); | |
251 | ffestorag_set_accretion (root_st, NULL); | |
252 | ffestorag_set_symbol (root_st, root_sym); | |
253 | ffestorag_set_size (root_st, size); | |
254 | ffestorag_set_offset (root_st, 0); /* Will not change; always 0 relative to itself! */ | |
255 | ffestorag_set_alignment (root_st, alignment); | |
256 | ffestorag_set_modulo (root_st, modulo); | |
257 | ffestorag_set_type (root_st, FFESTORAG_typeEQUIV); | |
258 | ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym)); | |
259 | ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym)); | |
260 | ffestorag_set_typesymbol (root_st, root_sym); | |
261 | ffestorag_set_is_save (root_st, FALSE); /* Assume FALSE, then... */ | |
262 | if (ffestorag_is_save (st)) /* ...update to TRUE if needed. */ | |
263 | ffestorag_update_save (root_st); | |
264 | ffestorag_set_is_init (root_st, FALSE); /* Assume FALSE, then... */ | |
265 | if (ffestorag_is_init (st)) /* ...update to TRUE if needed. */ | |
266 | ffestorag_update_init (root_st); | |
267 | ffesymbol_set_storage (root_sym, root_st); | |
268 | ffesymbol_signal_unreported (root_sym); | |
269 | init = ffesymbol_is_init (root_sym); | |
270 | ||
271 | /* Now that we know the root (offset=0) symbol, revisit all the lists and | |
272 | do the actual storage allocation. Keep doing this until we've gone | |
273 | through them all without making any new storage objects. */ | |
274 | ||
275 | do | |
276 | { | |
277 | new_storage = FALSE; | |
278 | need_storage = FALSE; | |
279 | for (list = ffeequiv_list (eq); | |
280 | list != NULL; | |
281 | list = ffebld_trail (list)) | |
282 | { /* For every equivalence list in the list of | |
283 | equivs */ | |
284 | /* Now find a "rooted" symbol in this list. That is, find the | |
285 | first item we can that is valid and whose symbol already | |
286 | has a storage area, because that means we know where it | |
287 | belongs in the equivalence area and can then allocate the | |
288 | rest of the items in the list accordingly. */ | |
289 | ||
290 | rooted_sym = NULL; | |
291 | rooted_exp = NULL; | |
292 | eqlist_offset = 0; | |
293 | ||
294 | for (item = ffebld_head (list); | |
295 | item != NULL; | |
296 | item = ffebld_trail (item)) | |
297 | { /* For every equivalence item in the list */ | |
298 | rooted_exp = ffebld_head (item); | |
299 | rooted_sym = ffeequiv_symbol (rooted_exp); | |
300 | if ((rooted_sym == NULL) | |
301 | || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL)) | |
302 | { | |
303 | rooted_sym = NULL; | |
304 | continue; /* Ignore me. */ | |
305 | } | |
306 | ||
307 | need_storage = TRUE; /* Somebody is likely to need | |
308 | storage. */ | |
309 | ||
310 | #if FFEEQUIV_DEBUG | |
311 | fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n", | |
312 | ffesymbol_text (rooted_sym), | |
313 | ffestorag_offset (rooted_st)); | |
314 | #endif | |
315 | ||
316 | /* The offset of this symbol from the equiv's root symbol | |
317 | is already known, and the size of this symbol is already | |
318 | incorporated in the size of the equiv's aggregate area. | |
319 | What we now determine is the offset of this equivalence | |
320 | _list_ from the equiv's root symbol. | |
321 | ||
322 | For example, if we know that A is at offset 16 from the | |
323 | root symbol, given EQUIVALENCE (B(24),A(2)), we're looking | |
324 | at A(2), meaning that the offset for this equivalence list | |
325 | is 20 (4 bytes beyond the beginning of A, assuming typical | |
326 | array types, dimensions, and type info). */ | |
327 | ||
328 | if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE, | |
329 | ffestorag_offset (rooted_st), FALSE)) | |
330 | ||
331 | { /* Can't use this one. */ | |
332 | ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for | |
333 | death. */ | |
334 | rooted_sym = NULL; | |
335 | continue; /* Something's wrong with eqv expr, try another. */ | |
336 | } | |
337 | ||
338 | #if FFEEQUIV_DEBUG | |
339 | fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n", | |
340 | eqlist_offset); | |
341 | #endif | |
342 | ||
343 | break; | |
344 | } | |
345 | ||
346 | /* If no rooted symbol, it means this list has no roots -- yet. | |
347 | So, forget this list this time around, but we'll get back | |
348 | to it after the outer loop iterates at least one more time, | |
349 | and, ultimately, it will have a root. */ | |
350 | ||
351 | if (rooted_sym == NULL) | |
352 | { | |
353 | #if FFEEQUIV_DEBUG | |
354 | fprintf (stderr, "No roots.\n"); | |
355 | #endif | |
356 | continue; | |
357 | } | |
358 | ||
359 | /* We now have a rooted symbol/expr and the offset of this equivalence | |
360 | list from the root symbol. The other expressions in this | |
361 | list all identify an initial storage unit that must have the | |
362 | same offset. */ | |
363 | ||
364 | for (item = ffebld_head (list); | |
365 | item != NULL; | |
366 | item = ffebld_trail (item)) | |
367 | { /* For every equivalence item in the list */ | |
368 | ffebld item_exp; /* Expression for equivalence. */ | |
369 | ffestorag item_st; /* Storage for var. */ | |
370 | ffesymbol item_sym; /* Var itself. */ | |
371 | ffetargetOffset item_offset; /* Offset for var from root. */ | |
372 | ffetargetOffset new_size; | |
373 | ||
374 | item_exp = ffebld_head (item); | |
375 | item_sym = ffeequiv_symbol (item_exp); | |
376 | if ((item_sym == NULL) | |
377 | || (ffesymbol_equiv (item_sym) == NULL)) | |
378 | continue; /* Ignore me. */ | |
379 | ||
380 | if (item_sym == rooted_sym) | |
381 | continue; /* Rooted sym already set up. */ | |
382 | ||
383 | if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE, | |
384 | eqlist_offset, FALSE)) | |
385 | { | |
386 | ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ | |
387 | continue; | |
388 | } | |
389 | ||
390 | #if FFEEQUIV_DEBUG | |
391 | fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d", | |
392 | ffesymbol_text (item_sym), item_offset); | |
393 | #endif | |
394 | ||
395 | if (ffesymbol_rank (item_sym) == 0) | |
396 | num_elements = 1; | |
397 | else | |
398 | num_elements = ffebld_constant_integerdefault (ffebld_conter | |
399 | (ffesymbol_arraysize (item_sym))); | |
400 | ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo, | |
401 | &size, ffesymbol_basictype (item_sym), | |
402 | ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym), | |
403 | num_elements); | |
404 | pad = ffetarget_align (ffestorag_ptr_to_alignment (st), | |
405 | ffestorag_ptr_to_modulo (st), | |
406 | item_offset, alignment, modulo); | |
407 | if (pad != 0) | |
408 | { | |
409 | ffebad_start (FFEBAD_EQUIV_ALIGN); | |
410 | ffebad_string (ffesymbol_text (item_sym)); | |
411 | ffebad_finish (); | |
412 | ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ | |
413 | continue; | |
414 | } | |
415 | ||
416 | /* If the variable's offset is less than the offset for the | |
417 | aggregate storage area, it means it has to expand backwards | |
418 | -- i.e. the new known starting point of the area precedes the | |
419 | old one. This can't happen with COMMON areas (the standard, | |
420 | and common sense, disallow it), but it is normal for local | |
421 | EQUIVALENCE areas. | |
422 | ||
423 | Also handle choosing the "documented" rooted symbol for this | |
424 | area here. It's the symbol at the bottom (lowest offset) | |
425 | of the aggregate area, with ties going to the name that would | |
426 | sort to the top of the list of ties. */ | |
427 | ||
428 | if (item_offset == ffestorag_offset (st)) | |
429 | { | |
430 | if ((item_sym != ffestorag_symbol (st)) | |
431 | && (strcmp (ffesymbol_text (item_sym), | |
432 | ffesymbol_text (ffestorag_symbol (st))) | |
433 | < 0)) | |
434 | ffestorag_set_symbol (st, item_sym); | |
435 | } | |
436 | else if (item_offset < ffestorag_offset (st)) | |
437 | { | |
438 | /* Increase size of equiv area to start for lower offset | |
439 | relative to root symbol. */ | |
440 | if (! ffetarget_offset_add (&new_size, | |
441 | ffestorag_offset (st) | |
442 | - item_offset, | |
443 | ffestorag_size (st))) | |
444 | ffetarget_offset_overflow (ffesymbol_text (s)); | |
445 | else | |
446 | ffestorag_set_size (st, new_size); | |
447 | ||
448 | ffestorag_set_symbol (st, item_sym); | |
449 | ffestorag_set_offset (st, item_offset); | |
450 | ||
451 | #if FFEEQUIV_DEBUG | |
452 | fprintf (stderr, " [eq offset=%" ffetargetOffset_f | |
453 | "d, size=%" ffetargetOffset_f "d]", | |
454 | item_offset, new_size); | |
455 | #endif | |
456 | } | |
457 | ||
458 | if ((item_st = ffesymbol_storage (item_sym)) == NULL) | |
459 | { /* Create new ffestorag object, extend equiv | |
460 | area. */ | |
461 | #if FFEEQUIV_DEBUG | |
462 | fprintf (stderr, ".\n"); | |
463 | #endif | |
464 | new_storage = TRUE; | |
465 | item_st = ffestorag_new (ffestorag_list_equivs (st)); | |
466 | ffestorag_set_parent (item_st, st); /* Initializations | |
467 | happen there. */ | |
468 | ffestorag_set_init (item_st, NULL); | |
469 | ffestorag_set_accretion (item_st, NULL); | |
470 | ffestorag_set_symbol (item_st, item_sym); | |
471 | ffestorag_set_size (item_st, size); | |
472 | ffestorag_set_offset (item_st, item_offset); | |
473 | ffestorag_set_alignment (item_st, alignment); | |
474 | ffestorag_set_modulo (item_st, modulo); | |
475 | ffestorag_set_type (item_st, FFESTORAG_typeEQUIV); | |
476 | ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym)); | |
477 | ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym)); | |
478 | ffestorag_set_typesymbol (item_st, item_sym); | |
479 | ffestorag_set_is_save (item_st, FALSE); /* Assume FALSE... */ | |
480 | if (ffestorag_is_save (st)) /* ...update TRUE */ | |
481 | ffestorag_update_save (item_st); /* if needed. */ | |
482 | ffestorag_set_is_init (item_st, FALSE); /* Assume FALSE... */ | |
483 | if (ffestorag_is_init (st)) /* ...update TRUE */ | |
484 | ffestorag_update_init (item_st); /* if needed. */ | |
485 | ffesymbol_set_storage (item_sym, item_st); | |
486 | ffesymbol_signal_unreported (item_sym); | |
487 | if (ffesymbol_is_init (item_sym)) | |
488 | init = TRUE; | |
489 | ||
490 | /* Determine new size of equiv area, complain if overflow. */ | |
491 | ||
492 | if (!ffetarget_offset_add (&size, item_offset, size) | |
493 | || !ffetarget_offset_add (&size, -ffestorag_offset (st), size)) | |
494 | ffetarget_offset_overflow (ffesymbol_text (s)); | |
495 | else if (size > ffestorag_size (st)) | |
496 | ffestorag_set_size (st, size); | |
497 | ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym), | |
498 | ffesymbol_kindtype (item_sym)); | |
499 | } | |
500 | else | |
501 | { | |
502 | #if FFEEQUIV_DEBUG | |
503 | fprintf (stderr, " (was %" ffetargetOffset_f "d).\n", | |
504 | ffestorag_offset (item_st)); | |
505 | #endif | |
506 | /* Make sure offset agrees with known offset. */ | |
507 | if (item_offset != ffestorag_offset (item_st)) | |
508 | { | |
509 | char io1[40]; | |
510 | char io2[40]; | |
511 | ||
512 | sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset); | |
513 | sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st)); | |
514 | ffebad_start (FFEBAD_EQUIV_MISMATCH); | |
515 | ffebad_string (ffesymbol_text (item_sym)); | |
516 | ffebad_string (ffesymbol_text (root_sym)); | |
517 | ffebad_string (io1); | |
518 | ffebad_string (io2); | |
519 | ffebad_finish (); | |
520 | } | |
521 | } | |
522 | ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ | |
523 | } /* (For every equivalence item in the list) */ | |
524 | ffebld_set_head (list, NULL); /* Don't do this list again. */ | |
525 | } /* (For every equivalence list in the list of | |
526 | equivs) */ | |
527 | } while (new_storage && need_storage); | |
528 | ||
529 | ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */ | |
530 | ||
531 | ffeequiv_kill (eq); /* Fully processed, no longer needed. */ | |
532 | ||
533 | /* If the offset for this storage area is zero (it cannot be positive), | |
534 | that means the alignment/modulo info is already correct. Otherwise, | |
535 | the alignment info is correct, but the modulo info reflects a | |
536 | zero offset, so fix it. */ | |
537 | ||
538 | if (ffestorag_offset (st) < 0) | |
539 | { | |
540 | /* Calculate the initial padding necessary to preserve | |
541 | the alignment/modulo requirements for the storage area. | |
542 | These requirements are themselves kept track of in the | |
543 | record for the storage area as a whole, but really pertain | |
544 | to offset 0 of that area, which is where the root symbol | |
545 | was originally placed. | |
546 | ||
547 | The goal here is to have the offset and size for the area | |
548 | faithfully reflect the area itself, not extra requirements | |
549 | like alignment. So to meet the alignment requirements, | |
550 | the modulo for the area should be set as if the area had an | |
551 | alignment requirement of alignment/0 and was aligned/padded | |
552 | downward to meet the alignment requirements of the area at | |
553 | offset zero, the amount of padding needed being the desired | |
554 | value for the modulo of the area. */ | |
555 | ||
556 | alignment = ffestorag_alignment (st); | |
557 | modulo = ffestorag_modulo (st); | |
558 | ||
559 | /* Since we want to move the whole area *down* (lower memory | |
560 | addresses) as required by the alignment/modulo paid, negate | |
561 | the offset to ffetarget_align, which assumes aligning *up* | |
562 | is desired. */ | |
563 | pad = ffetarget_align (&alignment, &modulo, | |
564 | - ffestorag_offset (st), | |
565 | alignment, 0); | |
566 | ffestorag_set_modulo (st, pad); | |
567 | } | |
568 | ||
569 | if (init) | |
570 | ffedata_gather (st); /* Gather subordinate inits into one init. */ | |
571 | } | |
572 | ||
573 | /* ffeequiv_offset_ -- Determine offset from start of symbol | |
574 | ||
575 | ffetargetOffset offset; | |
576 | ffesymbol s; // Symbol for error reporting. | |
577 | ffebld expr; // opSUBSTR, opARRAYREF, opSYMTER, opANY. | |
578 | bool subtract; // FALSE means add to adjust, TRUE means subtract from it. | |
579 | ffetargetOffset adjust; // Helps keep answer in pos range (unsigned). | |
580 | if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust)) | |
581 | // error doing the calculation, message already printed | |
582 | ||
583 | Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF | |
584 | combination added-to/subtracted-from the adjustment specified. If there | |
585 | is an error of some kind, returns FALSE, else returns TRUE. Note that | |
586 | only the first storage unit specified is considered; A(1:1) and A(1:2000) | |
587 | have the same first storage unit and so return the same offset. */ | |
588 | ||
589 | static bool | |
590 | ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED, | |
591 | ffebld expr, bool subtract, ffetargetOffset adjust, | |
592 | bool no_precede) | |
593 | { | |
594 | ffetargetIntegerDefault value = 0; | |
595 | ffetargetOffset cval; /* Converted value. */ | |
596 | ffesymbol sym; | |
597 | ||
598 | if (expr == NULL) | |
599 | return FALSE; | |
600 | ||
601 | again: /* :::::::::::::::::::: */ | |
602 | ||
603 | switch (ffebld_op (expr)) | |
604 | { | |
605 | case FFEBLD_opANY: | |
606 | return FALSE; | |
607 | ||
608 | case FFEBLD_opSYMTER: | |
609 | { | |
610 | ffetargetOffset size; /* Size of a single unit. */ | |
611 | ffetargetAlign a; /* Ignored. */ | |
612 | ffetargetAlign m; /* Ignored. */ | |
613 | ||
614 | sym = ffebld_symter (expr); | |
615 | if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) | |
616 | return FALSE; | |
617 | ||
618 | ffetarget_layout (ffesymbol_text (sym), &a, &m, &size, | |
619 | ffesymbol_basictype (sym), | |
620 | ffesymbol_kindtype (sym), 1, 1); | |
621 | ||
622 | if (value < 0) | |
623 | { /* Really invalid, as in A(-2:5), but in case | |
624 | it's wanted.... */ | |
625 | if (!ffetarget_offset (&cval, -value)) | |
626 | return FALSE; | |
627 | ||
628 | if (!ffetarget_offset_multiply (&cval, cval, size)) | |
629 | return FALSE; | |
630 | ||
631 | if (subtract) | |
632 | return ffetarget_offset_add (offset, cval, adjust); | |
633 | ||
634 | if (no_precede && (cval > adjust)) | |
635 | { | |
636 | neg: /* :::::::::::::::::::: */ | |
637 | ffebad_start (FFEBAD_COMMON_NEG); | |
638 | ffebad_string (ffesymbol_text (sym)); | |
639 | ffebad_finish (); | |
640 | return FALSE; | |
641 | } | |
642 | return ffetarget_offset_add (offset, -cval, adjust); | |
643 | } | |
644 | ||
645 | if (!ffetarget_offset (&cval, value)) | |
646 | return FALSE; | |
647 | ||
648 | if (!ffetarget_offset_multiply (&cval, cval, size)) | |
649 | return FALSE; | |
650 | ||
651 | if (!subtract) | |
652 | return ffetarget_offset_add (offset, cval, adjust); | |
653 | ||
654 | if (no_precede && (cval > adjust)) | |
655 | goto neg; /* :::::::::::::::::::: */ | |
656 | ||
657 | return ffetarget_offset_add (offset, -cval, adjust); | |
658 | } | |
659 | ||
660 | case FFEBLD_opARRAYREF: | |
661 | { | |
662 | ffebld symexp = ffebld_left (expr); | |
663 | ffebld subscripts = ffebld_right (expr); | |
664 | ffebld dims; | |
665 | ffetargetIntegerDefault width; | |
666 | ffetargetIntegerDefault arrayval; | |
667 | ffetargetIntegerDefault lowbound; | |
668 | ffetargetIntegerDefault highbound; | |
669 | ffebld subscript; | |
670 | ffebld dim; | |
671 | ffebld low; | |
672 | ffebld high; | |
673 | int rank = 0; | |
674 | ||
675 | if (ffebld_op (symexp) != FFEBLD_opSYMTER) | |
676 | return FALSE; | |
677 | ||
678 | sym = ffebld_symter (symexp); | |
679 | if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) | |
680 | return FALSE; | |
681 | ||
682 | if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE) | |
683 | width = 1; | |
684 | else | |
685 | width = ffesymbol_size (sym); | |
686 | dims = ffesymbol_dims (sym); | |
687 | ||
688 | while (subscripts != NULL) | |
689 | { | |
690 | ++rank; | |
691 | if (dims == NULL) | |
692 | { | |
693 | ffebad_start (FFEBAD_EQUIV_MANY); | |
694 | ffebad_string (ffesymbol_text (sym)); | |
695 | ffebad_finish (); | |
696 | return FALSE; | |
697 | } | |
698 | ||
699 | subscript = ffebld_head (subscripts); | |
700 | dim = ffebld_head (dims); | |
701 | ||
702 | if (ffebld_op (subscript) == FFEBLD_opANY) | |
703 | return FALSE; | |
704 | ||
705 | assert (ffebld_op (subscript) == FFEBLD_opCONTER); | |
706 | assert (ffeinfo_basictype (ffebld_info (subscript)) | |
707 | == FFEINFO_basictypeINTEGER); | |
708 | assert (ffeinfo_kindtype (ffebld_info (subscript)) | |
709 | == FFEINFO_kindtypeINTEGERDEFAULT); | |
710 | arrayval = ffebld_constant_integerdefault (ffebld_conter | |
711 | (subscript)); | |
712 | ||
713 | if (ffebld_op (dim) == FFEBLD_opANY) | |
714 | return FALSE; | |
715 | ||
716 | assert (ffebld_op (dim) == FFEBLD_opBOUNDS); | |
717 | low = ffebld_left (dim); | |
718 | high = ffebld_right (dim); | |
719 | ||
720 | if (low == NULL) | |
721 | lowbound = 1; | |
722 | else | |
723 | { | |
724 | if (ffebld_op (low) == FFEBLD_opANY) | |
725 | return FALSE; | |
726 | ||
727 | assert (ffebld_op (low) == FFEBLD_opCONTER); | |
728 | assert (ffeinfo_basictype (ffebld_info (low)) | |
729 | == FFEINFO_basictypeINTEGER); | |
730 | assert (ffeinfo_kindtype (ffebld_info (low)) | |
731 | == FFEINFO_kindtypeINTEGERDEFAULT); | |
732 | lowbound | |
733 | = ffebld_constant_integerdefault (ffebld_conter (low)); | |
734 | } | |
735 | ||
736 | if (ffebld_op (high) == FFEBLD_opANY) | |
737 | return FALSE; | |
738 | ||
739 | assert (ffebld_op (high) == FFEBLD_opCONTER); | |
740 | assert (ffeinfo_basictype (ffebld_info (high)) | |
741 | == FFEINFO_basictypeINTEGER); | |
742 | assert (ffeinfo_kindtype (ffebld_info (high)) | |
743 | == FFEINFO_kindtypeINTEGER1); | |
744 | highbound | |
745 | = ffebld_constant_integerdefault (ffebld_conter (high)); | |
746 | ||
747 | if ((arrayval < lowbound) || (arrayval > highbound)) | |
748 | { | |
749 | char rankstr[10]; | |
750 | ||
751 | sprintf (rankstr, "%d", rank); | |
752 | ffebad_start (FFEBAD_EQUIV_SUBSCRIPT); | |
753 | ffebad_string (ffesymbol_text (sym)); | |
754 | ffebad_string (rankstr); | |
755 | ffebad_finish (); | |
756 | } | |
757 | ||
758 | subscripts = ffebld_trail (subscripts); | |
759 | dims = ffebld_trail (dims); | |
760 | ||
761 | value += width * (arrayval - lowbound); | |
762 | if (subscripts != NULL) | |
763 | width *= highbound - lowbound + 1; | |
764 | } | |
765 | ||
766 | if (dims != NULL) | |
767 | { | |
768 | ffebad_start (FFEBAD_EQUIV_FEW); | |
769 | ffebad_string (ffesymbol_text (sym)); | |
770 | ffebad_finish (); | |
771 | return FALSE; | |
772 | } | |
773 | ||
774 | expr = symexp; | |
775 | } | |
776 | goto again; /* :::::::::::::::::::: */ | |
777 | ||
778 | case FFEBLD_opSUBSTR: | |
779 | { | |
780 | ffebld begin = ffebld_head (ffebld_right (expr)); | |
781 | ||
782 | expr = ffebld_left (expr); | |
783 | if (ffebld_op (expr) == FFEBLD_opANY) | |
784 | return FALSE; | |
785 | if (ffebld_op (expr) == FFEBLD_opARRAYREF) | |
786 | sym = ffebld_symter (ffebld_left (expr)); | |
787 | else if (ffebld_op (expr) == FFEBLD_opSYMTER) | |
788 | sym = ffebld_symter (expr); | |
789 | else | |
790 | sym = NULL; | |
791 | ||
792 | if ((sym != NULL) | |
793 | && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)) | |
794 | return FALSE; | |
795 | ||
796 | if (begin == NULL) | |
797 | value = 0; | |
798 | else | |
799 | { | |
800 | if (ffebld_op (begin) == FFEBLD_opANY) | |
801 | return FALSE; | |
802 | assert (ffebld_op (begin) == FFEBLD_opCONTER); | |
803 | assert (ffeinfo_basictype (ffebld_info (begin)) | |
804 | == FFEINFO_basictypeINTEGER); | |
805 | assert (ffeinfo_kindtype (ffebld_info (begin)) | |
806 | == FFEINFO_kindtypeINTEGERDEFAULT); | |
807 | ||
808 | value = ffebld_constant_integerdefault (ffebld_conter (begin)); | |
809 | ||
810 | if ((value < 1) | |
811 | || ((sym != NULL) | |
812 | && (value > ffesymbol_size (sym)))) | |
813 | { | |
814 | ffebad_start (FFEBAD_EQUIV_RANGE); | |
815 | ffebad_string (ffesymbol_text (sym)); | |
816 | ffebad_finish (); | |
817 | } | |
818 | ||
819 | --value; | |
820 | } | |
821 | if ((sym != NULL) | |
822 | && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER)) | |
823 | { | |
824 | ffebad_start (FFEBAD_EQUIV_SUBSTR); | |
825 | ffebad_string (ffesymbol_text (sym)); | |
826 | ffebad_finish (); | |
827 | value = 0; | |
828 | } | |
829 | } | |
830 | goto again; /* :::::::::::::::::::: */ | |
831 | ||
832 | default: | |
833 | assert ("bad op" == NULL); | |
834 | return FALSE; | |
835 | } | |
836 | ||
837 | } | |
838 | ||
839 | /* ffeequiv_add -- Add list of equivalences to list of lists for eq object | |
840 | ||
841 | ffeequiv eq; | |
842 | ffebld list; | |
843 | ffelexToken t; // points to first item in equivalence list | |
844 | ffeequiv_add(eq,list,t); | |
845 | ||
846 | Check the list to make sure only one common symbol is involved (even | |
847 | if multiple times) and agrees with the common symbol for the equivalence | |
848 | object (or it has no common symbol until now). Prepend (or append, it | |
849 | doesn't matter) the list to the list of lists for the equivalence object. | |
850 | Otherwise report an error and return. */ | |
851 | ||
852 | void | |
853 | ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t) | |
854 | { | |
855 | ffebld item; | |
856 | ffesymbol symbol; | |
857 | ffesymbol common = ffeequiv_common (eq); | |
858 | ||
859 | for (item = list; item != NULL; item = ffebld_trail (item)) | |
860 | { | |
861 | symbol = ffeequiv_symbol (ffebld_head (item)); | |
862 | ||
863 | if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */ | |
864 | { | |
865 | if (common == NULL) | |
866 | common = ffesymbol_common (symbol); | |
867 | else if (common != ffesymbol_common (symbol)) | |
868 | { | |
869 | /* Yes, and symbol disagrees with others on the COMMON area. */ | |
870 | ffebad_start (FFEBAD_EQUIV_COMMON); | |
871 | ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); | |
872 | ffebad_string (ffesymbol_text (common)); | |
873 | ffebad_string (ffesymbol_text (ffesymbol_common (symbol))); | |
874 | ffebad_finish (); | |
875 | return; | |
876 | } | |
877 | } | |
878 | } | |
879 | ||
880 | if ((common != NULL) | |
881 | && (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */ | |
882 | ffeequiv_set_common (eq, common); /* No, but it is now. */ | |
883 | ||
884 | for (item = list; item != NULL; item = ffebld_trail (item)) | |
885 | { | |
886 | symbol = ffeequiv_symbol (ffebld_head (item)); | |
887 | ||
888 | if (ffesymbol_equiv (symbol) == NULL) | |
889 | ffesymbol_set_equiv (symbol, eq); | |
890 | else | |
891 | assert (ffesymbol_equiv (symbol) == eq); | |
892 | ||
893 | if (ffesymbol_common (symbol) == NULL) /* Is symbol in a COMMON | |
894 | area? */ | |
895 | { /* No (at least not yet). */ | |
896 | if (ffesymbol_is_save (symbol)) | |
897 | ffeequiv_update_save (eq); /* EQUIVALENCE has >=1 SAVEd entity. */ | |
898 | if (ffesymbol_is_init (symbol)) | |
899 | ffeequiv_update_init (eq); /* EQUIVALENCE has >=1 init'd entity. */ | |
900 | continue; /* Nothing more to do here. */ | |
901 | } | |
902 | ||
903 | #if FFEGLOBAL_ENABLED | |
904 | if (ffesymbol_is_init (symbol)) | |
905 | ffeglobal_init_common (ffesymbol_common (symbol), t); | |
906 | #endif | |
907 | ||
908 | if (ffesymbol_is_save (ffesymbol_common (symbol))) | |
909 | ffeequiv_update_save (eq); /* EQUIVALENCE is in a SAVEd COMMON block. */ | |
910 | if (ffesymbol_is_init (ffesymbol_common (symbol))) | |
911 | ffeequiv_update_init (eq); /* EQUIVALENCE is in a init'd COMMON block. */ | |
912 | } | |
913 | ||
914 | ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq))); | |
915 | } | |
916 | ||
917 | /* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects | |
918 | ||
919 | ffeequiv_exec_transition(); */ | |
920 | ||
921 | void | |
922 | ffeequiv_exec_transition (void) | |
923 | { | |
924 | while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first) | |
925 | ffeequiv_layout_local_ (ffeequiv_list_.first); | |
926 | } | |
927 | ||
928 | /* ffeequiv_init_2 -- Initialize for new program unit | |
929 | ||
930 | ffeequiv_init_2(); | |
931 | ||
932 | Initializes the list of equivalences. */ | |
933 | ||
934 | void | |
935 | ffeequiv_init_2 (void) | |
936 | { | |
937 | ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first; | |
938 | ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first; | |
939 | } | |
940 | ||
941 | /* ffeequiv_kill -- Kill equivalence object after removing from list | |
942 | ||
943 | ffeequiv eq; | |
944 | ffeequiv_kill(eq); | |
945 | ||
946 | Removes equivalence object from master list, then kills it. */ | |
947 | ||
948 | void | |
949 | ffeequiv_kill (ffeequiv victim) | |
950 | { | |
951 | victim->next->previous = victim->previous; | |
952 | victim->previous->next = victim->next; | |
953 | if (ffe_is_do_internal_checks ()) | |
954 | { | |
955 | ffebld list; | |
956 | ffebld item; | |
957 | ffebld expr; | |
958 | ||
959 | /* Assert that nobody our victim points to still points to it. */ | |
960 | ||
961 | assert ((victim->common == NULL) | |
962 | || (ffesymbol_equiv (victim->common) == NULL)); | |
963 | ||
964 | for (list = victim->list; list != NULL; list = ffebld_trail (list)) | |
965 | { | |
966 | for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) | |
967 | { | |
968 | ffesymbol sym; | |
969 | ||
970 | expr = ffebld_head (item); | |
971 | sym = ffeequiv_symbol (expr); | |
972 | if (sym == NULL) | |
973 | continue; | |
974 | assert (ffesymbol_equiv (sym) != victim); | |
975 | } | |
976 | } | |
977 | } | |
978 | malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim)); | |
979 | } | |
980 | ||
981 | /* ffeequiv_layout_cblock -- Lay out storage for common area | |
982 | ||
983 | ffestorag st; | |
984 | if (ffeequiv_layout_cblock(st)) | |
985 | // at least one equiv'd symbol has init/accretion expr. | |
986 | ||
987 | Now that the explicitly COMMONed variables in the common area (whose | |
988 | ffestorag object is passed) have been laid out, lay out the storage | |
989 | for all variables equivalenced into the area by making subordinate | |
990 | ffestorag objects for them. */ | |
991 | ||
992 | bool | |
993 | ffeequiv_layout_cblock (ffestorag st) | |
994 | { | |
995 | ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */ | |
996 | ffebld list; /* List of explicit common vars, in order, in | |
997 | s. */ | |
998 | ffebld item; /* List of list of equivalences in a given | |
999 | explicit common var. */ | |
1000 | ffebld root; /* Expression for (1st) explicit common var | |
1001 | in list of eqs. */ | |
1002 | ffestorag rst; /* Storage for root. */ | |
1003 | ffetargetOffset root_offset; /* Offset for root into common area. */ | |
1004 | ffesymbol sr; /* Root itself. */ | |
1005 | ffeequiv seq; /* Its equivalence object, if any. */ | |
1006 | ffebld var; /* Expression for equivalence. */ | |
1007 | ffestorag vst; /* Storage for var. */ | |
1008 | ffetargetOffset var_offset; /* Offset for var into common area. */ | |
1009 | ffesymbol sv; /* Var itself. */ | |
1010 | ffebld altroot; /* Alternate root. */ | |
1011 | ffesymbol altrootsym; /* Alternate root symbol. */ | |
1012 | ffetargetAlign alignment; | |
1013 | ffetargetAlign modulo; | |
1014 | ffetargetAlign pad; | |
1015 | ffetargetOffset size; | |
1016 | ffetargetOffset num_elements; | |
1017 | bool new_storage; /* Established new storage info. */ | |
1018 | bool need_storage; /* Have need for more storage info. */ | |
1019 | bool ok; | |
1020 | bool init = FALSE; | |
1021 | ||
1022 | assert (st != NULL); | |
1023 | assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK); | |
1024 | assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON); | |
1025 | ||
1026 | for (list = ffesymbol_commonlist (ffestorag_symbol (st)); | |
1027 | list != NULL; | |
1028 | list = ffebld_trail (list)) | |
1029 | { /* For every variable in the common area */ | |
1030 | assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER); | |
1031 | sr = ffebld_symter (ffebld_head (list)); | |
1032 | if ((seq = ffesymbol_equiv (sr)) == NULL) | |
1033 | continue; /* No equivalences to process. */ | |
1034 | rst = ffesymbol_storage (sr); | |
1035 | if (rst == NULL) | |
1036 | { | |
1037 | assert (ffesymbol_kind (sr) == FFEINFO_kindANY); | |
1038 | continue; | |
1039 | } | |
1040 | ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */ | |
1041 | do | |
1042 | { | |
1043 | new_storage = FALSE; | |
1044 | need_storage = FALSE; | |
1045 | for (item = ffeequiv_list (seq); /* Get list of equivs. */ | |
1046 | item != NULL; | |
1047 | item = ffebld_trail (item)) | |
1048 | { /* For every eqv list in the list of equivs | |
1049 | for the variable */ | |
1050 | altroot = NULL; | |
1051 | altrootsym = NULL; | |
1052 | for (root = ffebld_head (item); | |
1053 | root != NULL; | |
1054 | root = ffebld_trail (root)) | |
1055 | { /* For every equivalence item in the list */ | |
1056 | sv = ffeequiv_symbol (ffebld_head (root)); | |
1057 | if (sv == sr) | |
1058 | break; /* Found first mention of "rooted" symbol. */ | |
1059 | if (ffesymbol_storage (sv) != NULL) | |
1060 | { | |
1061 | altroot = root; /* If no mention, use this guy | |
1062 | instead. */ | |
1063 | altrootsym = sv; | |
1064 | } | |
1065 | } | |
1066 | if (root != NULL) | |
1067 | { | |
1068 | root = ffebld_head (root); /* Lose its opITEM. */ | |
1069 | ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE, | |
1070 | ffestorag_offset (rst), TRUE); | |
1071 | /* Equiv point prior to start of common area? */ | |
1072 | } | |
1073 | else if (altroot != NULL) | |
1074 | { | |
1075 | /* Equiv point prior to start of common area? */ | |
1076 | root = ffebld_head (altroot); | |
1077 | ok = ffeequiv_offset_ (&root_offset, altrootsym, root, | |
1078 | FALSE, | |
1079 | ffestorag_offset (ffesymbol_storage (altrootsym)), | |
1080 | TRUE); | |
1081 | ffesymbol_set_equiv (altrootsym, NULL); | |
1082 | } | |
1083 | else | |
1084 | /* No rooted symbol in list of equivalences! */ | |
1085 | { /* Assume this was due to opANY and ignore | |
1086 | this list for now. */ | |
1087 | need_storage = TRUE; | |
1088 | continue; | |
1089 | } | |
1090 | ||
1091 | /* We now know the root symbol and the operating offset of that | |
1092 | root into the common area. The other expressions in the | |
1093 | list all identify an initial storage unit that must have the | |
1094 | same offset. */ | |
1095 | ||
1096 | for (var = ffebld_head (item); | |
1097 | var != NULL; | |
1098 | var = ffebld_trail (var)) | |
1099 | { /* For every equivalence item in the list */ | |
1100 | if (ffebld_head (var) == root) | |
1101 | continue; /* Except root, of course. */ | |
1102 | sv = ffeequiv_symbol (ffebld_head (var)); | |
1103 | if (sv == NULL) | |
1104 | continue; /* Except erroneous stuff (opANY). */ | |
1105 | ffesymbol_set_equiv (sv, NULL); /* Don't need this ref | |
1106 | anymore. */ | |
1107 | if (!ok | |
1108 | || !ffeequiv_offset_ (&var_offset, sv, | |
1109 | ffebld_head (var), TRUE, | |
1110 | root_offset, TRUE)) | |
1111 | continue; /* Can't do negative offset wrt COMMON. */ | |
1112 | ||
1113 | if (ffesymbol_rank (sv) == 0) | |
1114 | num_elements = 1; | |
1115 | else | |
1116 | num_elements = ffebld_constant_integerdefault | |
1117 | (ffebld_conter (ffesymbol_arraysize (sv))); | |
1118 | ffetarget_layout (ffesymbol_text (sv), &alignment, | |
1119 | &modulo, &size, | |
1120 | ffesymbol_basictype (sv), | |
1121 | ffesymbol_kindtype (sv), | |
1122 | ffesymbol_size (sv), num_elements); | |
1123 | pad = ffetarget_align (ffestorag_ptr_to_alignment (st), | |
1124 | ffestorag_ptr_to_modulo (st), | |
1125 | var_offset, alignment, modulo); | |
1126 | if (pad != 0) | |
1127 | { | |
1128 | ffebad_start (FFEBAD_EQUIV_ALIGN); | |
1129 | ffebad_string (ffesymbol_text (sv)); | |
1130 | ffebad_finish (); | |
1131 | continue; | |
1132 | } | |
1133 | ||
1134 | if ((vst = ffesymbol_storage (sv)) == NULL) | |
1135 | { /* Create new ffestorag object, extend | |
1136 | cblock. */ | |
1137 | new_storage = TRUE; | |
1138 | vst = ffestorag_new (ffestorag_list_equivs (st)); | |
1139 | ffestorag_set_parent (vst, st); /* Initializations | |
1140 | happen there. */ | |
1141 | ffestorag_set_init (vst, NULL); | |
1142 | ffestorag_set_accretion (vst, NULL); | |
1143 | ffestorag_set_symbol (vst, sv); | |
1144 | ffestorag_set_size (vst, size); | |
1145 | ffestorag_set_offset (vst, var_offset); | |
1146 | ffestorag_set_alignment (vst, alignment); | |
1147 | ffestorag_set_modulo (vst, modulo); | |
1148 | ffestorag_set_type (vst, FFESTORAG_typeEQUIV); | |
1149 | ffestorag_set_basictype (vst, ffesymbol_basictype (sv)); | |
1150 | ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv)); | |
1151 | ffestorag_set_typesymbol (vst, sv); | |
1152 | ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */ | |
1153 | if (ffestorag_is_save (st)) /* ...update TRUE */ | |
1154 | ffestorag_update_save (vst); /* if needed. */ | |
1155 | ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */ | |
1156 | if (ffestorag_is_init (st)) /* ...update TRUE */ | |
1157 | ffestorag_update_init (vst); /* if needed. */ | |
1158 | if (!ffetarget_offset_add (&size, var_offset, size)) | |
1159 | /* Find one size of common block, complain if | |
1160 | overflow. */ | |
1161 | ffetarget_offset_overflow (ffesymbol_text (s)); | |
1162 | else if (size > ffestorag_size (st)) | |
1163 | /* Extend common. */ | |
1164 | ffestorag_set_size (st, size); | |
1165 | ffesymbol_set_storage (sv, vst); | |
1166 | ffesymbol_set_common (sv, s); | |
1167 | ffesymbol_signal_unreported (sv); | |
1168 | ffestorag_update (st, sv, ffesymbol_basictype (sv), | |
1169 | ffesymbol_kindtype (sv)); | |
1170 | if (ffesymbol_is_init (sv)) | |
1171 | init = TRUE; | |
1172 | } | |
1173 | else | |
1174 | { | |
1175 | /* Make sure offset agrees with known offset. */ | |
1176 | if (var_offset != ffestorag_offset (vst)) | |
1177 | { | |
1178 | char io1[40]; | |
1179 | char io2[40]; | |
1180 | ||
1181 | sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset); | |
1182 | sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst)); | |
1183 | ffebad_start (FFEBAD_EQUIV_MISMATCH); | |
1184 | ffebad_string (ffesymbol_text (sv)); | |
1185 | ffebad_string (ffesymbol_text (s)); | |
1186 | ffebad_string (io1); | |
1187 | ffebad_string (io2); | |
1188 | ffebad_finish (); | |
1189 | } | |
1190 | } | |
1191 | } /* (For every equivalence item in the list) */ | |
1192 | } /* (For every eqv list in the list of equivs | |
1193 | for the variable) */ | |
1194 | } | |
1195 | while (new_storage && need_storage); | |
1196 | ||
1197 | ffeequiv_kill (seq); /* Kill equiv obj. */ | |
1198 | } /* (For every variable in the common area) */ | |
1199 | ||
1200 | return init; | |
1201 | } | |
1202 | ||
1203 | /* ffeequiv_merge -- Merge two equivalence objects, return the merged result | |
1204 | ||
1205 | ffeequiv eq1; | |
1206 | ffeequiv eq2; | |
1207 | ffelexToken t; // points to current equivalence item forcing the merge. | |
1208 | eq1 = ffeequiv_merge(eq1,eq2,t); | |
1209 | ||
1210 | If the two equivalence objects can be merged, they are, all the | |
1211 | ffesymbols in their lists of lists are adjusted to point to the merged | |
1212 | equivalence object, and the merged object is returned. | |
1213 | ||
1214 | Otherwise, the two equivalence objects have different non-NULL common | |
1215 | symbols, so the merge cannot take place. An error message is issued and | |
1216 | NULL is returned. */ | |
1217 | ||
1218 | ffeequiv | |
1219 | ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t) | |
1220 | { | |
1221 | ffebld list; | |
1222 | ffebld eqs; | |
1223 | ffesymbol symbol; | |
1224 | ffebld last = NULL; | |
1225 | ||
1226 | /* If both equivalence objects point to different common-based symbols, | |
1227 | complain. Of course, one or both might have NULL common symbols now, | |
1228 | and get COMMONed later, but the COMMON statement handler checks for | |
1229 | this. */ | |
1230 | ||
1231 | if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL) | |
1232 | && (ffeequiv_common (eq1) != ffeequiv_common (eq2))) | |
1233 | { | |
1234 | ffebad_start (FFEBAD_EQUIV_COMMON); | |
1235 | ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); | |
1236 | ffebad_string (ffesymbol_text (ffeequiv_common (eq1))); | |
1237 | ffebad_string (ffesymbol_text (ffeequiv_common (eq2))); | |
1238 | ffebad_finish (); | |
1239 | return NULL; | |
1240 | } | |
1241 | ||
1242 | /* Make eq1 the new, merged object (arbitrarily). */ | |
1243 | ||
1244 | if (ffeequiv_common (eq1) == NULL) | |
1245 | ffeequiv_set_common (eq1, ffeequiv_common (eq2)); | |
1246 | ||
1247 | /* If the victim object has any init'ed entities, so does the new object. */ | |
1248 | ||
1249 | if (eq2->is_init) | |
1250 | eq1->is_init = TRUE; | |
1251 | ||
1252 | #if FFEGLOBAL_ENABLED | |
1253 | if (eq1->is_init && (ffeequiv_common (eq1) != NULL)) | |
1254 | ffeglobal_init_common (ffeequiv_common (eq1), t); | |
1255 | #endif | |
1256 | ||
1257 | /* If the victim object has any SAVEd entities, then the new object has | |
1258 | some. */ | |
1259 | ||
1260 | if (ffeequiv_is_save (eq2)) | |
1261 | ffeequiv_update_save (eq1); | |
1262 | ||
1263 | /* If the victim object has any init'd entities, then the new object has | |
1264 | some. */ | |
1265 | ||
1266 | if (ffeequiv_is_init (eq2)) | |
1267 | ffeequiv_update_init (eq1); | |
1268 | ||
1269 | /* Adjust all the symbols in the list of lists of equivalences for the | |
1270 | victim equivalence object so they point to the new merged object | |
1271 | instead. */ | |
1272 | ||
1273 | for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list)) | |
1274 | { | |
1275 | for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs)) | |
1276 | { | |
1277 | symbol = ffeequiv_symbol (ffebld_head (eqs)); | |
1278 | if (ffesymbol_equiv (symbol) == eq2) | |
1279 | ffesymbol_set_equiv (symbol, eq1); | |
1280 | else | |
1281 | assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */ | |
1282 | } | |
1283 | ||
1284 | /* For convenience, remember where the last ITEM in the outer list is. */ | |
1285 | ||
1286 | if (ffebld_trail (list) == NULL) | |
1287 | { | |
1288 | last = list; | |
1289 | break; | |
1290 | } | |
1291 | } | |
1292 | ||
1293 | /* Append the list of lists in the new, merged object to the list of lists | |
1294 | in the victim object, then use the new combined list in the new merged | |
1295 | object. */ | |
1296 | ||
1297 | ffebld_set_trail (last, ffeequiv_list (eq1)); | |
1298 | ffeequiv_set_list (eq1, ffeequiv_list (eq2)); | |
1299 | ||
1300 | /* Unlink and kill the victim object. */ | |
1301 | ||
1302 | ffeequiv_kill (eq2); | |
1303 | ||
1304 | return eq1; /* Return the new merged object. */ | |
1305 | } | |
1306 | ||
1307 | /* ffeequiv_new -- Create new equivalence object, put in list | |
1308 | ||
1309 | ffeequiv eq; | |
1310 | eq = ffeequiv_new(); | |
1311 | ||
1312 | Creates a new equivalence object and adds it to the list of equivalence | |
1313 | objects. */ | |
1314 | ||
1315 | ffeequiv | |
1316 | ffeequiv_new (void) | |
1317 | { | |
1318 | ffeequiv eq; | |
1319 | ||
1320 | eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq)); | |
1321 | eq->next = (ffeequiv) &ffeequiv_list_.first; | |
1322 | eq->previous = ffeequiv_list_.last; | |
1323 | ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */ | |
1324 | ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */ | |
1325 | ffeequiv_set_is_save (eq, FALSE); | |
1326 | ffeequiv_set_is_init (eq, FALSE); | |
1327 | eq->next->previous = eq; | |
1328 | eq->previous->next = eq; | |
1329 | ||
1330 | return eq; | |
1331 | } | |
1332 | ||
1333 | /* ffeequiv_symbol -- Return symbol for equivalence expression | |
1334 | ||
1335 | ffesymbol symbol; | |
1336 | ffebld expr; | |
1337 | symbol = ffeequiv_symbol(expr); | |
1338 | ||
1339 | Finds the terminal SYMTER in an equivalence expression and returns the | |
1340 | ffesymbol for it. */ | |
1341 | ||
1342 | ffesymbol | |
1343 | ffeequiv_symbol (ffebld expr) | |
1344 | { | |
1345 | assert (expr != NULL); | |
1346 | ||
1347 | again: /* :::::::::::::::::::: */ | |
1348 | ||
1349 | switch (ffebld_op (expr)) | |
1350 | { | |
1351 | case FFEBLD_opARRAYREF: | |
1352 | case FFEBLD_opSUBSTR: | |
1353 | expr = ffebld_left (expr); | |
1354 | goto again; /* :::::::::::::::::::: */ | |
1355 | ||
1356 | case FFEBLD_opSYMTER: | |
1357 | return ffebld_symter (expr); | |
1358 | ||
1359 | case FFEBLD_opANY: | |
1360 | return NULL; | |
1361 | ||
1362 | default: | |
1363 | assert ("bad eq expr" == NULL); | |
1364 | return NULL; | |
1365 | } | |
1366 | } | |
1367 | ||
1368 | /* ffeequiv_update_init -- Update the INIT flag for the area to TRUE | |
1369 | ||
1370 | ffeequiv eq; | |
1371 | ffeequiv_update_init(eq); | |
1372 | ||
1373 | If the INIT flag for the <eq> object is already set, return. Else, | |
1374 | set it TRUE and call ffe*_update_init for all objects contained in | |
1375 | this one. */ | |
1376 | ||
1377 | void | |
1378 | ffeequiv_update_init (ffeequiv eq) | |
1379 | { | |
1380 | ffebld list; /* Current list in list of lists. */ | |
1381 | ffebld item; /* Current item in current list. */ | |
1382 | ffebld expr; /* Expression in head of current item. */ | |
1383 | ||
1384 | if (eq->is_init) | |
1385 | return; | |
1386 | ||
1387 | eq->is_init = TRUE; | |
1388 | ||
1389 | if ((eq->common != NULL) | |
1390 | && !ffesymbol_is_init (eq->common)) | |
1391 | ffesymbol_update_init (eq->common); /* Shouldn't be needed. */ | |
1392 | ||
1393 | for (list = eq->list; list != NULL; list = ffebld_trail (list)) | |
1394 | { | |
1395 | for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) | |
1396 | { | |
1397 | expr = ffebld_head (item); | |
1398 | ||
1399 | again: /* :::::::::::::::::::: */ | |
1400 | ||
1401 | switch (ffebld_op (expr)) | |
1402 | { | |
1403 | case FFEBLD_opANY: | |
1404 | break; | |
1405 | ||
1406 | case FFEBLD_opSYMTER: | |
1407 | if (!ffesymbol_is_init (ffebld_symter (expr))) | |
1408 | ffesymbol_update_init (ffebld_symter (expr)); | |
1409 | break; | |
1410 | ||
1411 | case FFEBLD_opARRAYREF: | |
1412 | expr = ffebld_left (expr); | |
1413 | goto again; /* :::::::::::::::::::: */ | |
1414 | ||
1415 | case FFEBLD_opSUBSTR: | |
1416 | expr = ffebld_left (expr); | |
1417 | goto again; /* :::::::::::::::::::: */ | |
1418 | ||
1419 | default: | |
1420 | assert ("bad op for ffeequiv_update_init" == NULL); | |
1421 | break; | |
1422 | } | |
1423 | } | |
1424 | } | |
1425 | } | |
1426 | ||
1427 | /* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE | |
1428 | ||
1429 | ffeequiv eq; | |
1430 | ffeequiv_update_save(eq); | |
1431 | ||
1432 | If the SAVE flag for the <eq> object is already set, return. Else, | |
1433 | set it TRUE and call ffe*_update_save for all objects contained in | |
1434 | this one. */ | |
1435 | ||
1436 | void | |
1437 | ffeequiv_update_save (ffeequiv eq) | |
1438 | { | |
1439 | ffebld list; /* Current list in list of lists. */ | |
1440 | ffebld item; /* Current item in current list. */ | |
1441 | ffebld expr; /* Expression in head of current item. */ | |
1442 | ||
1443 | if (eq->is_save) | |
1444 | return; | |
1445 | ||
1446 | eq->is_save = TRUE; | |
1447 | ||
1448 | if ((eq->common != NULL) | |
1449 | && !ffesymbol_is_save (eq->common)) | |
1450 | ffesymbol_update_save (eq->common); /* Shouldn't be needed. */ | |
1451 | ||
1452 | for (list = eq->list; list != NULL; list = ffebld_trail (list)) | |
1453 | { | |
1454 | for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) | |
1455 | { | |
1456 | expr = ffebld_head (item); | |
1457 | ||
1458 | again: /* :::::::::::::::::::: */ | |
1459 | ||
1460 | switch (ffebld_op (expr)) | |
1461 | { | |
1462 | case FFEBLD_opANY: | |
1463 | break; | |
1464 | ||
1465 | case FFEBLD_opSYMTER: | |
1466 | if (!ffesymbol_is_save (ffebld_symter (expr))) | |
1467 | ffesymbol_update_save (ffebld_symter (expr)); | |
1468 | break; | |
1469 | ||
1470 | case FFEBLD_opARRAYREF: | |
1471 | expr = ffebld_left (expr); | |
1472 | goto again; /* :::::::::::::::::::: */ | |
1473 | ||
1474 | case FFEBLD_opSUBSTR: | |
1475 | expr = ffebld_left (expr); | |
1476 | goto again; /* :::::::::::::::::::: */ | |
1477 | ||
1478 | default: | |
1479 | assert ("bad op for ffeequiv_update_save" == NULL); | |
1480 | break; | |
1481 | } | |
1482 | } | |
1483 | } | |
1484 | } |