ffesymbol
ffestu_sym_exec_transition (ffesymbol s)
{
ffeinfoKind skd;
ffeinfoWhere swh;
ffeinfoKind nkd;
ffeinfoWhere nwh;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffesymbolState ss;
ffesymbolState ns;
ffeintrinGen gen;
ffeintrinSpec spec;
ffeintrinImp imp;
bool needs_type = TRUE; /* Implicit type assignment might be
necessary. */
bool resolve_intrin = TRUE; /* Might need to resolve intrinsic. */
assert (s != NULL);
sa = ffesymbol_attrs (s);
skd = ffesymbol_kind (s);
swh = ffesymbol_where (s);
ss = ffesymbol_state (s);
switch (ss)
{
case FFESYMBOL_stateNONE:
return s; /* Assume caller will handle it. */
case FFESYMBOL_stateSEEN:
break;
case FFESYMBOL_stateUNCERTAIN:
ffestorag_exec_layout (s);
return s; /* Already processed this one, or not
necessary. */
case FFESYMBOL_stateUNDERSTOOD:
if (skd == FFEINFO_kindNAMELIST)
{
ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
ffestu_list_exec_transition_ (ffesymbol_namelist (s));
}
else if ((swh == FFEINFO_whereLOCAL)
&& ((skd == FFEINFO_kindFUNCTION)
|| (skd == FFEINFO_kindSUBROUTINE)))
{
ffestu_dummies_transition_ (ffecom_sym_exec_transition,
ffesymbol_dummyargs (s));
if ((skd == FFEINFO_kindFUNCTION)
&& !ffeimplic_establish_symbol (s))
ffesymbol_error (s, ffesta_tokens[0]);
}
ffesymbol_reference (s, NULL, FALSE);
ffestorag_exec_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
return s;
default:
assert ("bad status" == NULL);
return s;
}
ns = FFESYMBOL_stateUNDERSTOOD; /* Only a few UNCERTAIN exceptions. */
na = sa;
nkd = skd;
nwh = swh;
assert (!(sa & FFESYMBOL_attrsANY));
if (sa & FFESYMBOL_attrsCOMMON)
{
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereCOMMON;
}
else if (sa & FFESYMBOL_attrsRESULT)
{ /* Result variable for function. */
assert (!(sa & ~(FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereRESULT;
}
else if (sa & FFESYMBOL_attrsSFUNC)
{ /* Statement function. */
assert (!(sa & ~(FFESYMBOL_attrsSFUNC
| FFESYMBOL_attrsTYPE)));
nkd = FFEINFO_kindFUNCTION;
nwh = FFEINFO_whereCONSTANT;
}
else if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
{
nkd = FFEINFO_kindFUNCTION;
if (sa & FFESYMBOL_attrsDUMMY)
nwh = FFEINFO_whereDUMMY;
else
{
if (ffesta_is_entry_valid)
{
nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL. */
ns = FFESYMBOL_stateUNCERTAIN;
}
else
nwh = FFEINFO_whereGLOBAL;
}
}
else
/* No TYPE. */
{
nkd = FFEINFO_kindNONE; /* FUNCTION, SUBROUTINE, BLOCKDATA. */
needs_type = FALSE; /* Only gets type if FUNCTION. */
ns = FFESYMBOL_stateUNCERTAIN;
if (sa & FFESYMBOL_attrsDUMMY)
nwh = FFEINFO_whereDUMMY; /* Not BLOCKDATA. */
else
{
if (ffesta_is_entry_valid)
nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL. */
else
nwh = FFEINFO_whereGLOBAL;
}
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE /* Possible. */
| FFESYMBOL_attrsADJUSTS /* Possible. */
| FFESYMBOL_attrsANYLEN /* Possible. */
| FFESYMBOL_attrsANYSIZE /* Possible. */
| FFESYMBOL_attrsARRAY /* Possible. */
| FFESYMBOL_attrsDUMMY /* Have it. */
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG /* Possible. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nwh = FFEINFO_whereDUMMY;
if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
na = FFESYMBOL_attrsetNONE;
if (sa & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG))
nkd = FFEINFO_kindENTITY;
else if (sa & FFESYMBOL_attrsDUMMY) /* Still okay. */
{
if (!(sa & FFESYMBOL_attrsTYPE))
needs_type = FALSE; /* Don't assign type to SUBROUTINE! */
nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION, SUBROUTINE. */
ns = FFESYMBOL_stateUNCERTAIN;
}
}
else if (sa & FFESYMBOL_attrsADJUSTS)
{ /* Must be DUMMY or COMMON at some point. */
assert (!(sa & (FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS /* Have it. */
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV /* Possible. */
| FFESYMBOL_attrsINIT /* Possible. */
| FFESYMBOL_attrsNAMELIST /* Possible. */
| FFESYMBOL_attrsSFARG /* Possible. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
if (sa & FFESYMBOL_attrsEQUIV)
{
if ((ffesymbol_equiv (s) == NULL)
|| (ffeequiv_common (ffesymbol_equiv (s)) == NULL))
na = FFESYMBOL_attrsetNONE; /* Not equiv'd into COMMON. */
else
nwh = FFEINFO_whereCOMMON;
}
else if (!ffesta_is_entry_valid
|| (sa & (FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST)))
na = FFESYMBOL_attrsetNONE;
else
nwh = FFEINFO_whereDUMMY;
}
else if (sa & FFESYMBOL_attrsSAVE)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsEQUIV)
{
assert (!(sa & FFESYMBOL_attrsCOMMON)); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS /* Possible. */
| FFESYMBOL_attrsARRAY /* Possible. */
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV /* Have it. */
| FFESYMBOL_attrsINIT /* Possible. */
| FFESYMBOL_attrsNAMELIST /* Possible. */
| FFESYMBOL_attrsSAVE /* Possible. */
| FFESYMBOL_attrsSFARG /* Possible. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
nwh = ffestu_equiv_ (s);
}
else if (sa & FFESYMBOL_attrsNAMELIST)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsSAVE))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY /* Possible. */
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT /* Possible. */
| FFESYMBOL_attrsNAMELIST /* Have it. */
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG /* Possible. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsINIT)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY /* Possible. */
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT /* Have it. */
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG /* Possible. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSAVE))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG /* Have it. */
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
if (ffesta_is_entry_valid)
{
nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */
ns = FFESYMBOL_stateUNCERTAIN;
}
else
nwh = FFEINFO_whereLOCAL;
}
else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
{
assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsTYPE)));
nkd = FFEINFO_kindENTITY;
if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
na = FFESYMBOL_attrsetNONE;
if (sa & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsANYSIZE))
nwh = FFEINFO_whereDUMMY;
else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
/* Still okay. */
{
nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */
ns = FFESYMBOL_stateUNCERTAIN;
}
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN /* Possible. */
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY /* Have it. */
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsTYPE))); /* Possible. */
nkd = FFEINFO_kindENTITY;
if (sa & FFESYMBOL_attrsANYLEN)
{
assert (ffesta_is_entry_valid); /* Already diagnosed. */
nwh = FFEINFO_whereDUMMY;
}
else
{
if (ffesta_is_entry_valid)
{
nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */
ns = FFESYMBOL_stateUNCERTAIN;
}
else
nwh = FFEINFO_whereLOCAL;
}
}
else if (sa & FFESYMBOL_attrsANYLEN)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsRESULT))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN /* Have it. */
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsTYPE))); /* Have it too. */
if (ffesta_is_entry_valid)
{
nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */
nwh = FFEINFO_whereNONE; /* DUMMY, INTRINSIC, RESULT. */
ns = FFESYMBOL_stateUNCERTAIN;
resolve_intrin = FALSE;
}
else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE,
&gen, &spec, &imp))
{
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_generic (s, gen);
ffesymbol_set_specific (s, spec);
ffesymbol_set_implementation (s, imp);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNONE,
FFEINFO_whereINTRINSIC,
FFETARGET_charactersizeNONE));
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, NULL, FALSE);
ffestorag_exec_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
return s;
}
else
{ /* SPECIAL: can't have CHAR*(*) var in
PROGRAM/BLOCKDATA, unless it isn't
referenced anywhere in the code. */
ffesymbol_signal_change (s); /* Can't touch this. */
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, NULL, FALSE);
ffestorag_exec_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
return s;
}
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsSFUNC)));
assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsINTRINSIC /* UNDERSTOOD. */
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsSFUNC
| FFESYMBOL_attrsTYPE))); /* Have it. */
nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */
nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
ns = FFESYMBOL_stateUNCERTAIN;
resolve_intrin = FALSE;
}
else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK))
{ /* COMMON block. */
assert (!(sa & ~(FFESYMBOL_attrsCBLOCK
| FFESYMBOL_attrsSAVECBLOCK)));
if (sa & FFESYMBOL_attrsCBLOCK)
ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
else
ffesymbol_set_commonlist (s, NULL);
ffestu_list_exec_transition_ (ffesymbol_commonlist (s));
nkd = FFEINFO_kindCOMMON;
nwh = FFEINFO_whereLOCAL;
needs_type = FALSE;
}
else
{ /* First seen in stmt func definition. */
assert (sa == FFESYMBOL_attrsetNONE);
assert ("Why are we here again?" == NULL); /* ~~~~~ */
nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */
nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL, LOCAL. */
ns = FFESYMBOL_stateUNCERTAIN; /* Will get repromoted by caller. */
needs_type = FALSE;
}
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, ffesta_tokens[0]);
else if (!(na & FFESYMBOL_attrsANY)
&& (needs_type || (nkd != skd) || (nwh != swh)
|| (na != sa) || (ns != ss)))
{
ffesymbol_signal_change (s);
ffesymbol_set_attrs (s, na); /* Establish new info. */
ffesymbol_set_state (s, ns);
if ((ffesymbol_common (s) == NULL)
&& (ffesymbol_equiv (s) != NULL))
ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s)));
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
nkd,
nwh,
ffesymbol_size (s)));
if (needs_type && !ffeimplic_establish_symbol (s))
ffesymbol_error (s, ffesta_tokens[0]);
else if (resolve_intrin)
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, NULL, FALSE);
ffestorag_exec_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
}
return s;
}
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; /* Already laid out. */
switch (ffesymbol_kind (s))
{
default:
return; /* Do nothing. */
case FFEINFO_kindENTITY:
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
if (ffesymbol_equiv (s) != NULL)
return; /* Let ffeequiv handle this guy. */
if (ffesymbol_rank (s) == 0)
num_elements = 1;
else
{
if (ffebld_op (ffesymbol_arraysize (s))
!= FFEBLD_opCONTER)
return; /* An adjustable local array, just like a dummy. */
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; /* Initializations happen at sym level. */
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); /* Init completed before, but
we didn't have a storage
object for it; maybe back
end wants to see the sym
again now. */
ffesymbol_signal_unreported (s);
return;
case FFEINFO_whereCOMMON:
return; /* Allocate storage for entire common block
at once. */
case FFEINFO_whereDUMMY:
return; /* Don't do anything about dummies for now. */
case FFEINFO_whereRESULT:
case FFEINFO_whereIMMEDIATE:
case FFEINFO_whereCONSTANT:
case FFEINFO_whereNONE:
return; /* These don't get storage (esp. NONE, which
is UNCERTAIN). */
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; /* Initializations happen here. */
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
{ /* Special case for empty common area:
NONE/NONE means nothing. */
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; /* Ignore any symbols that have errors. */
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)
{ /* Warn about padding in the midst of a
common area. */
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; /* Initializations happen in COMMON block. */
stv->init = NULL;
stv->accretion = NULL;
stv->symbol = var;
stv->size = size;
if (!ffetarget_offset_add (&stv->offset, st->size, pad))
{ /* Common block size plus pad, complain if
overflow. */
ffetarget_offset_overflow (ffesymbol_text (s));
}
if (!ffetarget_offset_add (&st->size, stv->offset, stv->size))
{ /* Adjust size of common block, complain if
overflow. */
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; /* Must move inits over to COMMON's
ffestorag. */
}
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); /* Gather subordinate inits into one init. */
ffesymbol_signal_unreported (s);
return;
}
}
