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  <tkoenig@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-17  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/94090
	* gfortran.dg/interface_46.f90: New test.

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 515b91210f49a03650de2b7dcc93af30801643c0..2f99ce24599fcfe571574860812ab8a13c0fb336 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2020-04-17  Thomas Koenig  <tkoenig@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-15  Fritz Reese  <foreese@gcc.gnu.org>
        Linus Koenig <link@sig-st.de>
 

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0d77386ddae07581b85e3b9c5dd9f4aaed245d99..4e1da8c88a030750d21c264c37d0e78bf736263b 100644 (file)
--- 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 8f041f0a0a880fb13ce51324026757a1f8a55a42..ba1c8bc322eade13caf726aae58b242e375bb02a 100644 (file)
--- 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 9b95200c241aa35f79067028d56a0c211398a652..2371ab23645f5f72a0f2f27506d3d59c67a449ae 100644 (file)
--- 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 6c96253c1d190a76f63524fa0cb45c985e559422..15f5cb2a6335e8a8da85afc093284e748fc4ffc8 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2020-04-17  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/94090
+       * gfortran.dg/interface_46.f90: New test.
+
 2020-04-17  Richard Sandiford  <richard.sandiford@arm.com>
 
        * 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 (file)
index 0000000..c1d8763
--- /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