Hello world,
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.
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 75a50c999b7..5b375c65694 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 ccd2a5e3b7d..36659790ddf 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2605,11 +2605,24 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
/* Turn erros into warnings with -std=gnu and -std=legacy. */
gfc_errors_to_warnings (true);
+ /* If a function returns a wrong type, this can lead to
+ all kinds of ICEs and wrong code; issue a hard error
+ in this case. */
+
+ 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:"
+ if (bad_result_characteristics)
+ {
+ gfc_errors_to_warnings (false);
+ gfc_error ("Interface mismatch in global procedure %qs at %L:"
" %s", sym->name, &sym->declared_at, reason);
+ }
+ else
+ gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
+ " %s", sym->name, &sym->declared_at, reason);
goto done;
}
}
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
! { 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
