#include "proj.h"
#include "storag.h"
#include "data.h"
#include "malloc.h"
#include "symbol.h"
#include "target.h"
ffestoragList_ ffestorag_list_;
static ffetargetOffset ffestorag_local_size_;
static bool ffestorag_reported_;
#define ffestorag_next_(s) ((s)->next)
#define ffestorag_previous_(s) ((s)->previous)
void
ffestorag_drive (ffestoragList sl, void (*fn) (ffestorag mst, ffestorag st),
ffestorag mst)
{
ffestorag st;
for (st = sl->first;
st != (ffestorag) &sl->first;
st = st->next)
(*fn) (mst, st);
}
void
ffestorag_dump (ffestorag s)
{
if (s == NULL)
{
fprintf (dmpout, "(no storage object)");
return;
}
switch (s->type)
{
case FFESTORAG_typeCBLOCK:
fprintf (dmpout, "CBLOCK ");
break;
case FFESTORAG_typeCOMMON:
fprintf (dmpout, "COMMON ");
break;
case FFESTORAG_typeLOCAL:
fprintf (dmpout, "LOCAL ");
break;
case FFESTORAG_typeEQUIV:
fprintf (dmpout, "EQUIV ");
break;
default:
fprintf (dmpout, "?%d? ", s->type);
break;
}
if (s->symbol != NULL)
fprintf (dmpout, "\"%s\" ", ffesymbol_text (s->symbol));
fprintf (dmpout, "at %" ffetargetOffset_f "d size %" ffetargetOffset_f
"d, align loc%%%"
ffetargetAlign_f "u=%" ffetargetAlign_f "u, bt=%s, kt=%s",
s->offset,
s->size, (unsigned int) s->alignment, (unsigned int) s->modulo,
ffeinfo_basictype_string (s->basic_type),
ffeinfo_kindtype_string (s->kind_type));
if (s->equivs_.first != (ffestorag) &s->equivs_.first)
{
ffestorag sq;
fprintf (dmpout, " with equivs");
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (ffestorag_previous_ (sq) == (ffestorag) &s->equivs_.first)
fputc (' ', dmpout);
else
fputc (',', dmpout);
fprintf (dmpout, "%s", ffesymbol_text (ffestorag_symbol (sq)));
}
}
}
void
ffestorag_init_2 ()
{
ffestorag_list_.first = ffestorag_list_.last
= (ffestorag) &ffestorag_list_.first;
ffestorag_local_size_ = 0;
ffestorag_reported_ = FALSE;
}
void
ffestorag_end_layout (ffesymbol s)
{
if (ffesymbol_storage (s) != NULL)
return;
ffestorag_exec_layout (s);
#if 0
assert (ffesymbol_storage (s) == NULL);
#endif
}
void
ffestorag_exec_layout (ffesymbol s)
{
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetOffset size;
ffetargetOffset num_elements;
ffetargetAlign pad;
ffestorag st;
ffestorag stv;
ffebld list;
ffebld item;
ffesymbol var;
bool init;
if (ffesymbol_storage (s) != NULL)
return;
switch (ffesymbol_kind (s))
{
default:
return;
case FFEINFO_kindENTITY:
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
if (ffesymbol_equiv (s) != NULL)
return;
if (ffesymbol_rank (s) == 0)
num_elements = 1;
else
{
if (ffebld_op (ffesymbol_arraysize (s))
!= FFEBLD_opCONTER)
return;
num_elements
= ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (s)));
}
ffetarget_layout (ffesymbol_text (s), &alignment, &modulo,
&size, ffesymbol_basictype (s),
ffesymbol_kindtype (s), ffesymbol_size (s),
num_elements);
st = ffestorag_new (ffestorag_list_master ());
st->parent = NULL;
st->init = NULL;
st->accretion = NULL;
st->symbol = s;
st->size = size;
st->offset = 0;
st->alignment = alignment;
st->modulo = modulo;
st->type = FFESTORAG_typeLOCAL;
st->basic_type = ffesymbol_basictype (s);
st->kind_type = ffesymbol_kindtype (s);
st->type_symbol = s;
st->is_save = ffesymbol_is_save (s);
st->is_init = ffesymbol_is_init (s);
ffesymbol_set_storage (s, st);
if (ffesymbol_is_init (s))
ffecom_notify_init_symbol (s);
ffesymbol_signal_unreported (s);
return;
case FFEINFO_whereCOMMON:
return;
case FFEINFO_whereDUMMY:
return;
case FFEINFO_whereRESULT:
case FFEINFO_whereIMMEDIATE:
case FFEINFO_whereCONSTANT:
case FFEINFO_whereNONE:
return;
default:
assert ("bad ENTITY where" == NULL);
return;
}
break;
case FFEINFO_kindCOMMON:
assert (ffesymbol_where (s) == FFEINFO_whereLOCAL);
st = ffestorag_new (ffestorag_list_master ());
st->parent = NULL;
st->init = NULL;
st->accretion = NULL;
st->symbol = s;
st->size = 0;
st->offset = 0;
st->alignment = 1;
st->modulo = 0;
st->type = FFESTORAG_typeCBLOCK;
if (ffesymbol_commonlist (s) != NULL)
{
var = ffebld_symter (ffebld_head (ffesymbol_commonlist (s)));
st->basic_type = ffesymbol_basictype (var);
st->kind_type = ffesymbol_kindtype (var);
st->type_symbol = var;
}
else
{
st->basic_type = FFEINFO_basictypeNONE;
st->kind_type = FFEINFO_kindtypeNONE;
st->type_symbol = NULL;
}
st->is_save = ffesymbol_is_save (s);
st->is_init = ffesymbol_is_init (s);
if (!ffe_is_mainprog ())
ffeglobal_save_common (s,
st->is_save || ffe_is_saveall (),
ffesymbol_where_line (s),
ffesymbol_where_column (s));
ffesymbol_set_storage (s, st);
init = FALSE;
for (list = ffesymbol_commonlist (s);
list != NULL;
list = ffebld_trail (list))
{
item = ffebld_head (list);
assert (ffebld_op (item) == FFEBLD_opSYMTER);
var = ffebld_symter (item);
if (ffesymbol_basictype (var) == FFEINFO_basictypeANY)
continue;
if (ffesymbol_rank (var) == 0)
num_elements = 1;
else
num_elements = ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (var)));
ffetarget_layout (ffesymbol_text (var), &alignment, &modulo,
&size, ffesymbol_basictype (var),
ffesymbol_kindtype (var), ffesymbol_size (var),
num_elements);
pad = ffetarget_align (&st->alignment, &st->modulo, st->size,
alignment, modulo);
if (pad != 0)
{
char padding[20];
sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
ffebad_start (FFEBAD_COMMON_PAD);
ffebad_string (padding);
ffebad_string (ffesymbol_text (var));
ffebad_string (ffesymbol_text (s));
ffebad_string ((pad == 1)
? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
ffebad_finish ();
}
stv = ffestorag_new (ffestorag_list_master ());
stv->parent = st;
stv->init = NULL;
stv->accretion = NULL;
stv->symbol = var;
stv->size = size;
if (!ffetarget_offset_add (&stv->offset, st->size, pad))
{
ffetarget_offset_overflow (ffesymbol_text (s));
}
if (!ffetarget_offset_add (&st->size, stv->offset, stv->size))
{
ffetarget_offset_overflow (ffesymbol_text (s));
}
stv->alignment = alignment;
stv->modulo = modulo;
stv->type = FFESTORAG_typeCOMMON;
stv->basic_type = ffesymbol_basictype (var);
stv->kind_type = ffesymbol_kindtype (var);
stv->type_symbol = var;
stv->is_save = st->is_save;
stv->is_init = st->is_init;
ffesymbol_set_storage (var, stv);
ffesymbol_signal_unreported (var);
ffestorag_update (st, var, ffesymbol_basictype (var),
ffesymbol_kindtype (var));
if (ffesymbol_is_init (var))
init = TRUE;
}
if (ffeequiv_layout_cblock (st))
init = TRUE;
ffeglobal_pad_common (s, st->modulo, ffesymbol_where_line (s),
ffesymbol_where_column (s));
if (init)
ffedata_gather (st);
ffesymbol_signal_unreported (s);
return;
}
}
ffestorag
ffestorag_new (ffestoragList sl)
{
ffestorag s;
s = (ffestorag) malloc_new_kp (ffe_pool_program_unit (), "ffestorag",
sizeof (*s));
s->next = (ffestorag) &sl->first;
s->previous = sl->last;
#ifdef FFECOM_storageHOOK
s->hook = FFECOM_storageNULL;
#endif
s->previous->next = s;
sl->last = s;
s->equivs_.first = s->equivs_.last = (ffestorag) &s->equivs_.first;
return s;
}
void
ffestorag_report ()
{
ffestorag s;
if (ffestorag_reported_)
return;
for (s = ffestorag_list_.first;
s != (ffestorag) &ffestorag_list_.first;
s = s->next)
{
if (s->symbol == NULL)
{
ffestorag_reported_ = TRUE;
fputs ("Storage area: ", dmpout);
ffestorag_dump (s);
fputc ('\n', dmpout);
}
}
}
void
ffestorag_update (ffestorag s, ffesymbol sym, ffeinfoBasictype bt,
ffeinfoKindtype kt)
{
if (s->basic_type == bt)
{
if (s->kind_type == kt)
return;
s->kind_type = FFEINFO_kindtypeNONE;
return;
}
switch (s->basic_type)
{
case FFEINFO_basictypeANY:
return;
case FFEINFO_basictypeCHARACTER:
any:
s->basic_type = FFEINFO_basictypeANY;
s->kind_type = FFEINFO_kindtypeANY;
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_MIXED_TYPES);
ffebad_string (ffesymbol_text (s->type_symbol));
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
}
return;
default:
if (bt == FFEINFO_basictypeCHARACTER)
goto any;
s->basic_type = FFEINFO_basictypeNONE;
s->kind_type = FFEINFO_kindtypeNONE;
return;
}
}
void
ffestorag_update_init (ffestorag s)
{
ffestorag sq;
if (s->is_init)
return;
s->is_init = TRUE;
if ((s->symbol != NULL)
&& !ffesymbol_is_init (s->symbol))
ffesymbol_update_init (s->symbol);
if (s->parent != NULL)
ffestorag_update_init (s->parent);
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (!sq->is_init)
ffestorag_update_init (sq);
}
}
void
ffestorag_update_save (ffestorag s)
{
ffestorag sq;
if (s->is_save)
return;
s->is_save = TRUE;
if ((s->symbol != NULL)
&& !ffesymbol_is_save (s->symbol))
ffesymbol_update_save (s->symbol);
if (s->parent != NULL)
ffestorag_update_save (s->parent);
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (!sq->is_save)
ffestorag_update_save (sq);
}
}