diff mbox series

PR fortran/91649 -- Add additional checking for FINDLOC

Message ID 20191010230726.GA23968@troutmask.apl.washington.edu
State New
Headers show
Series PR fortran/91649 -- Add additional checking for FINDLOC | expand

Commit Message

Steve Kargl Oct. 10, 2019, 11:07 p.m. UTC 
The attached patch has been tested on x86_64-*-freebsd.
OK to commit?

The patch adds additional check for the ARRAY and VALUE
arguments.  First, ARRAY and VALUE need to be type
conformant, but gfortran did not check for the CHARACTER
type nor for numeric types.  Second, ARRAY must be an
intrinsic type, which implies that VALUE must also be
an intrinsic type.

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

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

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

	PR fortran/91649
	* gfortran.dg/pr91649.f90

Comments

Thomas Koenig Oct. 11, 2019, 5:42 a.m. UTC | #1 
Steve,

> The attached patch has been tested on x86_64-*-freebsd.
> OK to commit?

OK. Thanks a lot for the patch!

Regards

	Thomas
diff mbox series

Patch

Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 276837)
+++ gcc/fortran/check.c	(working copy)
@@ -3879,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;
@@ -3946,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;
 }
 
 
Index: gcc/testsuite/gfortran.dg/pr91649.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr91649.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr91649.f90	(working copy)
@@ -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
+