This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: {patch, fortran] PR37203: additional checks for RESHAPE


On Monday 05 January 2009 23:08:07 Mikael Morin wrote:
> > I think that the checks during simplification could be removed, but I
> > left them untouched for now.
>
> Hum, we will forget about it, so we should remove them now.

In attached patch, I turned all the checks during simplification into 
equivalent asserts. If ever any of the asserts triggers, something is amiss in 
gfc_check_reshape(). If neither catches an error and still the result of 
reshape is wrong, then it's an untested case anyway.

Ok for 4.5, trunk or the to-be-created sandbox?

Regards

	Daniel

Index: check.c
===================================================================
--- check.c	(revision 143089)
+++ 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,121 @@ 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, 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)
Index: simplify.c
===================================================================
--- simplify.c	(revision 143053)
+++ simplify.c	(working copy)
@@ -3446,16 +3446,10 @@ gfc_simplify_reshape (gfc_expr *source, 
   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.  */
@@ -3470,40 +3464,16 @@ gfc_simplify_reshape (gfc_expr *source, 
       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)
@@ -3519,42 +3489,15 @@ gfc_simplify_reshape (gfc_expr *source, 
       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);
 
-	  x[order[i]] = 1;
+	  gcc_assert (order[i] >= 1 && order[i] <= rank);
+	  gcc_assert (x[order[i-1]] == 0);
+
+	  x[order[i-1]] = 1;
 	}
     }
 
@@ -3601,18 +3544,13 @@ gfc_simplify_reshape (gfc_expr *source, 
 	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 ();
@@ -3622,9 +3560,6 @@ gfc_simplify_reshape (gfc_expr *source, 
 	  tail = tail->next;
 	}
 
-      if (e == NULL)
-	goto bad_reshape;
-
       tail->where = e->where;
       tail->expr = e;
 
@@ -3656,11 +3591,6 @@ inc:
   e->rank = rank;
 
   return e;
-
-bad_reshape:
-  gfc_free_constructor (head);
-  mpz_clear (index);
-  return &gfc_bad_expr;
 }
 
 

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]