OSDN Git Service

2009-06-07 Daniel Franke <franke.daniel@gmail.com>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 7 Jun 2009 17:33:34 +0000 (17:33 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 7 Jun 2009 17:33:34 +0000 (17:33 +0000)
        PR fortran/25104
        PR fortran/29962
        * array.c (gfc_append_constructor): Added NULL-check.
        * check.c (gfc_check_spread): Check DIM.
        (gfc_check_unpack): Check that the ARRAY arguments provides
        enough values for MASK.
        * intrinsic.h (gfc_simplify_spread): New prototype.
        (gfc_simplify_unpack): Likewise.
        * intrinsic.c (add_functions): Added new simplifier callbacks.
        * simplify.c (gfc_simplify_spread): New.
        (gfc_simplify_unpack): New.
        * expr.c (check_transformational): Allow additional
        * transformational
        intrinsics in initialization expression.

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

        PR fortran/25104
        PR fortran/29962
        * gfortran.dg/spread_init_expr.f03: New.
        * gfortran.dg/unpack_init_expr.f03: New.
        * gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted
        error message.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148250 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/check.c
gcc/fortran/expr.c
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/simplify.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
gcc/testsuite/gfortran.dg/spread_init_expr.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/unpack_init_expr.f03 [new file with mode: 0644]

index 638a9b8..0a737bf 100644 (file)
@@ -2,6 +2,22 @@
 
        PR fortran/25104
        PR fortran/29962
+       * array.c (gfc_append_constructor): Added NULL-check.
+       * check.c (gfc_check_spread): Check DIM.
+       (gfc_check_unpack): Check that the ARRAY arguments provides enough
+       values for MASK.
+       * intrinsic.h (gfc_simplify_spread): New prototype.
+       (gfc_simplify_unpack): Likewise.
+       * intrinsic.c (add_functions): Added new simplifier callbacks.
+       * simplify.c (gfc_simplify_spread): New.
+       (gfc_simplify_unpack): New.
+       * expr.c (check_transformational): Allow additional transformational
+       intrinsics in initialization expression.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/25104
+       PR fortran/29962
        * check.c (gfc_check_all_any): Check rank of DIM.
        (gfc_check_count): Likewise.
        * intrinsic.h (gfc_simplify_all): New prototype.
index 46c7425..4d3345f 100644 (file)
@@ -607,7 +607,8 @@ gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
 
   c->expr = new_expr;
 
-  if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)
+  if (new_expr
+      && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
     gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
 }
 
index c45d5db..103c941 100644 (file)
@@ -2816,6 +2816,18 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
+  /* dim_rank_check() does not apply here.  */
+  if (dim 
+      && dim->expr_type == EXPR_CONSTANT
+      && (mpz_cmp_ui (dim->value.integer, 1) < 0
+         || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+                "dimension index", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &dim->where);
+      return FAILURE;
+    }
+
   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
 
@@ -3120,6 +3132,8 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_try
 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 {
+  mpz_t vector_size;
+
   if (rank_check (vector, 0, 1) == FAILURE)
     return FAILURE;
 
@@ -3132,10 +3146,45 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
   if (same_type_check (vector, 0, field, 2) == FAILURE)
     return FAILURE;
 
+  if (mask->expr_type == EXPR_ARRAY
+      && gfc_array_size (vector, &vector_size) == SUCCESS)
+    {
+      int mask_true_count = 0;
+      gfc_constructor *mask_ctor = mask->value.constructor;
+      while (mask_ctor)
+       {
+         if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+           {
+             mask_true_count = 0;
+             break;
+           }
+
+         if (mask_ctor->expr->value.logical)
+           mask_true_count++;
+
+         mask_ctor = mask_ctor->next;
+       }
+
+      if (mpz_get_si (vector_size) < mask_true_count)
+       {
+         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[0], gfc_current_intrinsic,
+                    &vector->where, gfc_current_intrinsic_arg[1],
+                    mpz_get_si (vector_size), mask_true_count);
+         return FAILURE;
+       }
+
+      mpz_clear (vector_size);
+    }
+
   if (mask->rank != field->rank && field->rank != 0)
     {
-      gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
-                "MASK or be a scalar", &field->where);
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
+                "the same rank as '%s' or be a scalar", 
+                gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
+                &field->where, gfc_current_intrinsic_arg[1]);
       return FAILURE;
     }
 
@@ -3145,9 +3194,11 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
       for (i = 0; i < field->rank; i++)
        if (! identical_dimen_shape (mask, i, field, i))
        {
-         gfc_error ("Different shape in dimension %d for MASK and FIELD "
-                    "arguments of UNPACK at %L", mask->rank, &field->where);
-         return FAILURE;
+         gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+                    "must have identical shape.", 
+                    gfc_current_intrinsic_arg[2],
+                    gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+                    &field->where);
        }
     }
 
index a6a3a3b..f76c35e 100644 (file)
@@ -2130,7 +2130,8 @@ check_transformational (gfc_expr *e)
   static const char * const trans_func_f2003[] =  {
     "all", "any", "count", "dot_product", "matmul", "null", "pack",
     "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
-    "selected_real_kind", "sum", "transfer", "transpose", "trim", NULL
+    "selected_real_kind", "spread", "sum", "transfer", "transpose",
+    "trim", "unpack", NULL
   };
 
   int i;
index 2dbb0cf..014ea11 100644 (file)
@@ -2433,7 +2433,7 @@ add_functions (void)
   make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
 
   add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-            gfc_check_spread, NULL, gfc_resolve_spread,
+            gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
             src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
             ncopies, BT_INTEGER, di, REQUIRED);
 
@@ -2575,7 +2575,7 @@ add_functions (void)
   make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
 
   add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-            gfc_check_unpack, NULL, gfc_resolve_unpack,
+            gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
             v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
             f, BT_REAL, dr, REQUIRED);
 
index b483b11..4ae1578 100644 (file)
@@ -318,6 +318,7 @@ gfc_expr *gfc_simplify_sinh (gfc_expr *);
 gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_sngl (gfc_expr *);
 gfc_expr *gfc_simplify_spacing (gfc_expr *);
+gfc_expr *gfc_simplify_spread (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_sqrt (gfc_expr *);
 gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_tan (gfc_expr *);
@@ -328,6 +329,7 @@ gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_transpose (gfc_expr *);
 gfc_expr *gfc_simplify_trim (gfc_expr *);
 gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
 
index dbd7f3d..18ce099 100644 (file)
@@ -5038,6 +5038,99 @@ gfc_simplify_spacing (gfc_expr *x)
 
 
 gfc_expr *
+gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
+{
+  gfc_expr *result = 0L;
+  int i, j, dim, ncopies;
+
+  if ((!gfc_is_constant_expr (source)
+       && !is_constant_array_expr (source))
+      || !gfc_is_constant_expr (dim_expr)
+      || !gfc_is_constant_expr (ncopies_expr))
+    return NULL;
+
+  gcc_assert (dim_expr->ts.type == BT_INTEGER);
+  gfc_extract_int (dim_expr, &dim);
+  dim -= 1;   /* zero-base DIM */
+
+  gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
+  gfc_extract_int (ncopies_expr, &ncopies);
+  ncopies = MAX (ncopies, 0);
+
+  if (source->expr_type == EXPR_CONSTANT)
+    {
+      gcc_assert (dim == 0);
+
+      result = gfc_start_constructor (source->ts.type,
+                                     source->ts.kind,
+                                     &source->where);
+      result->rank = 1;
+      result->shape = gfc_get_shape (result->rank);
+      mpz_init_set_si (result->shape[0], ncopies);
+
+      for (i = 0; i < ncopies; ++i)
+        gfc_append_constructor (result, gfc_copy_expr (source));
+    }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+      gfc_constructor *ctor, *source_ctor, *result_ctor;
+
+      gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
+      gcc_assert (dim >= 0 && dim <= source->rank);
+
+      result = gfc_start_constructor (source->ts.type,
+                                     source->ts.kind,
+                                     &source->where);
+      result->rank = source->rank + 1;
+      result->shape = gfc_get_shape (result->rank);
+
+      result_size = 1;
+      for (i = 0, j = 0; i < result->rank; ++i)
+       {
+         if (i != dim)
+           mpz_init_set (result->shape[i], source->shape[j++]);
+         else
+           mpz_init_set_si (result->shape[i], ncopies);
+
+         extent[i] = mpz_get_si (result->shape[i]);
+         rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
+         result_size *= extent[i];
+       }
+
+      for (i = 0; i < result_size; ++i)
+       gfc_append_constructor (result, NULL);
+
+      source_ctor = source->value.constructor;
+      result_ctor = result->value.constructor;
+      while (source_ctor)
+       {
+         ctor = result_ctor;
+
+         for (i = 0; i < ncopies; ++i)
+         {
+           ctor->expr = gfc_copy_expr (source_ctor->expr);
+           ADVANCE (ctor, rstride[dim]);
+         }
+
+         ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
+         ADVANCE (source_ctor, 1);
+       }
+    }
+  else
+    /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
+       Replace NULL with gcc_unreachable() after implementing
+       gfc_simplify_cshift(). */
+    return NULL;
+
+  if (source->ts.type == BT_CHARACTER)
+    result->ts.cl = source->ts.cl;
+
+  return result;
+}
+
+
+gfc_expr *
 gfc_simplify_sqrt (gfc_expr *e)
 {
   gfc_expr *result;
@@ -5432,6 +5525,54 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
 
 gfc_expr *
+gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+  gfc_expr *result, *e;
+  gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
+
+  if (!is_constant_array_expr (vector)
+      || !is_constant_array_expr (mask)
+      || (!gfc_is_constant_expr (field)
+         && !is_constant_array_expr(field)))
+    return NULL;
+
+  result = gfc_start_constructor (vector->ts.type,
+                                 vector->ts.kind,
+                                 &vector->where);
+  result->rank = mask->rank;
+  result->shape = gfc_copy_shape (mask->shape, mask->rank);
+
+  if (vector->ts.type == BT_CHARACTER)
+    result->ts.cl = vector->ts.cl;
+
+  vector_ctor = vector->value.constructor;
+  mask_ctor = mask->value.constructor;
+  field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
+
+  while (mask_ctor)
+    {
+      if (mask_ctor->expr->value.logical)
+       {
+         gcc_assert (vector_ctor);
+         e = gfc_copy_expr (vector_ctor->expr);
+         ADVANCE (vector_ctor, 1);
+       }
+      else if (field->expr_type == EXPR_ARRAY)
+       e = gfc_copy_expr (field_ctor->expr);
+      else
+       e = gfc_copy_expr (field);
+
+      gfc_append_constructor (result, e);
+
+      ADVANCE (mask_ctor, 1);
+      ADVANCE (field_ctor, 1);
+    }
+
+  return result;
+}
+
+
+gfc_expr *
 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
 {
   gfc_expr *result;
index 78cd329..10445db 100644 (file)
@@ -2,6 +2,15 @@
 
        PR fortran/25104
        PR fortran/29962
+       * gfortran.dg/spread_init_expr.f03: New.
+       * gfortran.dg/unpack_init_expr.f03: New.
+       * gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted
+       error message.
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/25104
+       PR fortran/29962
        * gfortran.dg/count_init_expr.f03
        * gfortran.dg/product_init_expr.f03
        * gfortran.dg/sum_init_expr.f03
index c928460..daff64f 100644 (file)
@@ -39,6 +39,6 @@ program main
   if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
   if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
 
-  if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
-  if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
+  if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "must have identical shape" }
+  if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "must have identical shape" }
 end program main
diff --git a/gcc/testsuite/gfortran.dg/spread_init_expr.f03 b/gcc/testsuite/gfortran.dg/spread_init_expr.f03
new file mode 100644 (file)
index 0000000..a8bdc5e
--- /dev/null
@@ -0,0 +1,17 @@
+! { dg-do "run" }
+
+  INTEGER, PARAMETER :: n = 5
+  INTEGER, PARAMETER :: a1(n) = SPREAD(1, 1, n)
+  INTEGER, PARAMETER :: a2(n, 3) = SPREAD([1,2,3], DIM=1, NCOPIES=n)
+  INTEGER, PARAMETER :: a3(3, n) = SPREAD([1,2,3], DIM=2, NCOPIES=n)
+
+  IF (ANY(a1 /= [ 1, 1, 1, 1, 1 ])) CALL abort()
+
+  IF (ANY(a2(:, 1) /= 1)) CALL abort()
+  IF (ANY(a2(:, 2) /= 2)) CALL abort()
+  IF (ANY(a2(:, 3) /= 3)) CALL abort()
+
+  IF (ANY(a3(1, :) /= 1)) CALL abort()
+  IF (ANY(a3(2, :) /= 2)) CALL abort()
+  IF (ANY(a3(3, :) /= 3)) CALL abort()
+END
diff --git a/gcc/testsuite/gfortran.dg/unpack_init_expr.f03 b/gcc/testsuite/gfortran.dg/unpack_init_expr.f03
new file mode 100644 (file)
index 0000000..78460d1
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do "run" }
+!
+! Example from F2003, sec 13.7.125
+!
+  INTEGER, PARAMETER :: m(3,3) = RESHAPE ([1,0,0,0,1,0,0,0,1], [3,3])
+  INTEGER, PARAMETER :: v(3)   = [1,2,3]
+  LOGICAL, PARAMETER :: F = .FALSE., T = .TRUE.
+  LOGICAL, PARAMETER :: q(3,3) = RESHAPE ([F,T,F,T,F,F,F,F,T], [3,3])
+
+  INTEGER, PARAMETER :: r1(3,3) = UNPACK (V, MASK=Q, FIELD=M)
+  INTEGER, PARAMETER :: r2(3,3) = UNPACK (V, MASK=Q, FIELD=0)
+
+  IF (ANY (r1 /= RESHAPE ([1,1,0,2,1,0,0,0,3], [3,3]))) CALL ABORT()
+  IF (ANY (r2 /= RESHAPE ([0,1,0,2,0,0,0,0,3], [3,3]))) CALL ABORT()
+END