re PR fortran/91649 (ICE in gfc_resolve_findloc, at fortran/iresolve.c:1827)

2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/91649
	check.c (gfc_check_findloc): Additional checking for valid arguments

2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/91649
	* gfortran.dg/pr91649.f90: New test.

From-SVN: r276900

gcc/fortran/ChangeLog

 2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>
 
+	PR fortran/91649
+	check.c (gfc_check_findloc): Additional checking for valid arguments
+
+2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>
+
 	PR fortran/91715
 	* decl.c (gfc_match_prefix): If matching a type-spec returns an error,
 	it's an error so re-act correctly.

gcc/fortran/check.c

@@ -3921,26 +3921,27 @@ bool
 gfc_check_findloc (gfc_actual_arglist *ap)
 {
   gfc_expr *a, *v, *m, *d, *k, *b;
+  bool a1, v1;
 
   a = ap->expr;
   if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
     return false;
 
   v = ap->next->expr;
-  if (!scalar_check (v,1))
+  if (!intrinsic_type_check (v, 1) || !scalar_check (v,1))
     return false;
 
-  /* Check if the type is compatible.  */
+  /* Check if the type are both logical.  */
+  a1 = a->ts.type == BT_LOGICAL;
+  v1 = v->ts.type == BT_LOGICAL;
+  if ((a1 && !v1) || (!a1 && v1))
+    goto incompat;
 
-  if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
-      || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
-    {
-      gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
-		 "conformance to argument %qs at %L",
-		 gfc_current_intrinsic_arg[0]->name,
-		 gfc_current_intrinsic, &a->where,
-		 gfc_current_intrinsic_arg[1]->name, &v->where);
-    }
+  /* Check if the type are both character.  */
+  a1 = a->ts.type == BT_CHARACTER;
+  v1 = v->ts.type == BT_CHARACTER;
+  if ((a1 && !v1) || (!a1 && v1))
+    goto incompat;
 	 
   d = ap->next->next->expr;
   m = ap->next->next->next->expr;
@@ -3988,6 +3989,14 @@ gfc_check_findloc (gfc_actual_arglist *ap)
     return false;
 
   return true;
+
+incompat:
+  gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
+	     "conformance to argument %qs at %L",
+	     gfc_current_intrinsic_arg[0]->name,
+	     gfc_current_intrinsic, &a->where,
+	     gfc_current_intrinsic_arg[1]->name, &v->where);
+  return false;
 }
 
 

gcc/testsuite/ChangeLog

 2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>
 
+	PR fortran/91649
+	* gfortran.dg/pr91649.f90: New test.
+
+2019-10-11  Steven G. Kargl  <kargl@gcc.gnu.org>
+
 	PR fortran/91715
 	* gfortran.dg/function_kinds_5.f90: Prune run-on error.
 	* gfortran.dg/pr85543.f90: Ditto.

gcc/testsuite/gfortran.dg/pr91649.f90

+! { dg-do compile }
+! PR fortran/91649
+! Code originally contributed by Gerhard Steinmetz
+subroutine p
+   logical :: back = .true.
+   integer :: x(1) = findloc([1, 2, 1], '1', back=back) ! { dg-error "must be in type conformance" }
+   print *, x
+end
+
+subroutine q
+   type t
+   end type
+   logical :: back = .false.
+   integer :: x(1) = findloc([1, 2, 1], t(), back=back) ! { dg-error "must be of intrinsic type" }
+   print *, x
+end
+
+subroutine s
+   character(4) :: c = '1234'
+   integer :: x(1) = findloc([1, 2, 1], c, back=.true.) ! { dg-error "must be in type conformance" }
+   print *, x
+end
+