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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7819bd4..82164d7 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,10 @@
 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.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f66ed93..d2a4949 100644 (file)
--- a/gcc/fortran/check.c
+++ b/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;
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b11a1bf..cdc7179 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 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.

diff --git a/gcc/testsuite/gfortran.dg/pr91649.f90 b/gcc/testsuite/gfortran.dg/pr91649.f90
new file mode 100644 (file)
index 0000000..0e6acb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr91649.f90
@@ -0,0 +1,23 @@
+! { 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
+