From 2298af0800b292f028298c1eaec42fd3033c4b9b Mon Sep 17 00:00:00 2001 From: =?utf8?q?Thomas=20K=C3=B6nig?= Date: Fri, 17 Apr 2020 19:53:45 +0200 Subject: [PATCH] Fix ICE on invalid, PR94090. The attached patch fixes an ICE on invalid: When the return type of a function was misdeclared with a wrong rank, we issued a warning, but not an error (unless with -pedantic); later on, an ICE ensued. Nothing good can come from wrongly declaring a function type (considering the ABI), so I changed that into a hard error. 2020-04-17 Thomas Koenig 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-17 Thomas Koenig PR fortran/94090 * gfortran.dg/interface_46.f90: New test. --- gcc/fortran/ChangeLog | 12 ++++++++ gcc/fortran/gfortran.h | 3 +- gcc/fortran/interface.c | 14 +++++++-- gcc/fortran/resolve.c | 22 ++++++++----- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/interface_46.f90 | 36 ++++++++++++++++++++++ 6 files changed, 80 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_46.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 515b91210f4..2f99ce24599 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2020-04-17 Thomas Koenig + + 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-15 Fritz Reese Linus Koenig 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) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6c96253c1d1..15f5cb2a633 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2020-04-17 Thomas Koenig + + PR fortran/94090 + * gfortran.dg/interface_46.f90: New test. + 2020-04-17 Richard Sandiford * gcc.target/aarch64/sve/cost_model_2.c: New test. diff --git a/gcc/testsuite/gfortran.dg/interface_46.f90 b/gcc/testsuite/gfortran.dg/interface_46.f90 new file mode 100644 index 00000000000..c1d87638fbe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_46.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR 94090 - this used to cause an ICE. +! Test case by José Rui Faustino de Sousa. +function cntf(a) result(s) + implicit none + + integer, intent(in) :: a(:) + + integer :: s(3) + + s = [1, 2, 3] + return +end function cntf + +program ice_p + + implicit none + + interface + function cntf(a) result(s) ! { dg-error "Rank mismatch in function result" } + implicit none + integer, intent(in) :: a(:) + integer :: s ! (3) <- Ups! + end function cntf + end interface + + integer, parameter :: n = 9 + + integer :: arr(n) + + integer :: s(3) + + s = cntf(arr) + stop + +end program ice_p -- 2.30.2