Google Git
Sign in
gnu / gcc / 82b61df521d17a96f60e56ede06a55a8894b1c2e / . / gcc / f / equiv.c
blob: f58de9c4379d69be9634285dc9bc6d4887998419 [file] [log] [blame]
/* equiv.c -- Implementation File (module.c template V1.0)
Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.
Related Modules:
None
Description:
Handles the EQUIVALENCE relationships in a program unit.
Modifications:
*/
#define FFEEQUIV_DEBUG 0
/* Include files. */
#include "proj.h"
#include "equiv.h"
#include "bad.h"
#include "bld.h"
#include "com.h"
#include "data.h"
#include "global.h"
#include "lex.h"
#include "malloc.h"
#include "symbol.h"
/* Externals defined here. */
/* Simple definitions and enumerations. */
/* Internal typedefs. */
/* Private include files. */
/* Internal structure definitions. */
struct _ffeequiv_list_
{
ffeequiv first;
ffeequiv last;
};
/* Static objects accessed by functions in this module. */
static struct _ffeequiv_list_ ffeequiv_list_;
/* Static functions (internal). */
static void ffeequiv_destroy_ (ffeequiv eq);
static void ffeequiv_layout_local_ (ffeequiv eq);
static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s,
ffebld expr, bool subtract,
ffetargetOffset adjust, bool no_precede);
/* Internal macros. */
static void
ffeequiv_destroy_ (ffeequiv victim)
{
ffebld list;
ffebld item;
ffebld expr;
for (list = victim->list; list != NULL; list = ffebld_trail (list))
{
for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
{
ffesymbol sym;
expr = ffebld_head (item);
sym = ffeequiv_symbol (expr);
if (sym == NULL)
continue;
if (ffesymbol_equiv (sym) != NULL)
ffesymbol_set_equiv (sym, NULL);
}
}
ffeequiv_kill (victim);
}
/* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars
ffeequiv eq;
ffeequiv_layout_local_(eq);
Makes a single master ffestorag object that contains all the vars
in the equivalence, and makes subordinate ffestorag objects for the
vars with the correct offsets.
The resulting var offsets are relative not necessarily to 0 -- the
are relative to the offset of the master area, which might be 0 or
negative, but should never be positive. */
static void
ffeequiv_layout_local_ (ffeequiv eq)
{
ffestorag st; /* Equivalence storage area. */
ffebld list; /* List of list of equivalences. */
ffebld item; /* List of equivalences. */
ffebld root_exp; /* Expression for root sym. */
ffestorag root_st; /* Storage for root. */
ffesymbol root_sym; /* Root itself. */
ffebld rooted_exp; /* Expression for rooted sym in an eqlist. */
ffestorag rooted_st; /* Storage for rooted. */
ffesymbol rooted_sym; /* Rooted symbol itself. */
ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetAlign pad;
ffetargetOffset size;
ffetargetOffset num_elements;
bool new_storage; /* Established new storage info. */
bool need_storage; /* Have need for more storage info. */
bool init;
assert (eq != NULL);
if (ffeequiv_common (eq) != NULL)
{ /* Put in common due to programmer error. */
ffeequiv_destroy_ (eq);
return;
}
/* Find the symbol for the first valid item in the list of lists, use that
as the root symbol. Doesn't matter if it won't end up at the beginning
of the list, though. */
#if FFEEQUIV_DEBUG
fprintf (stderr, "Equiv1:\n");
#endif
root_sym = NULL;
root_exp = NULL;
for (list = ffeequiv_list (eq);
list != NULL;
list = ffebld_trail (list))
{ /* For every equivalence list in the list of
equivs */
for (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{ /* For every equivalence item in the list */
ffetargetOffset ign; /* Ignored. */
root_exp = ffebld_head (item);
root_sym = ffeequiv_symbol (root_exp);
if (root_sym == NULL)
continue; /* Ignore me. */
assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */
if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
{
/* We can't just eliminate this one symbol from the list
of candidates, because it might be the only one that
ties all these equivs together. So just destroy the
whole list. */
ffeequiv_destroy_ (eq);
return;
}
break; /* Use first valid eqv expr for root exp/sym. */
}
if (root_sym != NULL)
break;
}
if (root_sym == NULL)
{
ffeequiv_destroy_ (eq);
return;
}
#if FFEEQUIV_DEBUG
fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym));
#endif
/* We've got work to do, so make the LOCAL storage object that'll hold all
the equivalenced vars inside it. */
st = ffestorag_new (ffestorag_list_master ());
ffestorag_set_parent (st, NULL); /* Initializations happen here. */
ffestorag_set_init (st, NULL);
ffestorag_set_accretion (st, NULL);
ffestorag_set_offset (st, 0); /* Assume equiv will be at root offset 0 for now. */
ffestorag_set_alignment (st, 1);
ffestorag_set_modulo (st, 0);
ffestorag_set_type (st, FFESTORAG_typeLOCAL);
ffestorag_set_basictype (st, ffesymbol_basictype (root_sym));
ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym));
ffestorag_set_typesymbol (st, root_sym);
ffestorag_set_is_save (st, ffeequiv_is_save (eq));
if (ffesymbol_is_save (root_sym))
ffestorag_update_save (st);
ffestorag_set_is_init (st, ffeequiv_is_init (eq));
if (ffesymbol_is_init (root_sym))
ffestorag_update_init (st);
ffestorag_set_symbol (st, root_sym); /* Assume this will be the root until
we know better (used only to generate
the internal name for the aggregate area,
e.g. for debugging). */
/* Make the EQUIV storage object for the root symbol. */
if (ffesymbol_rank (root_sym) == 0)
num_elements = 1;
else
num_elements = ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (root_sym)));
ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size,
ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym),
ffesymbol_size (root_sym), num_elements);
ffestorag_set_size (st, size); /* Set initial size of aggregate area. */
pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
ffestorag_ptr_to_modulo (st), 0, alignment,
modulo);
assert (pad == 0);
root_st = ffestorag_new (ffestorag_list_equivs (st));
ffestorag_set_parent (root_st, st); /* Initializations happen there. */
ffestorag_set_init (root_st, NULL);
ffestorag_set_accretion (root_st, NULL);
ffestorag_set_symbol (root_st, root_sym);
ffestorag_set_size (root_st, size);
ffestorag_set_offset (root_st, 0); /* Will not change; always 0 relative to itself! */
ffestorag_set_alignment (root_st, alignment);
ffestorag_set_modulo (root_st, modulo);
ffestorag_set_type (root_st, FFESTORAG_typeEQUIV);
ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym));
ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym));
ffestorag_set_typesymbol (root_st, root_sym);
ffestorag_set_is_save (root_st, FALSE); /* Assume FALSE, then... */
if (ffestorag_is_save (st)) /* ...update to TRUE if needed. */
ffestorag_update_save (root_st);
ffestorag_set_is_init (root_st, FALSE); /* Assume FALSE, then... */
if (ffestorag_is_init (st)) /* ...update to TRUE if needed. */
ffestorag_update_init (root_st);
ffesymbol_set_storage (root_sym, root_st);
ffesymbol_signal_unreported (root_sym);
init = ffesymbol_is_init (root_sym);
/* Now that we know the root (offset=0) symbol, revisit all the lists and
do the actual storage allocation. Keep doing this until we've gone
through them all without making any new storage objects. */
do
{
new_storage = FALSE;
need_storage = FALSE;
for (list = ffeequiv_list (eq);
list != NULL;
list = ffebld_trail (list))
{ /* For every equivalence list in the list of
equivs */
/* Now find a "rooted" symbol in this list. That is, find the
first item we can that is valid and whose symbol already
has a storage area, because that means we know where it
belongs in the equivalence area and can then allocate the
rest of the items in the list accordingly. */
rooted_sym = NULL;
rooted_exp = NULL;
eqlist_offset = 0;
for (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{ /* For every equivalence item in the list */
rooted_exp = ffebld_head (item);
rooted_sym = ffeequiv_symbol (rooted_exp);
if ((rooted_sym == NULL)
|| ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL))
{
rooted_sym = NULL;
continue; /* Ignore me. */
}
need_storage = TRUE; /* Somebody is likely to need
storage. */
#if FFEEQUIV_DEBUG
fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n",
ffesymbol_text (rooted_sym),
ffestorag_offset (rooted_st));
#endif
/* The offset of this symbol from the equiv's root symbol
is already known, and the size of this symbol is already
incorporated in the size of the equiv's aggregate area.
What we now determine is the offset of this equivalence
_list_ from the equiv's root symbol.
For example, if we know that A is at offset 16 from the
root symbol, given EQUIVALENCE (B(24),A(2)), we're looking
at A(2), meaning that the offset for this equivalence list
is 20 (4 bytes beyond the beginning of A, assuming typical
array types, dimensions, and type info). */
if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
ffestorag_offset (rooted_st), FALSE))
{ /* Can't use this one. */
ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for
death. */
rooted_sym = NULL;
continue; /* Something's wrong with eqv expr, try another. */
}
#if FFEEQUIV_DEBUG
fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n",
eqlist_offset);
#endif
break;
}
/* If no rooted symbol, it means this list has no roots -- yet.
So, forget this list this time around, but we'll get back
to it after the outer loop iterates at least one more time,
and, ultimately, it will have a root. */
if (rooted_sym == NULL)
{
#if FFEEQUIV_DEBUG
fprintf (stderr, "No roots.\n");
#endif
continue;
}
/* We now have a rooted symbol/expr and the offset of this equivalence
list from the root symbol. The other expressions in this
list all identify an initial storage unit that must have the
same offset. */
for (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{ /* For every equivalence item in the list */
ffebld item_exp; /* Expression for equivalence. */
ffestorag item_st; /* Storage for var. */
ffesymbol item_sym; /* Var itself. */
ffetargetOffset item_offset; /* Offset for var from root. */
ffetargetOffset new_size;
item_exp = ffebld_head (item);
item_sym = ffeequiv_symbol (item_exp);
if ((item_sym == NULL)
|| (ffesymbol_equiv (item_sym) == NULL))
continue; /* Ignore me. */
if (item_sym == rooted_sym)
continue; /* Rooted sym already set up. */
if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
eqlist_offset, FALSE))
{
ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
continue;
}
#if FFEEQUIV_DEBUG
fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d",
ffesymbol_text (item_sym), item_offset);
#endif
if (ffesymbol_rank (item_sym) == 0)
num_elements = 1;
else
num_elements = ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (item_sym)));
ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo,
&size, ffesymbol_basictype (item_sym),
ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym),
num_elements);
pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
ffestorag_ptr_to_modulo (st),
item_offset, alignment, modulo);
if (pad != 0)
{
ffebad_start (FFEBAD_EQUIV_ALIGN);
ffebad_string (ffesymbol_text (item_sym));
ffebad_finish ();
ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
continue;
}
/* If the variable's offset is less than the offset for the
aggregate storage area, it means it has to expand backwards
-- i.e. the new known starting point of the area precedes the
old one. This can't happen with COMMON areas (the standard,
and common sense, disallow it), but it is normal for local
EQUIVALENCE areas.
Also handle choosing the "documented" rooted symbol for this
area here. It's the symbol at the bottom (lowest offset)
of the aggregate area, with ties going to the name that would
sort to the top of the list of ties. */
if (item_offset == ffestorag_offset (st))
{
if ((item_sym != ffestorag_symbol (st))
&& (strcmp (ffesymbol_text (item_sym),
ffesymbol_text (ffestorag_symbol (st)))
< 0))
ffestorag_set_symbol (st, item_sym);
}
else if (item_offset < ffestorag_offset (st))
{
/* Increase size of equiv area to start for lower offset
relative to root symbol. */
if (! ffetarget_offset_add (&new_size,
ffestorag_offset (st)
- item_offset,
ffestorag_size (st)))
ffetarget_offset_overflow (ffesymbol_text (s));
else
ffestorag_set_size (st, new_size);
ffestorag_set_symbol (st, item_sym);
ffestorag_set_offset (st, item_offset);
#if FFEEQUIV_DEBUG
fprintf (stderr, " [eq offset=%" ffetargetOffset_f
"d, size=%" ffetargetOffset_f "d]",
item_offset, new_size);
#endif
}
if ((item_st = ffesymbol_storage (item_sym)) == NULL)
{ /* Create new ffestorag object, extend equiv
area. */
#if FFEEQUIV_DEBUG
fprintf (stderr, ".\n");
#endif
new_storage = TRUE;
item_st = ffestorag_new (ffestorag_list_equivs (st));
ffestorag_set_parent (item_st, st); /* Initializations
happen there. */
ffestorag_set_init (item_st, NULL);
ffestorag_set_accretion (item_st, NULL);
ffestorag_set_symbol (item_st, item_sym);
ffestorag_set_size (item_st, size);
ffestorag_set_offset (item_st, item_offset);
ffestorag_set_alignment (item_st, alignment);
ffestorag_set_modulo (item_st, modulo);
ffestorag_set_type (item_st, FFESTORAG_typeEQUIV);
ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym));
ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym));
ffestorag_set_typesymbol (item_st, item_sym);
ffestorag_set_is_save (item_st, FALSE); /* Assume FALSE... */
if (ffestorag_is_save (st)) /* ...update TRUE */
ffestorag_update_save (item_st); /* if needed. */
ffestorag_set_is_init (item_st, FALSE); /* Assume FALSE... */
if (ffestorag_is_init (st)) /* ...update TRUE */
ffestorag_update_init (item_st); /* if needed. */
ffesymbol_set_storage (item_sym, item_st);
ffesymbol_signal_unreported (item_sym);
if (ffesymbol_is_init (item_sym))
init = TRUE;
/* Determine new size of equiv area, complain if overflow. */
if (!ffetarget_offset_add (&size, item_offset, size)
|| !ffetarget_offset_add (&size, -ffestorag_offset (st), size))
ffetarget_offset_overflow (ffesymbol_text (s));
else if (size > ffestorag_size (st))
ffestorag_set_size (st, size);
ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym),
ffesymbol_kindtype (item_sym));
}
else
{
#if FFEEQUIV_DEBUG
fprintf (stderr, " (was %" ffetargetOffset_f "d).\n",
ffestorag_offset (item_st));
#endif
/* Make sure offset agrees with known offset. */
if (item_offset != ffestorag_offset (item_st))
{
char io1[40];
char io2[40];
sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset);
sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st));
ffebad_start (FFEBAD_EQUIV_MISMATCH);
ffebad_string (ffesymbol_text (item_sym));
ffebad_string (ffesymbol_text (root_sym));
ffebad_string (io1);
ffebad_string (io2);
ffebad_finish ();
}
}
ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
} /* (For every equivalence item in the list) */
ffebld_set_head (list, NULL); /* Don't do this list again. */
} /* (For every equivalence list in the list of
equivs) */
} while (new_storage && need_storage);
ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */
ffeequiv_kill (eq); /* Fully processed, no longer needed. */
/* If the offset for this storage area is zero (it cannot be positive),
that means the alignment/modulo info is already correct. Otherwise,
the alignment info is correct, but the modulo info reflects a
zero offset, so fix it. */
if (ffestorag_offset (st) < 0)
{
/* Calculate the initial padding necessary to preserve
the alignment/modulo requirements for the storage area.
These requirements are themselves kept track of in the
record for the storage area as a whole, but really pertain
to offset 0 of that area, which is where the root symbol
was originally placed.
The goal here is to have the offset and size for the area
faithfully reflect the area itself, not extra requirements
like alignment. So to meet the alignment requirements,
the modulo for the area should be set as if the area had an
alignment requirement of alignment/0 and was aligned/padded
downward to meet the alignment requirements of the area at
offset zero, the amount of padding needed being the desired
value for the modulo of the area. */
alignment = ffestorag_alignment (st);
modulo = ffestorag_modulo (st);
/* Since we want to move the whole area *down* (lower memory
addresses) as required by the alignment/modulo paid, negate
the offset to ffetarget_align, which assumes aligning *up*
is desired. */
pad = ffetarget_align (&alignment, &modulo,
- ffestorag_offset (st),
alignment, 0);
ffestorag_set_modulo (st, pad);
}
if (init)
ffedata_gather (st); /* Gather subordinate inits into one init. */
}
/* ffeequiv_offset_ -- Determine offset from start of symbol
ffetargetOffset offset;
ffesymbol s; // Symbol for error reporting.
ffebld expr; // opSUBSTR, opARRAYREF, opSYMTER, opANY.
bool subtract; // FALSE means add to adjust, TRUE means subtract from it.
ffetargetOffset adjust; // Helps keep answer in pos range (unsigned).
if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust))
// error doing the calculation, message already printed
Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF
combination added-to/subtracted-from the adjustment specified. If there
is an error of some kind, returns FALSE, else returns TRUE. Note that
only the first storage unit specified is considered; A(1:1) and A(1:2000)
have the same first storage unit and so return the same offset. */
static bool
ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
ffebld expr, bool subtract, ffetargetOffset adjust,
bool no_precede)
{
ffetargetIntegerDefault value = 0;
ffetargetOffset cval; /* Converted value. */
ffesymbol sym;
if (expr == NULL)
return FALSE;
again: /* :::::::::::::::::::: */
switch (ffebld_op (expr))
{
case FFEBLD_opANY:
return FALSE;
case FFEBLD_opSYMTER:
{
ffetargetOffset size; /* Size of a single unit. */
ffetargetAlign a; /* Ignored. */
ffetargetAlign m; /* Ignored. */
sym = ffebld_symter (expr);
if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
return FALSE;
ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
ffesymbol_basictype (sym),
ffesymbol_kindtype (sym), 1, 1);
if (value < 0)
{ /* Really invalid, as in A(-2:5), but in case
it's wanted.... */
if (!ffetarget_offset (&cval, -value))
return FALSE;
if (!ffetarget_offset_multiply (&cval, cval, size))
return FALSE;
if (subtract)
return ffetarget_offset_add (offset, cval, adjust);
if (no_precede && (cval > adjust))
{
neg: /* :::::::::::::::::::: */
ffebad_start (FFEBAD_COMMON_NEG);
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
return FALSE;
}
return ffetarget_offset_add (offset, -cval, adjust);
}
if (!ffetarget_offset (&cval, value))
return FALSE;
if (!ffetarget_offset_multiply (&cval, cval, size))
return FALSE;
if (!subtract)
return ffetarget_offset_add (offset, cval, adjust);
if (no_precede && (cval > adjust))
goto neg; /* :::::::::::::::::::: */
return ffetarget_offset_add (offset, -cval, adjust);
}
case FFEBLD_opARRAYREF:
{
ffebld symexp = ffebld_left (expr);
ffebld subscripts = ffebld_right (expr);
ffebld dims;
ffetargetIntegerDefault width;
ffetargetIntegerDefault arrayval;
ffetargetIntegerDefault lowbound;
ffetargetIntegerDefault highbound;
ffebld subscript;
ffebld dim;
ffebld low;
ffebld high;
int rank = 0;
if (ffebld_op (symexp) != FFEBLD_opSYMTER)
return FALSE;
sym = ffebld_symter (symexp);
if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
return FALSE;
if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
width = 1;
else
width = ffesymbol_size (sym);
dims = ffesymbol_dims (sym);
while (subscripts != NULL)
{
++rank;
if (dims == NULL)
{
ffebad_start (FFEBAD_EQUIV_MANY);
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
return FALSE;
}
subscript = ffebld_head (subscripts);
dim = ffebld_head (dims);
if (ffebld_op (subscript) == FFEBLD_opANY)
return FALSE;
assert (ffebld_op (subscript) == FFEBLD_opCONTER);
assert (ffeinfo_basictype (ffebld_info (subscript))
== FFEINFO_basictypeINTEGER);
assert (ffeinfo_kindtype (ffebld_info (subscript))
== FFEINFO_kindtypeINTEGERDEFAULT);
arrayval = ffebld_constant_integerdefault (ffebld_conter
(subscript));
if (ffebld_op (dim) == FFEBLD_opANY)
return FALSE;
assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
low = ffebld_left (dim);
high = ffebld_right (dim);
if (low == NULL)
lowbound = 1;
else
{
if (ffebld_op (low) == FFEBLD_opANY)
return FALSE;
assert (ffebld_op (low) == FFEBLD_opCONTER);
assert (ffeinfo_basictype (ffebld_info (low))
== FFEINFO_basictypeINTEGER);
assert (ffeinfo_kindtype (ffebld_info (low))
== FFEINFO_kindtypeINTEGERDEFAULT);
lowbound
= ffebld_constant_integerdefault (ffebld_conter (low));
}
if (ffebld_op (high) == FFEBLD_opANY)
return FALSE;
assert (ffebld_op (high) == FFEBLD_opCONTER);
assert (ffeinfo_basictype (ffebld_info (high))
== FFEINFO_basictypeINTEGER);
assert (ffeinfo_kindtype (ffebld_info (high))
== FFEINFO_kindtypeINTEGER1);
highbound
= ffebld_constant_integerdefault (ffebld_conter (high));
if ((arrayval < lowbound) || (arrayval > highbound))
{
char rankstr[10];
sprintf (rankstr, "%d", rank);
ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
ffebad_string (ffesymbol_text (sym));
ffebad_string (rankstr);
ffebad_finish ();
}
subscripts = ffebld_trail (subscripts);
dims = ffebld_trail (dims);
value += width * (arrayval - lowbound);
if (subscripts != NULL)
width *= highbound - lowbound + 1;
}
if (dims != NULL)
{
ffebad_start (FFEBAD_EQUIV_FEW);
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
return FALSE;
}
expr = symexp;
}
goto again; /* :::::::::::::::::::: */
case FFEBLD_opSUBSTR:
{
ffebld begin = ffebld_head (ffebld_right (expr));
expr = ffebld_left (expr);
if (ffebld_op (expr) == FFEBLD_opANY)
return FALSE;
if (ffebld_op (expr) == FFEBLD_opARRAYREF)
sym = ffebld_symter (ffebld_left (expr));
else if (ffebld_op (expr) == FFEBLD_opSYMTER)
sym = ffebld_symter (expr);
else
sym = NULL;
if ((sym != NULL)
&& (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
return FALSE;
if (begin == NULL)
value = 0;
else
{
if (ffebld_op (begin) == FFEBLD_opANY)
return FALSE;
assert (ffebld_op (begin) == FFEBLD_opCONTER);
assert (ffeinfo_basictype (ffebld_info (begin))
== FFEINFO_basictypeINTEGER);
assert (ffeinfo_kindtype (ffebld_info (begin))
== FFEINFO_kindtypeINTEGERDEFAULT);
value = ffebld_constant_integerdefault (ffebld_conter (begin));
if ((value < 1)
|| ((sym != NULL)
&& (value > ffesymbol_size (sym))))
{
ffebad_start (FFEBAD_EQUIV_RANGE);
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
}
--value;
}
if ((sym != NULL)
&& (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
{
ffebad_start (FFEBAD_EQUIV_SUBSTR);
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
value = 0;
}
}
goto again; /* :::::::::::::::::::: */
default:
assert ("bad op" == NULL);
return FALSE;
}
}
/* ffeequiv_add -- Add list of equivalences to list of lists for eq object
ffeequiv eq;
ffebld list;
ffelexToken t; // points to first item in equivalence list
ffeequiv_add(eq,list,t);
Check the list to make sure only one common symbol is involved (even
if multiple times) and agrees with the common symbol for the equivalence
object (or it has no common symbol until now). Prepend (or append, it
doesn't matter) the list to the list of lists for the equivalence object.
Otherwise report an error and return. */
void
ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
{
ffebld item;
ffesymbol symbol;
ffesymbol common = ffeequiv_common (eq);
for (item = list; item != NULL; item = ffebld_trail (item))
{
symbol = ffeequiv_symbol (ffebld_head (item));
if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */
{
if (common == NULL)
common = ffesymbol_common (symbol);
else if (common != ffesymbol_common (symbol))
{
/* Yes, and symbol disagrees with others on the COMMON area. */
ffebad_start (FFEBAD_EQUIV_COMMON);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_string (ffesymbol_text (common));
ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
ffebad_finish ();
return;
}
}
}
if ((common != NULL)
&& (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */
ffeequiv_set_common (eq, common); /* No, but it is now. */
for (item = list; item != NULL; item = ffebld_trail (item))
{
symbol = ffeequiv_symbol (ffebld_head (item));
if (ffesymbol_equiv (symbol) == NULL)
ffesymbol_set_equiv (symbol, eq);
else
assert (ffesymbol_equiv (symbol) == eq);
if (ffesymbol_common (symbol) == NULL) /* Is symbol in a COMMON
area? */
{ /* No (at least not yet). */
if (ffesymbol_is_save (symbol))
ffeequiv_update_save (eq); /* EQUIVALENCE has >=1 SAVEd entity. */
if (ffesymbol_is_init (symbol))
ffeequiv_update_init (eq); /* EQUIVALENCE has >=1 init'd entity. */
continue; /* Nothing more to do here. */
}
#if FFEGLOBAL_ENABLED
if (ffesymbol_is_init (symbol))
ffeglobal_init_common (ffesymbol_common (symbol), t);
#endif
if (ffesymbol_is_save (ffesymbol_common (symbol)))
ffeequiv_update_save (eq); /* EQUIVALENCE is in a SAVEd COMMON block. */
if (ffesymbol_is_init (ffesymbol_common (symbol)))
ffeequiv_update_init (eq); /* EQUIVALENCE is in a init'd COMMON block. */
}
ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
}
/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
ffeequiv_exec_transition(); */
void
ffeequiv_exec_transition ()
{
while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
ffeequiv_layout_local_ (ffeequiv_list_.first);
}
/* ffeequiv_init_2 -- Initialize for new program unit
ffeequiv_init_2();
Initializes the list of equivalences. */
void
ffeequiv_init_2 ()
{
ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
}
/* ffeequiv_kill -- Kill equivalence object after removing from list
ffeequiv eq;
ffeequiv_kill(eq);
Removes equivalence object from master list, then kills it. */
void
ffeequiv_kill (ffeequiv victim)
{
victim->next->previous = victim->previous;
victim->previous->next = victim->next;
if (ffe_is_do_internal_checks ())
{
ffebld list;
ffebld item;
ffebld expr;
/* Assert that nobody our victim points to still points to it. */
assert ((victim->common == NULL)
|| (ffesymbol_equiv (victim->common) == NULL));
for (list = victim->list; list != NULL; list = ffebld_trail (list))
{
for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
{
ffesymbol sym;
expr = ffebld_head (item);
sym = ffeequiv_symbol (expr);
if (sym == NULL)
continue;
assert (ffesymbol_equiv (sym) != victim);
}
}
}
malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
}
/* ffeequiv_layout_cblock -- Lay out storage for common area
ffestorag st;
if (ffeequiv_layout_cblock(st))
// at least one equiv'd symbol has init/accretion expr.
Now that the explicitly COMMONed variables in the common area (whose
ffestorag object is passed) have been laid out, lay out the storage
for all variables equivalenced into the area by making subordinate
ffestorag objects for them. */
bool
ffeequiv_layout_cblock (ffestorag st)
{
ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */
ffebld list; /* List of explicit common vars, in order, in
s. */
ffebld item; /* List of list of equivalences in a given
explicit common var. */
ffebld root; /* Expression for (1st) explicit common var
in list of eqs. */
ffestorag rst; /* Storage for root. */
ffetargetOffset root_offset; /* Offset for root into common area. */
ffesymbol sr; /* Root itself. */
ffeequiv seq; /* Its equivalence object, if any. */
ffebld var; /* Expression for equivalence. */
ffestorag vst; /* Storage for var. */
ffetargetOffset var_offset; /* Offset for var into common area. */
ffesymbol sv; /* Var itself. */
ffebld altroot; /* Alternate root. */
ffesymbol altrootsym; /* Alternate root symbol. */
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetAlign pad;
ffetargetOffset size;
ffetargetOffset num_elements;
bool new_storage; /* Established new storage info. */
bool need_storage; /* Have need for more storage info. */
bool ok;
bool init = FALSE;
assert (st != NULL);
assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
for (list = ffesymbol_commonlist (ffestorag_symbol (st));
list != NULL;
list = ffebld_trail (list))
{ /* For every variable in the common area */
assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
sr = ffebld_symter (ffebld_head (list));
if ((seq = ffesymbol_equiv (sr)) == NULL)
continue; /* No equivalences to process. */
rst = ffesymbol_storage (sr);
if (rst == NULL)
{
assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
continue;
}
ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */
do
{
new_storage = FALSE;
need_storage = FALSE;
for (item = ffeequiv_list (seq); /* Get list of equivs. */
item != NULL;
item = ffebld_trail (item))
{ /* For every eqv list in the list of equivs
for the variable */
altroot = NULL;
altrootsym = NULL;
for (root = ffebld_head (item);
root != NULL;
root = ffebld_trail (root))
{ /* For every equivalence item in the list */
sv = ffeequiv_symbol (ffebld_head (root));
if (sv == sr)
break; /* Found first mention of "rooted" symbol. */
if (ffesymbol_storage (sv) != NULL)
{
altroot = root; /* If no mention, use this guy
instead. */
altrootsym = sv;
}
}
if (root != NULL)
{
root = ffebld_head (root); /* Lose its opITEM. */
ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
ffestorag_offset (rst), TRUE);
/* Equiv point prior to start of common area? */
}
else if (altroot != NULL)
{
/* Equiv point prior to start of common area? */
root = ffebld_head (altroot);
ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
FALSE,
ffestorag_offset (ffesymbol_storage (altrootsym)),
TRUE);
ffesymbol_set_equiv (altrootsym, NULL);
}
else
/* No rooted symbol in list of equivalences! */
{ /* Assume this was due to opANY and ignore
this list for now. */
need_storage = TRUE;
continue;
}
/* We now know the root symbol and the operating offset of that
root into the common area. The other expressions in the
list all identify an initial storage unit that must have the
same offset. */
for (var = ffebld_head (item);
var != NULL;
var = ffebld_trail (var))
{ /* For every equivalence item in the list */
if (ffebld_head (var) == root)
continue; /* Except root, of course. */
sv = ffeequiv_symbol (ffebld_head (var));
if (sv == NULL)
continue; /* Except erroneous stuff (opANY). */
ffesymbol_set_equiv (sv, NULL); /* Don't need this ref
anymore. */
if (!ok
|| !ffeequiv_offset_ (&var_offset, sv,
ffebld_head (var), TRUE,
root_offset, TRUE))
continue; /* Can't do negative offset wrt COMMON. */
if (ffesymbol_rank (sv) == 0)
num_elements = 1;
else
num_elements = ffebld_constant_integerdefault
(ffebld_conter (ffesymbol_arraysize (sv)));
ffetarget_layout (ffesymbol_text (sv), &alignment,
&modulo, &size,
ffesymbol_basictype (sv),
ffesymbol_kindtype (sv),
ffesymbol_size (sv), num_elements);
pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
ffestorag_ptr_to_modulo (st),
var_offset, alignment, modulo);
if (pad != 0)
{
ffebad_start (FFEBAD_EQUIV_ALIGN);
ffebad_string (ffesymbol_text (sv));
ffebad_finish ();
continue;
}
if ((vst = ffesymbol_storage (sv)) == NULL)
{ /* Create new ffestorag object, extend
cblock. */
new_storage = TRUE;
vst = ffestorag_new (ffestorag_list_equivs (st));
ffestorag_set_parent (vst, st); /* Initializations
happen there. */
ffestorag_set_init (vst, NULL);
ffestorag_set_accretion (vst, NULL);
ffestorag_set_symbol (vst, sv);
ffestorag_set_size (vst, size);
ffestorag_set_offset (vst, var_offset);
ffestorag_set_alignment (vst, alignment);
ffestorag_set_modulo (vst, modulo);
ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
ffestorag_set_typesymbol (vst, sv);
ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */
if (ffestorag_is_save (st)) /* ...update TRUE */
ffestorag_update_save (vst); /* if needed. */
ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */
if (ffestorag_is_init (st)) /* ...update TRUE */
ffestorag_update_init (vst); /* if needed. */
if (!ffetarget_offset_add (&size, var_offset, size))
/* Find one size of common block, complain if
overflow. */
ffetarget_offset_overflow (ffesymbol_text (s));
else if (size > ffestorag_size (st))
/* Extend common. */
ffestorag_set_size (st, size);
ffesymbol_set_storage (sv, vst);
ffesymbol_set_common (sv, s);
ffesymbol_signal_unreported (sv);
ffestorag_update (st, sv, ffesymbol_basictype (sv),
ffesymbol_kindtype (sv));
if (ffesymbol_is_init (sv))
init = TRUE;
}
else
{
/* Make sure offset agrees with known offset. */
if (var_offset != ffestorag_offset (vst))
{
char io1[40];
char io2[40];
sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
ffebad_start (FFEBAD_EQUIV_MISMATCH);
ffebad_string (ffesymbol_text (sv));
ffebad_string (ffesymbol_text (s));
ffebad_string (io1);
ffebad_string (io2);
ffebad_finish ();
}
}
} /* (For every equivalence item in the list) */
} /* (For every eqv list in the list of equivs
for the variable) */
}
while (new_storage && need_storage);
ffeequiv_kill (seq); /* Kill equiv obj. */
} /* (For every variable in the common area) */
return init;
}
/* ffeequiv_merge -- Merge two equivalence objects, return the merged result
ffeequiv eq1;
ffeequiv eq2;
ffelexToken t; // points to current equivalence item forcing the merge.
eq1 = ffeequiv_merge(eq1,eq2,t);
If the two equivalence objects can be merged, they are, all the
ffesymbols in their lists of lists are adjusted to point to the merged
equivalence object, and the merged object is returned.
Otherwise, the two equivalence objects have different non-NULL common
symbols, so the merge cannot take place. An error message is issued and
NULL is returned. */
ffeequiv
ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
{
ffebld list;
ffebld eqs;
ffesymbol symbol;
ffebld last = NULL;
/* If both equivalence objects point to different common-based symbols,
complain. Of course, one or both might have NULL common symbols now,
and get COMMONed later, but the COMMON statement handler checks for
this. */
if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
&& (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
{
ffebad_start (FFEBAD_EQUIV_COMMON);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
ffebad_finish ();
return NULL;
}
/* Make eq1 the new, merged object (arbitrarily). */
if (ffeequiv_common (eq1) == NULL)
ffeequiv_set_common (eq1, ffeequiv_common (eq2));
/* If the victim object has any init'ed entities, so does the new object. */
if (eq2->is_init)
eq1->is_init = TRUE;
#if FFEGLOBAL_ENABLED
if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
ffeglobal_init_common (ffeequiv_common (eq1), t);
#endif
/* If the victim object has any SAVEd entities, then the new object has
some. */
if (ffeequiv_is_save (eq2))
ffeequiv_update_save (eq1);
/* If the victim object has any init'd entities, then the new object has
some. */
if (ffeequiv_is_init (eq2))
ffeequiv_update_init (eq1);
/* Adjust all the symbols in the list of lists of equivalences for the
victim equivalence object so they point to the new merged object
instead. */
for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
{
for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
{
symbol = ffeequiv_symbol (ffebld_head (eqs));
if (ffesymbol_equiv (symbol) == eq2)
ffesymbol_set_equiv (symbol, eq1);
else
assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */
}
/* For convenience, remember where the last ITEM in the outer list is. */
if (ffebld_trail (list) == NULL)
{
last = list;
break;
}
}
/* Append the list of lists in the new, merged object to the list of lists
in the victim object, then use the new combined list in the new merged
object. */
ffebld_set_trail (last, ffeequiv_list (eq1));
ffeequiv_set_list (eq1, ffeequiv_list (eq2));
/* Unlink and kill the victim object. */
ffeequiv_kill (eq2);
return eq1; /* Return the new merged object. */
}
/* ffeequiv_new -- Create new equivalence object, put in list
ffeequiv eq;
eq = ffeequiv_new();
Creates a new equivalence object and adds it to the list of equivalence
objects. */
ffeequiv
ffeequiv_new ()
{
ffeequiv eq;
eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
eq->next = (ffeequiv) &ffeequiv_list_.first;
eq->previous = ffeequiv_list_.last;
ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */
ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */
ffeequiv_set_is_save (eq, FALSE);
ffeequiv_set_is_init (eq, FALSE);
eq->next->previous = eq;
eq->previous->next = eq;
return eq;
}
/* ffeequiv_symbol -- Return symbol for equivalence expression
ffesymbol symbol;
ffebld expr;
symbol = ffeequiv_symbol(expr);
Finds the terminal SYMTER in an equivalence expression and returns the
ffesymbol for it. */
ffesymbol
ffeequiv_symbol (ffebld expr)
{
assert (expr != NULL);
again: /* :::::::::::::::::::: */
switch (ffebld_op (expr))
{
case FFEBLD_opARRAYREF:
case FFEBLD_opSUBSTR:
expr = ffebld_left (expr);
goto again; /* :::::::::::::::::::: */
case FFEBLD_opSYMTER:
return ffebld_symter (expr);
case FFEBLD_opANY:
return NULL;
default:
assert ("bad eq expr" == NULL);
return NULL;
}
}
/* ffeequiv_update_init -- Update the INIT flag for the area to TRUE
ffeequiv eq;
ffeequiv_update_init(eq);
If the INIT flag for the <eq> object is already set, return. Else,
set it TRUE and call ffe*_update_init for all objects contained in
this one. */
void
ffeequiv_update_init (ffeequiv eq)
{
ffebld list; /* Current list in list of lists. */
ffebld item; /* Current item in current list. */
ffebld expr; /* Expression in head of current item. */
if (eq->is_init)
return;
eq->is_init = TRUE;
if ((eq->common != NULL)
&& !ffesymbol_is_init (eq->common))
ffesymbol_update_init (eq->common); /* Shouldn't be needed. */
for (list = eq->list; list != NULL; list = ffebld_trail (list))
{
for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
{
expr = ffebld_head (item);
again: /* :::::::::::::::::::: */
switch (ffebld_op (expr))
{
case FFEBLD_opANY:
break;
case FFEBLD_opSYMTER:
if (!ffesymbol_is_init (ffebld_symter (expr)))
ffesymbol_update_init (ffebld_symter (expr));
break;
case FFEBLD_opARRAYREF:
expr = ffebld_left (expr);
goto again; /* :::::::::::::::::::: */
case FFEBLD_opSUBSTR:
expr = ffebld_left (expr);
goto again; /* :::::::::::::::::::: */
default:
assert ("bad op for ffeequiv_update_init" == NULL);
break;
}
}
}
}
/* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
ffeequiv eq;
ffeequiv_update_save(eq);
If the SAVE flag for the <eq> object is already set, return. Else,
set it TRUE and call ffe*_update_save for all objects contained in
this one. */
void
ffeequiv_update_save (ffeequiv eq)
{
ffebld list; /* Current list in list of lists. */
ffebld item; /* Current item in current list. */
ffebld expr; /* Expression in head of current item. */
if (eq->is_save)
return;
eq->is_save = TRUE;
if ((eq->common != NULL)
&& !ffesymbol_is_save (eq->common))
ffesymbol_update_save (eq->common); /* Shouldn't be needed. */
for (list = eq->list; list != NULL; list = ffebld_trail (list))
{
for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
{
expr = ffebld_head (item);
again: /* :::::::::::::::::::: */
switch (ffebld_op (expr))
{
case FFEBLD_opANY:
break;
case FFEBLD_opSYMTER:
if (!ffesymbol_is_save (ffebld_symter (expr)))
ffesymbol_update_save (ffebld_symter (expr));
break;
case FFEBLD_opARRAYREF:
expr = ffebld_left (expr);
goto again; /* :::::::::::::::::::: */
case FFEBLD_opSUBSTR:
expr = ffebld_left (expr);
goto again; /* :::::::::::::::::::: */
default:
assert ("bad op for ffeequiv_update_save" == NULL);
break;
}
}
}
}