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