void
ffesymbol_error (ffesymbol s, ffelexToken t)
{
if ((t != NULL)
&& ffest_ffebad_start (FFEBAD_SYMERR))
{
ffebad_string (ffesymbol_text (s));
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s));
ffebad_finish ();
}
if (ffesymbol_attr (s, FFESYMBOL_attrANY))
return;
ffesymbol_signal_change (s); /* May need to back up to previous version. */
if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
|| (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
ffesymbol_set_attr (s, FFESYMBOL_attrANY);
ffesymbol_set_info (s, ffeinfo_new_any ());
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
if (s->check_state == FFESYMBOL_checkstatePENDING_)
ffelex_token_kill (s->check_token);
s->check_state = FFESYMBOL_checkstateCHECKED_;
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
ffesymbol
ffestu_sym_end_transition (ffesymbol s)
{
ffeinfoKind skd;
ffeinfoWhere swh;
ffeinfoKind nkd;
ffeinfoWhere nwh;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffesymbolState ss;
ffesymbolState ns;
bool needs_type = TRUE; /* Implicit type assignment might be
necessary. */
assert (s != NULL);
ss = ffesymbol_state (s);
sa = ffesymbol_attrs (s);
skd = ffesymbol_kind (s);
swh = ffesymbol_where (s);
switch (ss)
{
case FFESYMBOL_stateUNCERTAIN:
if ((swh == FFEINFO_whereDUMMY)
&& (ffesymbol_numentries (s) == 0))
{ /* Not actually in any dummy list! */
ffesymbol_error (s, ffesta_tokens[0]);
return s;
}
else if (((swh == FFEINFO_whereLOCAL)
|| (swh == FFEINFO_whereNONE))
&& (skd == FFEINFO_kindENTITY)
&& ffestu_symter_end_transition_ (ffesymbol_dims (s)))
{ /* Bad dimension expressions. */
ffesymbol_error (s, NULL);
return s;
}
break;
case FFESYMBOL_stateUNDERSTOOD:
if ((swh == FFEINFO_whereLOCAL)
&& ((skd == FFEINFO_kindFUNCTION)
|| (skd == FFEINFO_kindSUBROUTINE)))
{
int n_args;
ffebld list;
ffebld item;
ffeglobalArgSummary as;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
bool array;
char *name = NULL;
ffestu_dummies_transition_ (ffecom_sym_end_transition,
ffesymbol_dummyargs (s));
n_args = ffebld_list_length (ffesymbol_dummyargs (s));
ffeglobal_proc_def_nargs (s, n_args);
for (list = ffesymbol_dummyargs (s), n_args = 0;
list != NULL;
list = ffebld_trail (list), ++n_args)
{
item = ffebld_head (list);
array = FALSE;
if (item != NULL)
{
bt = ffeinfo_basictype (ffebld_info (item));
kt = ffeinfo_kindtype (ffebld_info (item));
array = (ffeinfo_rank (ffebld_info (item)) > 0);
switch (ffebld_op (item))
{
case FFEBLD_opSTAR:
as = FFEGLOBAL_argsummaryALTRTN;
break;
case FFEBLD_opSYMTER:
name = ffesymbol_text (ffebld_symter (item));
as = FFEGLOBAL_argsummaryNONE;
switch (ffeinfo_kind (ffebld_info (item)))
{
case FFEINFO_kindFUNCTION:
as = FFEGLOBAL_argsummaryFUNC;
break;
case FFEINFO_kindSUBROUTINE:
as = FFEGLOBAL_argsummarySUBR;
break;
case FFEINFO_kindNONE:
as = FFEGLOBAL_argsummaryPROC;
break;
default:
break;
}
if (as != FFEGLOBAL_argsummaryNONE)
break;
/* Fall through. */
default:
if (bt == FFEINFO_basictypeCHARACTER)
as = FFEGLOBAL_argsummaryDESCR;
else
as = FFEGLOBAL_argsummaryREF;
break;
}
}
else
{
as = FFEGLOBAL_argsummaryNONE;
bt = FFEINFO_basictypeNONE;
kt = FFEINFO_kindtypeNONE;
}
ffeglobal_proc_def_arg (s, n_args, name, as, bt, kt, array);
}
}
else if (swh == FFEINFO_whereDUMMY)
{
if (ffesymbol_numentries (s) == 0)
{ /* Not actually in any dummy list! */
ffesymbol_error (s, ffesta_tokens[0]);
return s;
}
if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
{ /* Bad dimension expressions. */
ffesymbol_error (s, NULL);
return s;
}
}
else if ((swh == FFEINFO_whereLOCAL)
&& ffestu_symter_end_transition_ (ffesymbol_dims (s)))
{ /* Bad dimension expressions. */
ffesymbol_error (s, NULL);
return s;
}
ffestorag_end_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
return s;
default:
assert ("bad status" == NULL);
return s;
}
ns = FFESYMBOL_stateUNDERSTOOD;
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
nkd = skd;
nwh = swh;
/* Figure out what kind of object we've got based on previous declarations
of or references to the object. */
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
nwh = FFEINFO_whereGLOBAL;
else
/* Not TYPE. */
{
if (sa & FFESYMBOL_attrsDUMMY)
{ /* Not TYPE. */
ns = FFESYMBOL_stateUNCERTAIN; /* FUNCTION/SUBROUTINE. */
needs_type = FALSE; /* Don't assign type to SUBROUTINE! */
}
else if (sa & FFESYMBOL_attrsACTUALARG)
{ /* Not DUMMY or TYPE. */
ns = FFESYMBOL_stateUNCERTAIN; /* FUNCTION/SUBROUTINE. */
needs_type = FALSE; /* Don't assign type to SUBROUTINE! */
}
else
/* Not ACTUALARG, DUMMY, or TYPE. */
{ /* This is an assumption, essentially. */
nkd = FFEINFO_kindBLOCKDATA;
nwh = FFEINFO_whereGLOBAL;
needs_type = FALSE;
}
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
/* Honestly, this appears to be a guess. I can't find anyplace in the
standard that makes clear whether this unreferenced dummy argument
is an ENTITY or a FUNCTION. And yet, for the f2c interface, picking
one is critical for CHARACTER entities because it determines whether
to expect an additional argument specifying the length of an ENTITY
that is not expected (or needed) for a FUNCTION. HOWEVER, F90 makes
this guess a correct one, and it does seem that the Section 18 Notes
in Appendix B of F77 make it clear the F77 standard at least
intended to make this guess correct as well, so this seems ok. */
nkd = FFEINFO_kindENTITY;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
{
ffesymbol_error (s, NULL);
return s;
}
if (sa & FFESYMBOL_attrsADJUSTABLE)
{ /* Not actually in any dummy list! */
if (ffe_is_pedantic ()
&& ffebad_start_msg ("Local adjustable symbol `%A' at %0",
FFEBAD_severityPEDANTIC))
{
ffebad_string (ffesymbol_text (s));
ffebad_here (0, ffesymbol_where_line (s),
ffesymbol_where_column (s));
ffebad_finish ();
}
}
nwh = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
nwh = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG))); /* Handled above. */
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (sa & FFESYMBOL_attrsANYLEN)
{ /* Can't touch this. */
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, NULL, FALSE);
ffestorag_end_layout (s);
ffesymbol_signal_unreported (s); /* For debugging purposes. */
return s;
}
nkd = FFEINFO_kindENTITY;
nwh = FFEINFO_whereLOCAL;
}
else
assert ("unexpected attribute set" == NULL);
/* Now see what we've got for a new object: NONE means a new error cropped
up; ANY means an old error to be ignored; otherwise, everything's ok,
update the object (symbol) and continue on. */
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, ffesta_tokens[0]);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
ffesymbol_set_attrs (s, na); /* Establish new info. */
ffesymbol_set_state (s, ns);
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
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, NULL, FALSE);
ffestorag_end_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;
}
}
