diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 638a9b876105a4faf05b4f881841f6cbccca85f9..0a737bfd1e91994f688d3144ba8c8ff3798ea118 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+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
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 46c7425b9c1d3a90004ff268005e7468eb3a057f..4d3345f3fd4347206b796db2a6f6fc3ca0e87a28 100644
--- a/gcc/fortran/array.c
+++ b/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");
}
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c45d5db6b05ab9ac74be13367ff22db0a49dfa6c..103c9417790c30e51ee908492e5d10ddb17a19af 100644
--- a/gcc/fortran/check.c
+++ b/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);
}
}
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index a6a3a3b4ee3ab62500f2401beb0bb7f2f5342c1a..f76c35ea4f155e21da359767b97f5075133c57e8 100644
--- a/gcc/fortran/expr.c
+++ b/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;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 2dbb0cf14149f9be822378b610e935c8afb2855c..014ea11d3e83160c0410b9f0a1415b8c8d1b9025 100644
--- a/gcc/fortran/intrinsic.c
+++ b/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);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index b483b11fe984266871e6934bb3c6daabfcf40120..4ae15783fc179074f13cba2962e189ddf2fccc75 100644
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index dbd7f3d6309eddd3771fccd1ff317c924058d163..18ce099ae77fbc655d984de7ab8962315ea838a5 100644
--- a/gcc/fortran/simplify.c
+++ b/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)
{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 78cd329f95a5a327557614a6173a40cb7f142ad2..10445db8048e2cee2b7786acd3582771de06cfed 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
index c9284607fec5b6bcfeb6eb53af63c46a9b38a194..daff64f8065f2c585778851bbb06177500f57566 100644
--- a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/spread_init_expr.f03 b/gcc/testsuite/gfortran.dg/spread_init_expr.f03
new file mode 100644
index 0000000000000000000000000000000000000000..a8bdc5e19ee5c4451b09ca5d9620c41b5751e2b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spread_init_expr.f03
@@ -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
index 0000000000000000000000000000000000000000..78460d19a633c0610201c6d5063926cad0e52a9b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unpack_init_expr.f03
@@ -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