{patch, fortran] PR37203: additional checks for RESHAPE

[Daniel Franke <franke dot daniel at gmail dot com>]

Hi all.

This patch adds additional argument checks for the RESHAPE intrinsic.
These checks are also implemented in simplify.c (gfc_simplify_reshape), but 
there they are only triggered if all arguments are constant. The implemented 
checks test each argument individually. 

I think that the checks during simplification could be removed, but I left 
them untouched for now.


gcc/fortran:
2009-08-04  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/37203
	* check.c (gfc_check_reshape): Additional checks for the
	SHAPE and ORDER arguments.

gcc/testsuite:
2009-08-04  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/37203
	* gfortran.dg/reshape_order_5.f90: New.
	* gfortran.dg/reshape_shape_1.f90: New.


Regression tested on i686-pc-linux-gnu. Ok for trunk?

Regards

	Daniel

Index: fortran/check.c
===================================================================
--- fortran/check.c	(revision 143046)
+++ fortran/check.c	(working copy)
@@ -2324,7 +2324,7 @@ gfc_check_reshape (gfc_expr *source, gfc
 {
   mpz_t size;
   mpz_t nelems;
-  int m;
+  int shape_size;
 
   if (array_check (source, 0) == FAILURE)
     return FAILURE;
@@ -2342,26 +2342,112 @@ gfc_check_reshape (gfc_expr *source, gfc
       return FAILURE;
     }
 
-  m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
+  shape_size = mpz_get_ui (size);
   mpz_clear (size);
 
-  if (m > 0)
+  if (shape_size <= 0)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 &shape->where);
+      return FAILURE;
+    }
+  else if (shape_size > GFC_MAX_DIMENSIONS)
     {
       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
 		 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
       return FAILURE;
     }
+  else if (shape->expr_type == EXPR_ARRAY)
+    {
+      gfc_expr *e;
+      int i = 0, extent;
+      while ((e = gfc_get_array_element (shape, i)) != NULL)
+	{
+	  if (e->expr_type != EXPR_CONSTANT)
+	    continue;
+
+	  gfc_extract_int (e, &extent);
+	  if (extent < 0)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			 "negative element (%d)", gfc_current_intrinsic_arg[1],
+			 gfc_current_intrinsic, &e->where, extent);
+	      return FAILURE;
+	    }
+	  i++;
+	}
+    }
 
   if (pad != NULL)
     {
       if (same_type_check (source, 0, pad, 2) == FAILURE)
 	return FAILURE;
+
       if (array_check (pad, 2) == FAILURE)
 	return FAILURE;
     }
 
-  if (order != NULL && array_check (order, 3) == FAILURE)
-    return FAILURE;
+  if (order != NULL)
+    {
+      if (array_check (order, 3) == FAILURE)
+	return FAILURE;
+
+      if (type_check (order, 3, BT_INTEGER) == FAILURE)
+	return FAILURE;
+
+      if (order->expr_type == EXPR_ARRAY)
+	{
+	  int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+	  gfc_expr *e;
+
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+	    perm[i] = 0;
+
+	  gfc_array_size (order, &size);
+	  order_size = mpz_get_ui (size);
+	  mpz_clear (size);
+
+	  if (order_size != shape_size)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			 "has wrong number of elements (%d/%d)", 
+			 gfc_current_intrinsic_arg[3],
+			 gfc_current_intrinsic, &order->where,
+			 order_size, shape_size);
+	      return FAILURE;
+	    }
+
+	  for (i = 1; i <= order_size; ++i)
+	    {
+	      e = gfc_get_array_element (order, i-1);
+	      if (e->expr_type != EXPR_CONSTANT)
+	        continue;
+
+	      gfc_extract_int (e, &dim);
+
+	      if (dim < 1 || dim > order_size)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			     "has out-of-range dimension (%d)", 
+			     gfc_current_intrinsic_arg[3],
+			     gfc_current_intrinsic, &e->where, dim);
+		  return FAILURE;
+		}
+
+	      if (perm[dim-1] != 0)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			     "invalid permutation of dimensions (dimension "
+			     "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+			     gfc_current_intrinsic, &e->where, dim);
+		  return FAILURE;
+		}
+
+	      perm[dim-1] = 1;
+	    }
+	}
+    }
 
   if (pad == NULL && shape->expr_type == EXPR_ARRAY
       && gfc_is_constant_expr (shape)
Index: testsuite/gfortran.dg/reshape_order_5.f90
===================================================================
--- testsuite/gfortran.dg/reshape_order_5.f90	(revision 0)
+++ testsuite/gfortran.dg/reshape_order_5.f90	(revision 0)
@@ -0,0 +1,16 @@
+! { dg-do "compile" }
+!
+! PR fortran/37203 - check RESHAPE arguments
+!
+
+  integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
+  integer, dimension(2) :: shape1 = (/ 2, 5/)
+  integer, dimension(2) :: pad1 = (/ 0, 0/)
+  integer, dimension(2) :: t(2,5)
+
+  t = reshape(source1, shape1, pad1, (/2, 1/))        ! ok
+  t = reshape(source1, shape1, pad1, (/2.1, 1.2/))    ! { dg-error "must be INTEGER" }
+  t = reshape(source1, shape1, pad1, (/2, 2/))        ! { dg-error "invalid permutation" }
+  t = reshape(source1, shape1, pad1, (/2, 3/))        ! { dg-error "out-of-range dimension" }
+  t = reshape(source1, shape1, pad1, (/2/))           ! { dg-error "wrong number of elements" }
+end
Index: testsuite/gfortran.dg/reshape_shape_1.f90
===================================================================
--- testsuite/gfortran.dg/reshape_shape_1.f90	(revision 0)
+++ testsuite/gfortran.dg/reshape_shape_1.f90	(revision 0)
@@ -0,0 +1,14 @@
+! { dg-do "compile" }
+!
+! PR fortran/37203 - check RESHAPE arguments
+!
+
+  integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
+  integer, dimension(2) :: pad1 = (/ 0, 0/)
+  integer, dimension(2) :: t(2,5)
+  integer :: i
+
+  t = reshape(source1, SHAPE(0), pad1, (/2, 1/))      ! { dg-error "is empty" }
+  t = reshape(source1, (/(i,i=1,32)/), pad1, (/2, 1/))    ! { dg-error "has more than" }
+  t = reshape(source1, (/ 2, -5/), pad1, (/2, 1/))    ! { dg-error "negative element" }
+end