This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, fortran-dev] PR29962 - simplifiers for SPREAD and UNPACK
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Mon, 6 Apr 2009 00:50:15 +0200
- Subject: [patch, fortran-dev] PR29962 - simplifiers for SPREAD and UNPACK
Two more simplifiers: SPREAD and UNPACK.
gcc/fortran/:
2009-04-05 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.
gcc/testsuite/:
2009-04-05 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.
Regression tested on i686-pc-linux-gnu.
Ok for dev-branch and (eventually) trunk?
Cheers
Daniel
P.S. CSHIFT, EOSHIFT, MINVAL/MAXVAL, MINLOC/MAXLOC to go.
Index: fortran/intrinsic.c
===================================================================
--- fortran/intrinsic.c (revision 145573)
+++ fortran/intrinsic.c (working copy)
@@ -2308,7 +2308,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);
@@ -2450,7 +2450,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: fortran/intrinsic.h
===================================================================
--- fortran/intrinsic.h (revision 145573)
+++ fortran/intrinsic.h (working copy)
@@ -317,6 +317,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 *);
@@ -327,6 +328,7 @@ gfc_expr *gfc_simplify_transfer (gfc_exp
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: fortran/array.c
===================================================================
--- fortran/array.c (revision 145559)
+++ fortran/array.c (working copy)
@@ -607,7 +607,8 @@ gfc_append_constructor (gfc_expr *base,
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: fortran/expr.c
===================================================================
--- fortran/expr.c (revision 145573)
+++ fortran/expr.c (working copy)
@@ -2122,7 +2122,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: fortran/check.c
===================================================================
--- fortran/check.c (revision 145573)
+++ fortran/check.c (working copy)
@@ -2816,6 +2816,18 @@ gfc_check_spread (gfc_expr *source, gfc_
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_e
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_
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_
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: fortran/simplify.c
===================================================================
--- fortran/simplify.c (revision 145573)
+++ fortran/simplify.c (working copy)
@@ -4839,6 +4839,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;
@@ -5227,6 +5320,54 @@ gfc_simplify_ubound (gfc_expr *array, gf
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: testsuite/gfortran.dg/spread_init_expr.f03
===================================================================
--- testsuite/gfortran.dg/spread_init_expr.f03 (revision 0)
+++ testsuite/gfortran.dg/spread_init_expr.f03 (revision 0)
@@ -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
Index: testsuite/gfortran.dg/unpack_init_expr.f03
===================================================================
--- testsuite/gfortran.dg/unpack_init_expr.f03 (revision 0)
+++ testsuite/gfortran.dg/unpack_init_expr.f03 (revision 0)
@@ -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
Index: testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
===================================================================
--- testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 (revision 145570)
+++ testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 (working copy)
@@ -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