int
yyparse ()
#else
#error
#endif
{
ffewhereFile wf;
if (ffe_is_version ())
fprintf (stderr, "GNU Fortran Front End version %s\n", ffe_version_string);
#if FFECOM_targetCURRENT == FFECOM_targetFFE
ffe_init_0 ();
{
int strings_processed;
for (--argc, ++argv; argc > 0; argc -= strings_processed, argv += strings_processed)
{
strings_processed = ffe_decode_option (argc, argv);
if (strings_processed == 0)
{
fprintf (stderr, "Unrecognized option: %s\n", argv[0]);
strings_processed = 1;
}
}
}
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (!ffe_is_pedantic ())
ffe_set_is_pedantic (pedantic);
#else
#error
#endif
#if FFECOM_targetCURRENT == FFECOM_targetFFE
wf = ffewhere_file_new (NAME_OF_STDIN, strlen (NAME_OF_STDIN));
ffecom_file (NAME_OF_STDIN);
ffe_file (wf, stdin);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
wf = ffewhere_file_new (main_input_filename, strlen (main_input_filename));
ffecom_file (main_input_filename);
ffe_file (wf, finput);
#else
#error
#endif
#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecom_finish_compile ();
return 0;
#elif FFECOM_targetCURRENT == FFECOM_targetFFE
ffe_terminate_0 ();
exit (0);
#else
#error
#endif
}
void
ffe_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
const char *fname;
ffewhereFile wf;
if (ffe_is_version ())
fprintf (stderr, "GNU Fortran Front End version %s\n", version_string);
if (!ffe_is_pedantic ())
ffe_set_is_pedantic (pedantic);
fname = main_input_filename ? main_input_filename : "<stdin>";
wf = ffewhere_file_new (fname, strlen (fname));
ffecom_file (fname);
ffe_file (wf, finput);
ffecom_finish_compile ();
}
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; /* No need to do anything further. */
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;
}
}
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;
}