Hi Fritz,
I wonder: could you simply replace the gfc_error_opt(0, ...) call with
gfc_error?
Yes. Looking back at the code, I think it can also be cleaned up
a little - turning the error to warnings is only needed on that
particular branch, and resetting it to the default can also
happen there, and at the target of a goto statement.
So, here's an updated patch. OK for trunk?
Regards
Thomas
2020-04-13 Thomas Koenig <[email protected]>
PR fortran/94090
* gfortran.dg (gfc_compare_interfaces): Add
optional argument bad_result_characteristics.
* interface.c (gfc_check_result_characteristics): Fix
whitespace.
(gfc_compare_interfaces): Handle new argument; return
true if function return values are wrong.
* resolve.c (resolve_global_procedure): Hard error if
the return value of a function is wrong.
2020-04-13 Thomas Koenig <[email protected]>
PR fortran/94090
* gfortran.dg/interface_46.f90: New test.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0d77386ddae..4e1da8c88a0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3445,7 +3445,8 @@ bool gfc_check_dummy_characteristics (gfc_symbol *,
gfc_symbol *,
bool gfc_check_result_characteristics (gfc_symbol *, gfc_symbol *,
char *, int);
bool gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
- char *, int, const char *, const char *);
+ char *, int, const char *, const char *,
+ bool *bad_result_characteristics = NULL);
void gfc_check_interfaces (gfc_namespace *);
bool gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 8f041f0a0a8..ba1c8bc322e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1529,7 +1529,7 @@ gfc_check_dummy_characteristics (gfc_symbol *s1,
gfc_symbol *s2,
bool
gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
- char *errmsg, int err_len)
+ char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
@@ -1695,12 +1695,16 @@ bool
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
int generic_flag, int strict_flag,
char *errmsg, int err_len,
- const char *p1, const char *p2)
+ const char *p1, const char *p2,
+ bool *bad_result_characteristics)
{
gfc_formal_arglist *f1, *f2;
gcc_assert (name2 != NULL);
+ if (bad_result_characteristics)
+ *bad_result_characteristics = false;
+
if (s1->attr.function && (s2->attr.subroutine
|| (!s2->attr.function && s2->ts.type == BT_UNKNOWN
&& gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
@@ -1726,7 +1730,11 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2,
const char *name2,
/* If both are functions, check result characteristics. */
if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
|| !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
- return false;
+ {
+ if (bad_result_characteristics)
+ *bad_result_characteristics = true;
+ return false;
+ }
}
if (s1->attr.pure && !s2->attr.pure)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9b95200c241..2371ab23645 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2601,21 +2601,27 @@ resolve_global_procedure (gfc_symbol *sym, locus
*where, int sub)
goto done;
}
- if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU))
- /* Turn erros into warnings with -std=gnu and -std=legacy. */
- gfc_errors_to_warnings (true);
-
+ bool bad_result_characteristics;
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
- reason, sizeof(reason), NULL, NULL))
+ reason, sizeof(reason), NULL, NULL,
+ &bad_result_characteristics))
{
- gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
- " %s", sym->name, &sym->declared_at, reason);
+ /* Turn erros into warnings with -std=gnu and -std=legacy,
+ unless a function returns a wrong type, which can lead
+ to all kinds of ICEs and wrong code. */
+
+ if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
+ && !bad_result_characteristics)
+ gfc_errors_to_warnings (true);
+
+ gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
+ sym->name, &sym->declared_at, reason);
+ gfc_errors_to_warnings (false);
goto done;
}
}
done:
- gfc_errors_to_warnings (false);
if (gsym->type == GSYM_UNKNOWN)
{
