re PR fortran/32890 (Compile-time detect of LHS/RHS missmatch for PACK)
authorDaniel Franke <franke.daniel@gmail.com>
Sat, 6 Jun 2009 18:51:29 +0000 (14:51 -0400)
committerTobias Burnus <burnus@gcc.gnu.org>
Sat, 6 Jun 2009 18:51:29 +0000 (20:51 +0200)
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

gcc/fortran/ChangeLog
gcc/fortran/check.c
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/simplify.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/pack_assign_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pack_vector_1.f90 [new file with mode: 0644]

index 5eacd0f..b50949f 100644 (file)
@@ -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
index c4e33bb..b61909b 100644 (file)
@@ -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;
index 0b16a72..7744b33 100644 (file)
@@ -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);
 
index 7e8bc73..4a4aa5a 100644 (file)
@@ -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 *);
index fea1b91..09cf297 100644 (file)
@@ -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 *
index 6c4b7ca..ca9f04f 100644 (file)
@@ -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 (file)
index 0000000..4bab0da
--- /dev/null
@@ -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 (file)
index 0000000..ba3624e
--- /dev/null
@@ -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