re PR fortran/37203 (Check ORDER= of RESHAPE)

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

        PR fortran/37203
        * check.c (gfc_check_reshape): Additional checks for the
        SHAPE and ORDER arguments.
        * simplify.c (gfc_simplify_reshape): Converted argument checks
        to asserts.

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

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

From-SVN: r148190

gcc/fortran/ChangeLog

+2009-06-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37203
+	* check.c (gfc_check_reshape): Additional checks for the
+	SHAPE and ORDER arguments.
+	* simplify.c (gfc_simplify_reshape): Converted argument checks
+	to asserts.
+
 2009-06-03  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.texi: Add mixed-language programming, mention

gcc/fortran/check.c

@@ -2324,7 +2324,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 {
   mpz_t size;
   mpz_t nelems;
-  int m;
+  int shape_size;
 
   if (array_check (source, 0) == FAILURE)
     return FAILURE;
@@ -2342,26 +2342,121 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
       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, extent;
+      for (i = 0; i < shape_size; ++i)
+	{
+	  e = gfc_get_array_element (shape, i);
+	  if (e->expr_type != EXPR_CONSTANT)
+	    {
+	      gfc_free_expr (e);
+	      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;
+	    }
+
+	  gfc_free_expr (e);
+	}
+    }
 
   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)
+		{
+		  gfc_free_expr (e);
+		  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;
+	      gfc_free_expr (e);
+	    }
+	}
+    }
 
   if (pad == NULL && shape->expr_type == EXPR_ARRAY
       && gfc_is_constant_expr (shape)

gcc/fortran/simplify.c

@@ -3657,16 +3657,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
   gfc_expr *e;
 
   /* Check that argument expression types are OK.  */
-  if (!is_constant_array_expr (source))
-    return NULL;
-
-  if (!is_constant_array_expr (shape_exp))
-    return NULL;
-
-  if (!is_constant_array_expr (pad))
-    return NULL;
-
-  if (!is_constant_array_expr (order_exp))
+  if (!is_constant_array_expr (source)
+      || !is_constant_array_expr (shape_exp)
+      || !is_constant_array_expr (pad)
+      || !is_constant_array_expr (order_exp))
     return NULL;
 
   /* Proceed with simplification, unpacking the array.  */
@@ -3681,40 +3675,16 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
       if (e == NULL)
 	break;
 
-      if (gfc_extract_int (e, &shape[rank]) != NULL)
-	{
-	  gfc_error ("Integer too large in shape specification at %L",
-		     &e->where);
-	  gfc_free_expr (e);
-	  goto bad_reshape;
-	}
+      gfc_extract_int (e, &shape[rank]);
 
-      if (rank >= GFC_MAX_DIMENSIONS)
-	{
-	  gfc_error ("Too many dimensions in shape specification for RESHAPE "
-		     "at %L", &e->where);
-	  gfc_free_expr (e);
-	  goto bad_reshape;
-	}
-
-      if (shape[rank] < 0)
-	{
-	  gfc_error ("Shape specification at %L cannot be negative",
-		     &e->where);
-	  gfc_free_expr (e);
-	  goto bad_reshape;
-	}
+      gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
+      gcc_assert (shape[rank] >= 0);
 
       gfc_free_expr (e);
       rank++;
     }
 
-  if (rank == 0)
-    {
-      gfc_error ("Shape specification at %L cannot be the null array",
-		 &shape_exp->where);
-      goto bad_reshape;
-    }
+  gcc_assert (rank > 0);
 
   /* Now unpack the order array if present.  */
   if (order_exp == NULL)
@@ -3730,41 +3700,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
       for (i = 0; i < rank; i++)
 	{
 	  e = gfc_get_array_element (order_exp, i);
-	  if (e == NULL)
-	    {
-	      gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
-			 "size as SHAPE parameter", &order_exp->where);
-	      goto bad_reshape;
-	    }
-
-	  if (gfc_extract_int (e, &order[i]) != NULL)
-	    {
-	      gfc_error ("Error in ORDER parameter of RESHAPE at %L",
-			 &e->where);
-	      gfc_free_expr (e);
-	      goto bad_reshape;
-	    }
-
-	  if (order[i] < 1 || order[i] > rank)
-	    {
-	      gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
-			 &e->where);
-	      gfc_free_expr (e);
-	      goto bad_reshape;
-	    }
-
-	  order[i]--;
-
-	  if (x[order[i]])
-	    {
-	      gfc_error ("Invalid permutation in ORDER parameter at %L",
-			 &e->where);
-	      gfc_free_expr (e);
-	      goto bad_reshape;
-	    }
+	  gcc_assert (e);
 
+	  gfc_extract_int (e, &order[i]);
 	  gfc_free_expr (e);
 
+	  gcc_assert (order[i] >= 1 && order[i] <= rank);
+	  order[i]--;
+	  gcc_assert (x[order[i]] == 0);
 	  x[order[i]] = 1;
 	}
     }
@@ -3812,18 +3755,13 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
 	e = gfc_get_array_element (source, j);
       else
 	{
-	  j = j - nsource;
-
-	  if (npad == 0)
-	    {
-	      gfc_error ("PAD parameter required for short SOURCE parameter "
-			 "at %L", &source->where);
-	      goto bad_reshape;
-	    }
+	  gcc_assert (npad > 0);
 
+	  j = j - nsource;
 	  j = j % npad;
 	  e = gfc_get_array_element (pad, j);
 	}
+      gcc_assert (e);
 
       if (head == NULL)
 	head = tail = gfc_get_constructor ();
@@ -3833,9 +3771,6 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
 	  tail = tail->next;
 	}
 
-      if (e == NULL)
-	goto bad_reshape;
-
       tail->where = e->where;
       tail->expr = e;
 
@@ -3867,11 +3802,6 @@ inc:
   e->rank = rank;
 
   return e;
-
-bad_reshape:
-  gfc_free_constructor (head);
-  mpz_clear (index);
-  return &gfc_bad_expr;
 }
 
 

gcc/testsuite/ChangeLog

+2009-06-04  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/37203
+	* gfortran.dg/reshape_order_5.f90: New.
+	* gfortran.dg/reshape_shape_1.f90: New.
+
 2009-06-04  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/template/error38.C: Add pointer-to-typedef case.

gcc/testsuite/gfortran.dg/reshape_order_5.f90

+! { 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

gcc/testsuite/gfortran.dg/reshape_shape_1.f90

+! { 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