re PR fortran/32890 (Compile-time detect of LHS/RHS missmatch for PACK)

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

        PR fortran/32890
        * intrinsic.h (gfc_simplify_pack): New prototype.
        * intrinsic.c (add_functions): Added simplifier-callback to PACK.
        * simplify.c (is_constant_array_expr): Moved to beginning of file.
        (gfc_simplify_pack): New.
        * check.c (gfc_check_pack): Check that VECTOR has enough elements.
        Added safeguards for empty arrays.

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

        PR fortran/32890
        * gfortran.dg/pack_assign_1.f90: New.
        * gfortran.dg/pack_vector_1.f90: New.

From-SVN: r148237

8 files changed, 184 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5eacd0f..b50949f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2009-06-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32890
+	* intrinsic.h (gfc_simplify_pack): New prototype.
+	* intrinsic.c (add_functions): Added
+	simplifier-callback to PACK.
+	* simplify.c (is_constant_array_expr): Moved
+	to beginning of file.
+	(gfc_simplify_pack): New.
+	* check.c (gfc_check_pack): Check that VECTOR has enough elements.
+	Added safeguards for empty arrays.
+
 2009-06-05  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	* simplify.c (call_mpc_func): Use mpc_realref/mpc_imagref
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c4e33bb..b61909b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2149,13 +2149,63 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 
   if (vector != NULL)
     {
+      mpz_t array_size, vector_size;
+      bool have_array_size, have_vector_size;
+
       if (same_type_check (array, 0, vector, 2) == FAILURE)
 	return FAILURE;
 
       if (rank_check (vector, 2, 1) == FAILURE)
 	return FAILURE;
 
-      /* TODO: More constraints here.  */
+      /* VECTOR requires at least as many elements as MASK
+         has .TRUE. values.  */
+      have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
+      have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
+
+      if (have_vector_size
+	  && (mask->expr_type == EXPR_ARRAY
+	      || (mask->expr_type == EXPR_CONSTANT
+		  && have_array_size)))
+	{
+	  int mask_true_values = 0;
+
+	  if (mask->expr_type == EXPR_ARRAY)
+	    {
+	      gfc_constructor *mask_ctor = mask->value.constructor;
+	      while (mask_ctor)
+		{
+		  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+		    {
+		      mask_true_values = 0;
+		      break;
+		    }
+
+		  if (mask_ctor->expr->value.logical)
+		    mask_true_values++;
+
+		  mask_ctor = mask_ctor->next;
+		}
+	    }
+	  else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
+	    mask_true_values = mpz_get_si (array_size);
+
+	  if (mpz_get_si (vector_size) < mask_true_values)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+			 "provide at least as many elements as there "
+			 "are .TRUE. values in '%s' (%ld/%d)",
+			 gfc_current_intrinsic_arg[2],gfc_current_intrinsic, 
+			 &vector->where, gfc_current_intrinsic_arg[1],
+			 mpz_get_si (vector_size), mask_true_values);
+	      return FAILURE;
+	    }
+	}
+
+      if (have_array_size)
+	mpz_clear (array_size);
+      if (have_vector_size)
+	mpz_clear (vector_size);
     }
 
   return SUCCESS;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 0b16a72..7744b33 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2209,7 +2209,7 @@ add_functions (void)
   make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
 
   add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-	     gfc_check_pack, NULL, gfc_resolve_pack,
+	     gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
 	     ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
 	     v, BT_REAL, dr, OPTIONAL);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 7e8bc73..4a4aa5a 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -289,6 +289,7 @@ gfc_expr *gfc_simplify_null (gfc_expr *);
 gfc_expr *gfc_simplify_idnint (gfc_expr *);
 gfc_expr *gfc_simplify_not (gfc_expr *);
 gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_precision (gfc_expr *);
 gfc_expr *gfc_simplify_radix (gfc_expr *);
 gfc_expr *gfc_simplify_range (gfc_expr *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index fea1b91..09cf297 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -27,6 +27,10 @@ along with GCC; see the file COPYING3.  If not see
 #include "intrinsic.h"
 #include "target-memory.h"
 
+/* Savely advance an array constructor by 'n' elements.
+   Mainly used by simplifiers of transformational intrinsics.  */
+#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
+
 gfc_expr gfc_bad_expr;
 
 
@@ -229,6 +233,28 @@ call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
 }
 #endif
 
+
+/* Test that the expression is an constant array.  */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+  gfc_constructor *c;
+
+  if (e == NULL)
+    return true;
+
+  if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+    return false;
+
+  for (c = e->value.constructor; c; c = c->next)
+    if (c->expr->expr_type != EXPR_CONSTANT)
+      return false;
+
+  return true;
+}
+
+
 /********************** Simplification functions *****************************/
 
 gfc_expr *
@@ -3360,6 +3386,75 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y)
 
 
 gfc_expr *
+gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+  gfc_expr *result;
+  gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
+
+  if (!is_constant_array_expr(array)
+      || !is_constant_array_expr(vector)
+      || (!gfc_is_constant_expr (mask)
+          && !is_constant_array_expr(mask)))
+    return NULL;
+
+  result = gfc_start_constructor (array->ts.type, 
+				  array->ts.kind,
+				  &array->where);
+
+  array_ctor = array->value.constructor;
+  vector_ctor = vector ? vector->value.constructor : NULL;
+
+  if (mask->expr_type == EXPR_CONSTANT
+      && mask->value.logical)
+    {
+      /* Copy all elements of ARRAY to RESULT.  */
+      while (array_ctor)
+	{
+	  gfc_append_constructor (result, 
+				  gfc_copy_expr (array_ctor->expr));
+
+	  ADVANCE (array_ctor, 1);
+	  ADVANCE (vector_ctor, 1);
+	}
+    }
+  else if (mask->expr_type == EXPR_ARRAY)
+    {
+      /* Copy only those elements of ARRAY to RESULT whose 
+	 MASK equals .TRUE..  */
+      mask_ctor = mask->value.constructor;
+      while (mask_ctor)
+	{
+	  if (mask_ctor->expr->value.logical)
+	    {
+	      gfc_append_constructor (result, 
+				      gfc_copy_expr (array_ctor->expr)); 
+	      ADVANCE (vector_ctor, 1);
+	    }
+
+	  ADVANCE (array_ctor, 1);
+	  ADVANCE (mask_ctor, 1);
+	}
+    }
+
+  /* Append any left-over elements from VECTOR to RESULT.  */
+  while (vector_ctor)
+    {
+      gfc_append_constructor (result, 
+			      gfc_copy_expr (vector_ctor->expr));
+      ADVANCE (vector_ctor, 1);
+    }
+
+  result->shape = gfc_get_shape (1);
+  gfc_array_size (result, &result->shape[0]);
+
+  if (array->ts.type == BT_CHARACTER)
+    result->ts.cl = array->ts.cl;
+
+  return result;
+}
+
+
+gfc_expr *
 gfc_simplify_precision (gfc_expr *e)
 {
   gfc_expr *result;
@@ -3621,27 +3716,6 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
 }
 
 
-/* Test that the expression is an constant array.  */
-
-static bool
-is_constant_array_expr (gfc_expr *e)
-{
-  gfc_constructor *c;
-
-  if (e == NULL)
-    return true;
-
-  if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
-    return false;
-  
-  for (c = e->value.constructor; c; c = c->next)
-    if (c->expr->expr_type != EXPR_CONSTANT)
-      return false;
-
-  return true;
-}
-
-
 /* This one is a bear, but mainly has to do with shuffling elements.  */
 
 gfc_expr *
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6c4b7ca..ca9f04f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2009-06-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/32890
+	* gfortran.dg/pack_assign_1.f90: New.
+	* gfortran.dg/pack_vector_1.f90: New.
+
 2009-06-05  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/40340
diff --git a/gcc/testsuite/gfortran.dg/pack_assign_1.f90 b/gcc/testsuite/gfortran.dg/pack_assign_1.f90
new file mode 100644
index 0000000..4bab0da
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pack_assign_1.f90
@@ -0,0 +1,8 @@
+! { dg-do "compile" }
+! PR32890 - compile-time checks for assigments
+
+INTEGER :: it, neighbrs(42)  ! anything but 30
+
+neighbrs = PACK((/ (it, it=1,30) /), (/ (it, it=1,30) /) < 3, (/ (0,it=1,30) /) )  ! { dg-error "Different shape" }
+
+END
diff --git a/gcc/testsuite/gfortran.dg/pack_vector_1.f90 b/gcc/testsuite/gfortran.dg/pack_vector_1.f90
new file mode 100644
index 0000000..ba3624e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pack_vector_1.f90
@@ -0,0 +1,10 @@
+! { dg-do "compile" }
+!
+! Check that the VECTOR argument of the PACK intrinsic has at least
+! as many elements as the MASK has .TRUE. values.
+!
+
+  INTEGER :: res(2)
+  res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), SHAPE(1)) !{ dg-error "must provide at least as many" }
+  res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), (/ -1 /)) !{ dg-error "must provide at least as many" }
+END