#define FFEEQUIV_DEBUG 0
#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"
struct _ffeequiv_list_
{
ffeequiv first;
ffeequiv last;
};
static struct _ffeequiv_list_ ffeequiv_list_;
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);
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);
}
static void
ffeequiv_layout_local_ (ffeequiv eq)
{
ffestorag st;
ffebld list;
ffebld item;
ffebld root_exp;
ffestorag root_st;
ffesymbol root_sym;
ffebld rooted_exp;
ffestorag rooted_st;
ffesymbol rooted_sym;
ffetargetOffset eqlist_offset;
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetAlign pad;
ffetargetOffset size;
ffetargetOffset num_elements;
bool new_storage;
bool need_storage;
bool init;
assert (eq != NULL);
if (ffeequiv_common (eq) != NULL)
{
ffeequiv_destroy_ (eq);
return;
}
#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 (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{
ffetargetOffset ign;
root_exp = ffebld_head (item);
root_sym = ffeequiv_symbol (root_exp);
if (root_sym == NULL)
continue;
assert (ffesymbol_storage (root_sym) == NULL);
if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
{
ffeequiv_destroy_ (eq);
return;
}
break;
}
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
st = ffestorag_new (ffestorag_list_master ());
ffestorag_set_parent (st, NULL);
ffestorag_set_init (st, NULL);
ffestorag_set_accretion (st, NULL);
ffestorag_set_offset (st, 0);
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);
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);
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);
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);
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);
if (ffestorag_is_save (st))
ffestorag_update_save (root_st);
ffestorag_set_is_init (root_st, FALSE);
if (ffestorag_is_init (st))
ffestorag_update_init (root_st);
ffesymbol_set_storage (root_sym, root_st);
ffesymbol_signal_unreported (root_sym);
init = ffesymbol_is_init (root_sym);
do
{
new_storage = FALSE;
need_storage = FALSE;
for (list = ffeequiv_list (eq);
list != NULL;
list = ffebld_trail (list))
{
rooted_sym = NULL;
rooted_exp = NULL;
eqlist_offset = 0;
for (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{
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;
}
need_storage = TRUE;
#if FFEEQUIV_DEBUG
fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n",
ffesymbol_text (rooted_sym),
ffestorag_offset (rooted_st));
#endif
if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
ffestorag_offset (rooted_st), FALSE))
{
ffesymbol_set_equiv (rooted_sym, NULL);
rooted_sym = NULL;
continue;
}
#if FFEEQUIV_DEBUG
fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n",
eqlist_offset);
#endif
break;
}
if (rooted_sym == NULL)
{
#if FFEEQUIV_DEBUG
fprintf (stderr, "No roots.\n");
#endif
continue;
}
for (item = ffebld_head (list);
item != NULL;
item = ffebld_trail (item))
{
ffebld item_exp;
ffestorag item_st;
ffesymbol item_sym;
ffetargetOffset item_offset;
ffetargetOffset new_size;
item_exp = ffebld_head (item);
item_sym = ffeequiv_symbol (item_exp);
if ((item_sym == NULL)
|| (ffesymbol_equiv (item_sym) == NULL))
continue;
if (item_sym == rooted_sym)
continue;
if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
eqlist_offset, FALSE))
{
ffesymbol_set_equiv (item_sym, NULL);
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);
continue;
}
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))
{
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)
{
#if FFEEQUIV_DEBUG
fprintf (stderr, ".\n");
#endif
new_storage = TRUE;
item_st = ffestorag_new (ffestorag_list_equivs (st));
ffestorag_set_parent (item_st, st);
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);
if (ffestorag_is_save (st))
ffestorag_update_save (item_st);
ffestorag_set_is_init (item_st, FALSE);
if (ffestorag_is_init (st))
ffestorag_update_init (item_st);
ffesymbol_set_storage (item_sym, item_st);
ffesymbol_signal_unreported (item_sym);
if (ffesymbol_is_init (item_sym))
init = TRUE;
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
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);
}
ffebld_set_head (list, NULL);
}
} while (new_storage && need_storage);
ffesymbol_set_equiv (root_sym, NULL);
ffeequiv_kill (eq);
if (ffestorag_offset (st) < 0)
{
alignment = ffestorag_alignment (st);
modulo = ffestorag_modulo (st);
pad = ffetarget_align (&alignment, &modulo,
- ffestorag_offset (st),
alignment, 0);
ffestorag_set_modulo (st, pad);
}
if (init)
ffedata_gather (st);
}
static bool
ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
ffebld expr, bool subtract, ffetargetOffset adjust,
bool no_precede)
{
ffetargetIntegerDefault value = 0;
ffetargetOffset cval;
ffesymbol sym;
if (expr == NULL)
return FALSE;
again:
switch (ffebld_op (expr))
{
case FFEBLD_opANY:
return FALSE;
case FFEBLD_opSYMTER:
{
ffetargetOffset size;
ffetargetAlign a;
ffetargetAlign m;
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)
{
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;
}
}
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)
{
if (common == NULL)
common = ffesymbol_common (symbol);
else if (common != ffesymbol_common (symbol))
{
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))
ffeequiv_set_common (eq, common);
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)
{
if (ffesymbol_is_save (symbol))
ffeequiv_update_save (eq);
if (ffesymbol_is_init (symbol))
ffeequiv_update_init (eq);
continue;
}
#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);
if (ffesymbol_is_init (ffesymbol_common (symbol)))
ffeequiv_update_init (eq);
}
ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
}
void
ffeequiv_exec_transition ()
{
while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
ffeequiv_layout_local_ (ffeequiv_list_.first);
}
void
ffeequiv_init_2 ()
{
ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
}
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 ((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));
}
bool
ffeequiv_layout_cblock (ffestorag st)
{
ffesymbol s = ffestorag_symbol (st);
ffebld list;
ffebld item;
ffebld root;
ffestorag rst;
ffetargetOffset root_offset;
ffesymbol sr;
ffeequiv seq;
ffebld var;
ffestorag vst;
ffetargetOffset var_offset;
ffesymbol sv;
ffebld altroot;
ffesymbol altrootsym;
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetAlign pad;
ffetargetOffset size;
ffetargetOffset num_elements;
bool new_storage;
bool need_storage;
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))
{
assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
sr = ffebld_symter (ffebld_head (list));
if ((seq = ffesymbol_equiv (sr)) == NULL)
continue;
rst = ffesymbol_storage (sr);
if (rst == NULL)
{
assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
continue;
}
ffesymbol_set_equiv (sr, NULL);
do
{
new_storage = FALSE;
need_storage = FALSE;
for (item = ffeequiv_list (seq);
item != NULL;
item = ffebld_trail (item))
{
altroot = NULL;
altrootsym = NULL;
for (root = ffebld_head (item);
root != NULL;
root = ffebld_trail (root))
{
sv = ffeequiv_symbol (ffebld_head (root));
if (sv == sr)
break;
if (ffesymbol_storage (sv) != NULL)
{
altroot = root;
altrootsym = sv;
}
}
if (root != NULL)
{
root = ffebld_head (root);
ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
ffestorag_offset (rst), TRUE);
}
else if (altroot != NULL)
{
root = ffebld_head (altroot);
ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
FALSE,
ffestorag_offset (ffesymbol_storage (altrootsym)),
TRUE);
ffesymbol_set_equiv (altrootsym, NULL);
}
else
{
need_storage = TRUE;
continue;
}
for (var = ffebld_head (item);
var != NULL;
var = ffebld_trail (var))
{
if (ffebld_head (var) == root)
continue;
sv = ffeequiv_symbol (ffebld_head (var));
if (sv == NULL)
continue;
ffesymbol_set_equiv (sv, NULL);
if (!ok
|| !ffeequiv_offset_ (&var_offset, sv,
ffebld_head (var), TRUE,
root_offset, TRUE))
continue;
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)
{
new_storage = TRUE;
vst = ffestorag_new (ffestorag_list_equivs (st));
ffestorag_set_parent (vst, st);
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);
if (ffestorag_is_save (st))
ffestorag_update_save (vst);
ffestorag_set_is_init (vst, FALSE);
if (ffestorag_is_init (st))
ffestorag_update_init (vst);
if (!ffetarget_offset_add (&size, var_offset, size))
ffetarget_offset_overflow (ffesymbol_text (s));
else if (size > ffestorag_size (st))
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
{
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 ();
}
}
}
}
}
while (new_storage && need_storage);
ffeequiv_kill (seq);
}
return init;
}
ffeequiv
ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
{
ffebld list;
ffebld eqs;
ffesymbol symbol;
ffebld last = NULL;
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;
}
if (ffeequiv_common (eq1) == NULL)
ffeequiv_set_common (eq1, ffeequiv_common (eq2));
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 (ffeequiv_is_save (eq2))
ffeequiv_update_save (eq1);
if (ffeequiv_is_init (eq2))
ffeequiv_update_init (eq1);
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);
}
if (ffebld_trail (list) == NULL)
{
last = list;
break;
}
}
ffebld_set_trail (last, ffeequiv_list (eq1));
ffeequiv_set_list (eq1, ffeequiv_list (eq2));
ffeequiv_kill (eq2);
return eq1;
}
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);
ffeequiv_set_list (eq, NULL);
ffeequiv_set_is_save (eq, FALSE);
ffeequiv_set_is_init (eq, FALSE);
eq->next->previous = eq;
eq->previous->next = eq;
return eq;
}
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;
}
}
void
ffeequiv_update_init (ffeequiv eq)
{
ffebld list;
ffebld item;
ffebld expr;
if (eq->is_init)
return;
eq->is_init = TRUE;
if ((eq->common != NULL)
&& !ffesymbol_is_init (eq->common))
ffesymbol_update_init (eq->common);
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;
}
}
}
}
void
ffeequiv_update_save (ffeequiv eq)
{
ffebld list;
ffebld item;
ffebld expr;
if (eq->is_save)
return;
eq->is_save = TRUE;
if ((eq->common != NULL)
&& !ffesymbol_is_save (eq->common))
ffesymbol_update_save (eq->common);
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;
}
}
}
}