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

        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

+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+	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

gcc/fortran/array.c

@@ -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");
 }
 

gcc/fortran/check.c

@@ -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);
 	}
     }
 

gcc/fortran/expr.c

@@ -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;

gcc/fortran/intrinsic.c

@@ -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);
 

gcc/fortran/intrinsic.h

@@ -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 *);
 

gcc/fortran/simplify.c

@@ -5037,6 +5037,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)
 {
@@ -5431,6 +5524,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)
 {

gcc/testsuite/ChangeLog

+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.
+
 2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/25104

gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90

@@ -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

gcc/testsuite/gfortran.dg/spread_init_expr.f03

+! { 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

gcc/testsuite/gfortran.dg/unpack_init_expr.f03

+! { 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