[fortran-dev, patch] PR32890 - add simplifier and argument check for PACK

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

Attached patch adds a simplifier for the PACK intrinsic and implements 
additional compile-time argument checks.


2009-03-23  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.

2009-03-23  Daniel Franke  <franke.daniel@gmail.com>

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


Bootstrapped and regression tested on i686-pc-linux-gnu.
Ok for dev and 4.5?

Cheers

	Daniel
  

Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 144994)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -288,6 +288,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 *);
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 144994)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -2084,7 +2084,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);
 
@@ -3600,9 +3600,12 @@ gfc_intrinsic_func_interface (gfc_expr *
   flag = 0;
 
   for (actual = expr->value.function.actual; actual; actual = actual->next)
-    if (actual->expr != NULL)
+    if (actual->expr != NULL) {
+      gfc_simplify_expr (actual->expr, 0);
+
       flag |= (actual->expr->ts.type != BT_INTEGER
 	       && actual->expr->ts.type != BT_CHARACTER);
+    }
 
   name = expr->symtree->n.sym->name;
 
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(revision 144996)
+++ gcc/fortran/simplify.c	(working copy)
@@ -27,6 +27,8 @@ along with GCC; see the file COPYING3.  
 #include "intrinsic.h"
 #include "target-memory.h"
 
+#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
+
 gfc_expr gfc_bad_expr;
 
 
@@ -210,6 +212,26 @@ convert_mpz_to_signed (mpz_t x, int bits
     }
 }
 
+/* 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 *****************************/
 
@@ -3170,6 +3192,75 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *
 
 
 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;
@@ -3431,27 +3522,6 @@ gfc_simplify_repeat (gfc_expr *e, gfc_ex
 }
 
 
-/* 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 *
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 144996)
+++ gcc/fortran/check.c	(working copy)
@@ -2149,13 +2149,61 @@ gfc_check_pack (gfc_expr *array, gfc_exp
 
   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_array_size
+	  && (mask->expr_type == EXPR_ARRAY
+	      || (mask->expr_type == EXPR_CONSTANT
+		  && have_vector_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;
+	    }
+	}
+
+      mpz_clear (array_size);
+      mpz_clear (vector_size);
     }
 
   return SUCCESS;
Index: gcc/testsuite/gfortran.dg/pack_assign_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pack_assign_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/pack_assign_1.f90	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/pack_vector_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pack_vector_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/pack_vector_1.f90	(revision 0)
@@ -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