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.

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>
 

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 *);

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)

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)
     {

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.

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