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 <tkoe...@gcc.gnu.org> 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 <tkoe...@gcc.gnu.org> 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) {