diff mbox series

PR fortran/91565 -- Extra checks on ORDER

Message ID 20190827220053.GA19648@troutmask.apl.washington.edu
State New
Headers show
Series PR fortran/91565 -- Extra checks on ORDER | expand

Commit Message

Steve Kargl Aug. 27, 2019, 10 p.m. UTC 
The attached ptch implements additional checks on the
ORDER dummy argument for the RESHAPE intrinsic function.
Built and regression tested on x86_64-*-freebsd.  OK to
commit?

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

	PR fortran/91565
	* simplify.c (gfc_simplify_reshape): Add additional checks of the
	ORDER dummy argument.

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

	PR fortran/91565
	* gfortran.dg/pr91565.f90: New test.

Comments

Janne Blomqvist Aug. 28, 2019, 7:19 a.m. UTC | #1 
On Wed, Aug 28, 2019 at 1:01 AM Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
>
> The attached ptch implements additional checks on the
> ORDER dummy argument for the RESHAPE intrinsic function.
> Built and regression tested on x86_64-*-freebsd.  OK to
> commit?

Ok.
diff mbox series

Patch

Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(revision 274961)
+++ gcc/fortran/simplify.c	(working copy)
@@ -6495,7 +6503,14 @@  gfc_simplify_real (gfc_expr *e, gfc_expr *k)
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
+     warning.  */
+  tmp1 = warn_conversion;
+  tmp2 = warn_conversion_extra;
+  warn_conversion = warn_conversion_extra = 0;
   result = gfc_convert_constant (e, BT_REAL, kind);
+  warn_conversion = tmp1;
+  warn_conversion_extra = tmp2;
   if (result == &gfc_bad_expr)
     return &gfc_bad_expr;
 
@@ -6668,6 +6683,9 @@  gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
   mpz_init (index);
   rank = 0;
 
+  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+    x[i] = 0;
+
   for (;;)
     {
       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
@@ -6692,9 +6710,29 @@  gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
     }
   else
     {
-      for (i = 0; i < rank; i++)
-	x[i] = 0;
+      mpz_t size;
+      int order_size, shape_size;
 
+      if (order_exp->rank != shape_exp->rank)
+	{
+	  gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
+		     &order_exp->where, &shape_exp->where);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_array_size (shape_exp, &size);
+      shape_size = mpz_get_ui (size);
+      mpz_clear (size);
+      gfc_array_size (order_exp, &size);
+      order_size = mpz_get_ui (size);
+      mpz_clear (size);
+      if (order_size != shape_size)
+	{
+	  gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
+		     &order_exp->where, &shape_exp->where);
+	  return &gfc_bad_expr;
+	}
+
       for (i = 0; i < rank; i++)
 	{
 	  e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
@@ -6704,7 +6742,12 @@  gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
 
 	  gcc_assert (order[i] >= 1 && order[i] <= rank);
 	  order[i]--;
-	  gcc_assert (x[order[i]] == 0);
+	  if (x[order[i]] != 0)
+	    {
+	      gfc_error ("ORDER at %L is not a permutation of the size of "
+			 "SHAPE at %L", &order_exp->where, &shape_exp->where);
+	      return &gfc_bad_expr;
+	    }
 	  x[order[i]] = 1;
 	}
     }
Index: gcc/testsuite/gfortran.dg/pr91565.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr91565.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr91565.f90	(working copy)
@@ -0,0 +1,17 @@ 
+! { dg-do compile }
+! PR fortran/91565
+! Contributed by Gerhard Steinmetz
+program p
+   integer, parameter :: a(2) = [2,2]              ! { dg-error "\(1\)" }
+   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "not a permutation" }
+end
+
+subroutine foo
+   integer, parameter :: a(1) = 1                  ! { dg-error "\(1\)" }
+   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" }
+end
+
+subroutine bar
+   integer, parameter :: a(1,2) = 1                ! { dg-error "\(1\)" }
+   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" }
+end