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;
}
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;
}