* config/i386/i386.md (mmx_pinsrw): Output operands in correct
[official-gcc.git] / gcc / f / equiv.c
blob54dc12bf71976f72d56e5f5bf791c93c7137e253
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.
5 This file is part of GNU Fortran.
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.
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.
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.
22 Related Modules:
23 None
25 Description:
26 Handles the EQUIVALENCE relationships in a program unit.
28 Modifications:
31 #define FFEEQUIV_DEBUG 0
33 /* Include files. */
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"
46 /* Externals defined here. */
49 /* Simple definitions and enumerations. */
52 /* Internal typedefs. */
55 /* Private include files. */
58 /* Internal structure definitions. */
60 struct _ffeequiv_list_
62 ffeequiv first;
63 ffeequiv last;
66 /* Static objects accessed by functions in this module. */
68 static struct _ffeequiv_list_ ffeequiv_list_;
70 /* Static functions (internal). */
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);
78 /* Internal macros. */
81 static void
82 ffeequiv_destroy_ (ffeequiv victim)
84 ffebld list;
85 ffebld item;
86 ffebld expr;
88 for (list = victim->list; list != NULL; list = ffebld_trail (list))
90 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
92 ffesymbol sym;
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);
102 ffeequiv_kill (victim);
105 /* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars
107 ffeequiv eq;
108 ffeequiv_layout_local_(eq);
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.
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. */
118 static void
119 ffeequiv_layout_local_ (ffeequiv eq)
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;
140 assert (eq != NULL);
142 if (ffeequiv_common (eq) != NULL)
143 { /* Put in common due to programmer error. */
144 ffeequiv_destroy_ (eq);
145 return;
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. */
152 #if FFEEQUIV_DEBUG
153 fprintf (stderr, "Equiv1:\n");
154 #endif
156 root_sym = NULL;
157 root_exp = NULL;
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. */
170 root_exp = ffebld_head (item);
171 root_sym = ffeequiv_symbol (root_exp);
172 if (root_sym == NULL)
173 continue; /* Ignore me. */
175 assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */
177 if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
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. */
184 ffeequiv_destroy_ (eq);
185 return;
188 break; /* Use first valid eqv expr for root exp/sym. */
190 if (root_sym != NULL)
191 break;
194 if (root_sym == NULL)
196 ffeequiv_destroy_ (eq);
197 return;
201 #if FFEEQUIV_DEBUG
202 fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym));
203 #endif
205 /* We've got work to do, so make the LOCAL storage object that'll hold all
206 the equivalenced vars inside it. */
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). */
230 /* Make the EQUIV storage object for the root symbol. */
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. */
242 pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
243 ffestorag_ptr_to_modulo (st), 0, alignment,
244 modulo);
245 assert (pad == 0);
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);
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. */
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. */
289 rooted_sym = NULL;
290 rooted_exp = NULL;
291 eqlist_offset = 0;
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))
302 rooted_sym = NULL;
303 continue; /* Ignore me. */
306 need_storage = TRUE; /* Somebody is likely to need
307 storage. */
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
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.
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). */
327 if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
328 ffestorag_offset (rooted_st), FALSE))
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. */
337 #if FFEEQUIV_DEBUG
338 fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n",
339 eqlist_offset);
340 #endif
342 break;
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. */
350 if (rooted_sym == NULL)
352 #if FFEEQUIV_DEBUG
353 fprintf (stderr, "No roots.\n");
354 #endif
355 continue;
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. */
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;
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. */
379 if (item_sym == rooted_sym)
380 continue; /* Rooted sym already set up. */
382 if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
383 eqlist_offset, FALSE))
385 ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
386 continue;
389 #if FFEEQUIV_DEBUG
390 fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d",
391 ffesymbol_text (item_sym), item_offset);
392 #endif
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)
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;
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.
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. */
427 if (item_offset == ffestorag_offset (st))
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);
435 else if (item_offset < ffestorag_offset (st))
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);
447 ffestorag_set_symbol (st, item_sym);
448 ffestorag_set_offset (st, item_offset);
450 #if FFEEQUIV_DEBUG
451 fprintf (stderr, " [eq offset=%" ffetargetOffset_f
452 "d, size=%" ffetargetOffset_f "d]",
453 item_offset, new_size);
454 #endif
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;
489 /* Determine new size of equiv area, complain if overflow. */
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));
499 else
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))
508 char io1[40];
509 char io2[40];
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 ();
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);
528 ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */
530 ffeequiv_kill (eq); /* Fully processed, no longer needed. */
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. */
537 if (ffestorag_offset (st) < 0)
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.
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. */
555 alignment = ffestorag_alignment (st);
556 modulo = ffestorag_modulo (st);
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);
568 if (init)
569 ffedata_gather (st); /* Gather subordinate inits into one init. */
572 /* ffeequiv_offset_ -- Determine offset from start of symbol
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
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. */
588 static bool
589 ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
590 ffebld expr, bool subtract, ffetargetOffset adjust,
591 bool no_precede)
593 ffetargetIntegerDefault value = 0;
594 ffetargetOffset cval; /* Converted value. */
595 ffesymbol sym;
597 if (expr == NULL)
598 return FALSE;
600 again: /* :::::::::::::::::::: */
602 switch (ffebld_op (expr))
604 case FFEBLD_opANY:
605 return FALSE;
607 case FFEBLD_opSYMTER:
609 ffetargetOffset size; /* Size of a single unit. */
610 ffetargetAlign a; /* Ignored. */
611 ffetargetAlign m; /* Ignored. */
613 sym = ffebld_symter (expr);
614 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
615 return FALSE;
617 ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
618 ffesymbol_basictype (sym),
619 ffesymbol_kindtype (sym), 1, 1);
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;
627 if (!ffetarget_offset_multiply (&cval, cval, size))
628 return FALSE;
630 if (subtract)
631 return ffetarget_offset_add (offset, cval, adjust);
633 if (no_precede && (cval > adjust))
635 neg: /* :::::::::::::::::::: */
636 ffebad_start (FFEBAD_COMMON_NEG);
637 ffebad_string (ffesymbol_text (sym));
638 ffebad_finish ();
639 return FALSE;
641 return ffetarget_offset_add (offset, -cval, adjust);
644 if (!ffetarget_offset (&cval, value))
645 return FALSE;
647 if (!ffetarget_offset_multiply (&cval, cval, size))
648 return FALSE;
650 if (!subtract)
651 return ffetarget_offset_add (offset, cval, adjust);
653 if (no_precede && (cval > adjust))
654 goto neg; /* :::::::::::::::::::: */
656 return ffetarget_offset_add (offset, -cval, adjust);
659 case FFEBLD_opARRAYREF:
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;
674 if (ffebld_op (symexp) != FFEBLD_opSYMTER)
675 return FALSE;
677 sym = ffebld_symter (symexp);
678 if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
679 return FALSE;
681 if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
682 width = 1;
683 else
684 width = ffesymbol_size (sym);
685 dims = ffesymbol_dims (sym);
687 while (subscripts != NULL)
689 ++rank;
690 if (dims == NULL)
692 ffebad_start (FFEBAD_EQUIV_MANY);
693 ffebad_string (ffesymbol_text (sym));
694 ffebad_finish ();
695 return FALSE;
698 subscript = ffebld_head (subscripts);
699 dim = ffebld_head (dims);
701 if (ffebld_op (subscript) == FFEBLD_opANY)
702 return FALSE;
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));
712 if (ffebld_op (dim) == FFEBLD_opANY)
713 return FALSE;
715 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
716 low = ffebld_left (dim);
717 high = ffebld_right (dim);
719 if (low == NULL)
720 lowbound = 1;
721 else
723 if (ffebld_op (low) == FFEBLD_opANY)
724 return FALSE;
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));
735 if (ffebld_op (high) == FFEBLD_opANY)
736 return FALSE;
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));
746 if ((arrayval < lowbound) || (arrayval > highbound))
748 char rankstr[10];
750 sprintf (rankstr, "%d", rank);
751 ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
752 ffebad_string (ffesymbol_text (sym));
753 ffebad_string (rankstr);
754 ffebad_finish ();
757 subscripts = ffebld_trail (subscripts);
758 dims = ffebld_trail (dims);
760 value += width * (arrayval - lowbound);
761 if (subscripts != NULL)
762 width *= highbound - lowbound + 1;
765 if (dims != NULL)
767 ffebad_start (FFEBAD_EQUIV_FEW);
768 ffebad_string (ffesymbol_text (sym));
769 ffebad_finish ();
770 return FALSE;
773 expr = symexp;
775 goto again; /* :::::::::::::::::::: */
777 case FFEBLD_opSUBSTR:
779 ffebld begin = ffebld_head (ffebld_right (expr));
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;
791 if ((sym != NULL)
792 && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
793 return FALSE;
795 if (begin == NULL)
796 value = 0;
797 else
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);
807 value = ffebld_constant_integerdefault (ffebld_conter (begin));
809 if ((value < 1)
810 || ((sym != NULL)
811 && (value > ffesymbol_size (sym))))
813 ffebad_start (FFEBAD_EQUIV_RANGE);
814 ffebad_string (ffesymbol_text (sym));
815 ffebad_finish ();
818 --value;
820 if ((sym != NULL)
821 && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
823 ffebad_start (FFEBAD_EQUIV_SUBSTR);
824 ffebad_string (ffesymbol_text (sym));
825 ffebad_finish ();
826 value = 0;
829 goto again; /* :::::::::::::::::::: */
831 default:
832 assert ("bad op" == NULL);
833 return FALSE;
838 /* ffeequiv_add -- Add list of equivalences to list of lists for eq object
840 ffeequiv eq;
841 ffebld list;
842 ffelexToken t; // points to first item in equivalence list
843 ffeequiv_add(eq,list,t);
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. */
851 void
852 ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
854 ffebld item;
855 ffesymbol symbol;
856 ffesymbol common = ffeequiv_common (eq);
858 for (item = list; item != NULL; item = ffebld_trail (item))
860 symbol = ffeequiv_symbol (ffebld_head (item));
862 if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */
864 if (common == NULL)
865 common = ffesymbol_common (symbol);
866 else if (common != ffesymbol_common (symbol))
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;
879 if ((common != NULL)
880 && (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */
881 ffeequiv_set_common (eq, common); /* No, but it is now. */
883 for (item = list; item != NULL; item = ffebld_trail (item))
885 symbol = ffeequiv_symbol (ffebld_head (item));
887 if (ffesymbol_equiv (symbol) == NULL)
888 ffesymbol_set_equiv (symbol, eq);
889 else
890 assert (ffesymbol_equiv (symbol) == eq);
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. */
902 #if FFEGLOBAL_ENABLED
903 if (ffesymbol_is_init (symbol))
904 ffeglobal_init_common (ffesymbol_common (symbol), t);
905 #endif
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. */
913 ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
916 /* ffeequiv_dump -- Dump info on equivalence object
918 ffeequiv eq;
919 ffeequiv_dump(eq); */
921 #if FFECOM_targetCURRENT == FFECOM_targetFFE
922 void
923 ffeequiv_dump (ffeequiv eq)
925 if (ffeequiv_common (eq) != NULL)
926 fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
927 ffebld_dump (ffeequiv_list (eq));
929 #endif
931 /* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
933 ffeequiv_exec_transition(); */
935 void
936 ffeequiv_exec_transition ()
938 while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
939 ffeequiv_layout_local_ (ffeequiv_list_.first);
942 /* ffeequiv_init_2 -- Initialize for new program unit
944 ffeequiv_init_2();
946 Initializes the list of equivalences. */
948 void
949 ffeequiv_init_2 ()
951 ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
952 ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
955 /* ffeequiv_kill -- Kill equivalence object after removing from list
957 ffeequiv eq;
958 ffeequiv_kill(eq);
960 Removes equivalence object from master list, then kills it. */
962 void
963 ffeequiv_kill (ffeequiv victim)
965 victim->next->previous = victim->previous;
966 victim->previous->next = victim->next;
967 if (ffe_is_do_internal_checks ())
969 ffebld list;
970 ffebld item;
971 ffebld expr;
973 /* Assert that nobody our victim points to still points to it. */
975 assert ((victim->common == NULL)
976 || (ffesymbol_equiv (victim->common) == NULL));
978 for (list = victim->list; list != NULL; list = ffebld_trail (list))
980 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
982 ffesymbol sym;
984 expr = ffebld_head (item);
985 sym = ffeequiv_symbol (expr);
986 if (sym == NULL)
987 continue;
988 assert (ffesymbol_equiv (sym) != victim);
992 malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
995 /* ffeequiv_layout_cblock -- Lay out storage for common area
997 ffestorag st;
998 if (ffeequiv_layout_cblock(st))
999 // at least one equiv'd symbol has init/accretion expr.
1001 Now that the explicitly COMMONed variables in the common area (whose
1002 ffestorag object is passed) have been laid out, lay out the storage
1003 for all variables equivalenced into the area by making subordinate
1004 ffestorag objects for them. */
1006 bool
1007 ffeequiv_layout_cblock (ffestorag st)
1009 ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */
1010 ffebld list; /* List of explicit common vars, in order, in
1011 s. */
1012 ffebld item; /* List of list of equivalences in a given
1013 explicit common var. */
1014 ffebld root; /* Expression for (1st) explicit common var
1015 in list of eqs. */
1016 ffestorag rst; /* Storage for root. */
1017 ffetargetOffset root_offset; /* Offset for root into common area. */
1018 ffesymbol sr; /* Root itself. */
1019 ffeequiv seq; /* Its equivalence object, if any. */
1020 ffebld var; /* Expression for equivalence. */
1021 ffestorag vst; /* Storage for var. */
1022 ffetargetOffset var_offset; /* Offset for var into common area. */
1023 ffesymbol sv; /* Var itself. */
1024 ffebld altroot; /* Alternate root. */
1025 ffesymbol altrootsym; /* Alternate root symbol. */
1026 ffetargetAlign alignment;
1027 ffetargetAlign modulo;
1028 ffetargetAlign pad;
1029 ffetargetOffset size;
1030 ffetargetOffset num_elements;
1031 bool new_storage; /* Established new storage info. */
1032 bool need_storage; /* Have need for more storage info. */
1033 bool ok;
1034 bool init = FALSE;
1036 assert (st != NULL);
1037 assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
1038 assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
1040 for (list = ffesymbol_commonlist (ffestorag_symbol (st));
1041 list != NULL;
1042 list = ffebld_trail (list))
1043 { /* For every variable in the common area */
1044 assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
1045 sr = ffebld_symter (ffebld_head (list));
1046 if ((seq = ffesymbol_equiv (sr)) == NULL)
1047 continue; /* No equivalences to process. */
1048 rst = ffesymbol_storage (sr);
1049 if (rst == NULL)
1051 assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
1052 continue;
1054 ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */
1057 new_storage = FALSE;
1058 need_storage = FALSE;
1059 for (item = ffeequiv_list (seq); /* Get list of equivs. */
1060 item != NULL;
1061 item = ffebld_trail (item))
1062 { /* For every eqv list in the list of equivs
1063 for the variable */
1064 altroot = NULL;
1065 altrootsym = NULL;
1066 for (root = ffebld_head (item);
1067 root != NULL;
1068 root = ffebld_trail (root))
1069 { /* For every equivalence item in the list */
1070 sv = ffeequiv_symbol (ffebld_head (root));
1071 if (sv == sr)
1072 break; /* Found first mention of "rooted" symbol. */
1073 if (ffesymbol_storage (sv) != NULL)
1075 altroot = root; /* If no mention, use this guy
1076 instead. */
1077 altrootsym = sv;
1080 if (root != NULL)
1082 root = ffebld_head (root); /* Lose its opITEM. */
1083 ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
1084 ffestorag_offset (rst), TRUE);
1085 /* Equiv point prior to start of common area? */
1087 else if (altroot != NULL)
1089 /* Equiv point prior to start of common area? */
1090 root = ffebld_head (altroot);
1091 ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
1092 FALSE,
1093 ffestorag_offset (ffesymbol_storage (altrootsym)),
1094 TRUE);
1095 ffesymbol_set_equiv (altrootsym, NULL);
1097 else
1098 /* No rooted symbol in list of equivalences! */
1099 { /* Assume this was due to opANY and ignore
1100 this list for now. */
1101 need_storage = TRUE;
1102 continue;
1105 /* We now know the root symbol and the operating offset of that
1106 root into the common area. The other expressions in the
1107 list all identify an initial storage unit that must have the
1108 same offset. */
1110 for (var = ffebld_head (item);
1111 var != NULL;
1112 var = ffebld_trail (var))
1113 { /* For every equivalence item in the list */
1114 if (ffebld_head (var) == root)
1115 continue; /* Except root, of course. */
1116 sv = ffeequiv_symbol (ffebld_head (var));
1117 if (sv == NULL)
1118 continue; /* Except erroneous stuff (opANY). */
1119 ffesymbol_set_equiv (sv, NULL); /* Don't need this ref
1120 anymore. */
1121 if (!ok
1122 || !ffeequiv_offset_ (&var_offset, sv,
1123 ffebld_head (var), TRUE,
1124 root_offset, TRUE))
1125 continue; /* Can't do negative offset wrt COMMON. */
1127 if (ffesymbol_rank (sv) == 0)
1128 num_elements = 1;
1129 else
1130 num_elements = ffebld_constant_integerdefault
1131 (ffebld_conter (ffesymbol_arraysize (sv)));
1132 ffetarget_layout (ffesymbol_text (sv), &alignment,
1133 &modulo, &size,
1134 ffesymbol_basictype (sv),
1135 ffesymbol_kindtype (sv),
1136 ffesymbol_size (sv), num_elements);
1137 pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
1138 ffestorag_ptr_to_modulo (st),
1139 var_offset, alignment, modulo);
1140 if (pad != 0)
1142 ffebad_start (FFEBAD_EQUIV_ALIGN);
1143 ffebad_string (ffesymbol_text (sv));
1144 ffebad_finish ();
1145 continue;
1148 if ((vst = ffesymbol_storage (sv)) == NULL)
1149 { /* Create new ffestorag object, extend
1150 cblock. */
1151 new_storage = TRUE;
1152 vst = ffestorag_new (ffestorag_list_equivs (st));
1153 ffestorag_set_parent (vst, st); /* Initializations
1154 happen there. */
1155 ffestorag_set_init (vst, NULL);
1156 ffestorag_set_accretion (vst, NULL);
1157 ffestorag_set_symbol (vst, sv);
1158 ffestorag_set_size (vst, size);
1159 ffestorag_set_offset (vst, var_offset);
1160 ffestorag_set_alignment (vst, alignment);
1161 ffestorag_set_modulo (vst, modulo);
1162 ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
1163 ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
1164 ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
1165 ffestorag_set_typesymbol (vst, sv);
1166 ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */
1167 if (ffestorag_is_save (st)) /* ...update TRUE */
1168 ffestorag_update_save (vst); /* if needed. */
1169 ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */
1170 if (ffestorag_is_init (st)) /* ...update TRUE */
1171 ffestorag_update_init (vst); /* if needed. */
1172 if (!ffetarget_offset_add (&size, var_offset, size))
1173 /* Find one size of common block, complain if
1174 overflow. */
1175 ffetarget_offset_overflow (ffesymbol_text (s));
1176 else if (size > ffestorag_size (st))
1177 /* Extend common. */
1178 ffestorag_set_size (st, size);
1179 ffesymbol_set_storage (sv, vst);
1180 ffesymbol_set_common (sv, s);
1181 ffesymbol_signal_unreported (sv);
1182 ffestorag_update (st, sv, ffesymbol_basictype (sv),
1183 ffesymbol_kindtype (sv));
1184 if (ffesymbol_is_init (sv))
1185 init = TRUE;
1187 else
1189 /* Make sure offset agrees with known offset. */
1190 if (var_offset != ffestorag_offset (vst))
1192 char io1[40];
1193 char io2[40];
1195 sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
1196 sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
1197 ffebad_start (FFEBAD_EQUIV_MISMATCH);
1198 ffebad_string (ffesymbol_text (sv));
1199 ffebad_string (ffesymbol_text (s));
1200 ffebad_string (io1);
1201 ffebad_string (io2);
1202 ffebad_finish ();
1205 } /* (For every equivalence item in the list) */
1206 } /* (For every eqv list in the list of equivs
1207 for the variable) */
1209 while (new_storage && need_storage);
1211 ffeequiv_kill (seq); /* Kill equiv obj. */
1212 } /* (For every variable in the common area) */
1214 return init;
1217 /* ffeequiv_merge -- Merge two equivalence objects, return the merged result
1219 ffeequiv eq1;
1220 ffeequiv eq2;
1221 ffelexToken t; // points to current equivalence item forcing the merge.
1222 eq1 = ffeequiv_merge(eq1,eq2,t);
1224 If the two equivalence objects can be merged, they are, all the
1225 ffesymbols in their lists of lists are adjusted to point to the merged
1226 equivalence object, and the merged object is returned.
1228 Otherwise, the two equivalence objects have different non-NULL common
1229 symbols, so the merge cannot take place. An error message is issued and
1230 NULL is returned. */
1232 ffeequiv
1233 ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
1235 ffebld list;
1236 ffebld eqs;
1237 ffesymbol symbol;
1238 ffebld last = NULL;
1240 /* If both equivalence objects point to different common-based symbols,
1241 complain. Of course, one or both might have NULL common symbols now,
1242 and get COMMONed later, but the COMMON statement handler checks for
1243 this. */
1245 if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
1246 && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
1248 ffebad_start (FFEBAD_EQUIV_COMMON);
1249 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1250 ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
1251 ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
1252 ffebad_finish ();
1253 return NULL;
1256 /* Make eq1 the new, merged object (arbitrarily). */
1258 if (ffeequiv_common (eq1) == NULL)
1259 ffeequiv_set_common (eq1, ffeequiv_common (eq2));
1261 /* If the victim object has any init'ed entities, so does the new object. */
1263 if (eq2->is_init)
1264 eq1->is_init = TRUE;
1266 #if FFEGLOBAL_ENABLED
1267 if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
1268 ffeglobal_init_common (ffeequiv_common (eq1), t);
1269 #endif
1271 /* If the victim object has any SAVEd entities, then the new object has
1272 some. */
1274 if (ffeequiv_is_save (eq2))
1275 ffeequiv_update_save (eq1);
1277 /* If the victim object has any init'd entities, then the new object has
1278 some. */
1280 if (ffeequiv_is_init (eq2))
1281 ffeequiv_update_init (eq1);
1283 /* Adjust all the symbols in the list of lists of equivalences for the
1284 victim equivalence object so they point to the new merged object
1285 instead. */
1287 for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
1289 for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
1291 symbol = ffeequiv_symbol (ffebld_head (eqs));
1292 if (ffesymbol_equiv (symbol) == eq2)
1293 ffesymbol_set_equiv (symbol, eq1);
1294 else
1295 assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */
1298 /* For convenience, remember where the last ITEM in the outer list is. */
1300 if (ffebld_trail (list) == NULL)
1302 last = list;
1303 break;
1307 /* Append the list of lists in the new, merged object to the list of lists
1308 in the victim object, then use the new combined list in the new merged
1309 object. */
1311 ffebld_set_trail (last, ffeequiv_list (eq1));
1312 ffeequiv_set_list (eq1, ffeequiv_list (eq2));
1314 /* Unlink and kill the victim object. */
1316 ffeequiv_kill (eq2);
1318 return eq1; /* Return the new merged object. */
1321 /* ffeequiv_new -- Create new equivalence object, put in list
1323 ffeequiv eq;
1324 eq = ffeequiv_new();
1326 Creates a new equivalence object and adds it to the list of equivalence
1327 objects. */
1329 ffeequiv
1330 ffeequiv_new ()
1332 ffeequiv eq;
1334 eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
1335 eq->next = (ffeequiv) &ffeequiv_list_.first;
1336 eq->previous = ffeequiv_list_.last;
1337 ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */
1338 ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */
1339 ffeequiv_set_is_save (eq, FALSE);
1340 ffeequiv_set_is_init (eq, FALSE);
1341 eq->next->previous = eq;
1342 eq->previous->next = eq;
1344 return eq;
1347 /* ffeequiv_symbol -- Return symbol for equivalence expression
1349 ffesymbol symbol;
1350 ffebld expr;
1351 symbol = ffeequiv_symbol(expr);
1353 Finds the terminal SYMTER in an equivalence expression and returns the
1354 ffesymbol for it. */
1356 ffesymbol
1357 ffeequiv_symbol (ffebld expr)
1359 assert (expr != NULL);
1361 again: /* :::::::::::::::::::: */
1363 switch (ffebld_op (expr))
1365 case FFEBLD_opARRAYREF:
1366 case FFEBLD_opSUBSTR:
1367 expr = ffebld_left (expr);
1368 goto again; /* :::::::::::::::::::: */
1370 case FFEBLD_opSYMTER:
1371 return ffebld_symter (expr);
1373 case FFEBLD_opANY:
1374 return NULL;
1376 default:
1377 assert ("bad eq expr" == NULL);
1378 return NULL;
1382 /* ffeequiv_update_init -- Update the INIT flag for the area to TRUE
1384 ffeequiv eq;
1385 ffeequiv_update_init(eq);
1387 If the INIT flag for the <eq> object is already set, return. Else,
1388 set it TRUE and call ffe*_update_init for all objects contained in
1389 this one. */
1391 void
1392 ffeequiv_update_init (ffeequiv eq)
1394 ffebld list; /* Current list in list of lists. */
1395 ffebld item; /* Current item in current list. */
1396 ffebld expr; /* Expression in head of current item. */
1398 if (eq->is_init)
1399 return;
1401 eq->is_init = TRUE;
1403 if ((eq->common != NULL)
1404 && !ffesymbol_is_init (eq->common))
1405 ffesymbol_update_init (eq->common); /* Shouldn't be needed. */
1407 for (list = eq->list; list != NULL; list = ffebld_trail (list))
1409 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1411 expr = ffebld_head (item);
1413 again: /* :::::::::::::::::::: */
1415 switch (ffebld_op (expr))
1417 case FFEBLD_opANY:
1418 break;
1420 case FFEBLD_opSYMTER:
1421 if (!ffesymbol_is_init (ffebld_symter (expr)))
1422 ffesymbol_update_init (ffebld_symter (expr));
1423 break;
1425 case FFEBLD_opARRAYREF:
1426 expr = ffebld_left (expr);
1427 goto again; /* :::::::::::::::::::: */
1429 case FFEBLD_opSUBSTR:
1430 expr = ffebld_left (expr);
1431 goto again; /* :::::::::::::::::::: */
1433 default:
1434 assert ("bad op for ffeequiv_update_init" == NULL);
1435 break;
1441 /* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
1443 ffeequiv eq;
1444 ffeequiv_update_save(eq);
1446 If the SAVE flag for the <eq> object is already set, return. Else,
1447 set it TRUE and call ffe*_update_save for all objects contained in
1448 this one. */
1450 void
1451 ffeequiv_update_save (ffeequiv eq)
1453 ffebld list; /* Current list in list of lists. */
1454 ffebld item; /* Current item in current list. */
1455 ffebld expr; /* Expression in head of current item. */
1457 if (eq->is_save)
1458 return;
1460 eq->is_save = TRUE;
1462 if ((eq->common != NULL)
1463 && !ffesymbol_is_save (eq->common))
1464 ffesymbol_update_save (eq->common); /* Shouldn't be needed. */
1466 for (list = eq->list; list != NULL; list = ffebld_trail (list))
1468 for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1470 expr = ffebld_head (item);
1472 again: /* :::::::::::::::::::: */
1474 switch (ffebld_op (expr))
1476 case FFEBLD_opANY:
1477 break;
1479 case FFEBLD_opSYMTER:
1480 if (!ffesymbol_is_save (ffebld_symter (expr)))
1481 ffesymbol_update_save (ffebld_symter (expr));
1482 break;
1484 case FFEBLD_opARRAYREF:
1485 expr = ffebld_left (expr);
1486 goto again; /* :::::::::::::::::::: */
1488 case FFEBLD_opSUBSTR:
1489 expr = ffebld_left (expr);
1490 goto again; /* :::::::::::::::::::: */
1492 default:
1493 assert ("bad op for ffeequiv_update_save" == NULL);
1494 break;