===================================================================
@@ -0,0 +1,15 @@
+! { dg-do run }
+! PR PR 56872 - wrong front-end optimization with a
+! single array constructor and another value.
+program main
+ real :: s
+ integer :: m
+ integer :: k
+ real :: res
+
+ m = 2
+ s = 1000.
+
+ res = SUM([3.0,(s**(REAL(k-1)/REAL(m-1)),k=1,m),17.])
+ if (abs(res - 1021.)>1e-4) call abort
+end
===================================================================
@@ -0,0 +1,24 @@
+! { dg-do run }
+! { dg-options "-ffrontend-optimize -fdump-tree-original" }
+! Test that reduction optimization doesn't break with a function expression
+! in an array constructor.
+program main
+ implicit none
+ integer, parameter :: dp=selected_real_kind(15)
+ real(kind=dp), dimension(2,2) :: a
+ real(kind=dp) thirteen
+
+ data a /2._dp,3._dp,5._dp,7._dp/
+ thirteen = 13._dp
+ if (abs (product([[sum([eleven_ones()]), thirteen], a]) - 30030._dp) > 1e-8) call abort
+ contains
+ function eleven_ones()
+ real(kind=dp) :: eleven_ones(11)
+ integer :: i
+
+ eleven_ones = [ (1._dp, i=1,11) ]
+ end function eleven_ones
+end program main
+! { dg-final { scan-tree-dump-times "while" 4 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
===================================================================
@@ -48,5 +48,5 @@ program main
call baz(a,b,res);
if (abs(res - 8.1) > 1e-5) call abort
end program main
-! { dg-final { scan-tree-dump-times "while" 3 "original" } }
+! { dg-final { scan-tree-dump-times "while" 5 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
===================================================================
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-options "-ffrontend-optimize -fdump-tree-original" }
+! Test that nested array constructors are optimized.
+program main
+ implicit none
+ integer, parameter :: dp=selected_real_kind(15)
+ real(kind=dp), dimension(2,2) :: a
+ real(kind=dp) thirteen
+
+ data a /2._dp,3._dp,5._dp,7._dp/
+ thirteen = 13._dp
+ if (abs (product([[11._dp, thirteen], a]) - 30030._dp) > 1e-8) call abort
+end program main
+! { dg-final { scan-tree-dump-times "while" 2 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
===================================================================
@@ -1,3 +1,13 @@
+2013-04-19 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/56872
+ * gfortran.dg/array_constructor_45.f90: New test.
+ * gfortran.dg/array_constructor_46.f90: New test.
+ * gfortran.dg/array_constructor_47.f90: New test.
+ * gfortran.dg/array_constructor_40.f90: Adjust number of
+ while loops.
+
2013-04-18 Jakub Jelinek <jakub@redhat.com>
PR rtl-optimization/56999
===================================================================
@@ -1,3 +1,14 @@
+2013-04-19 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/56872
+ * frontend-passes.c (copy_walk_reduction_arg): Change argument type
+ to gfc_constructor. If it has an iterator, wrap the copy of its
+ expression in an array constructor with that iterator. Don't special
+ case function expressions.
+ (callback_reduction): Update caller. Don't return early if there is
+ an iterator.
+
2013-04-18 Tobias Burnus <burnus@net-b.de>
* expr.c (find_array_element): Don't copy expr.
===================================================================
@@ -192,37 +192,49 @@ optimize_expr (gfc_expr **e, int *walk_subtrees AT
old one can be freed. */
static gfc_expr *
-copy_walk_reduction_arg (gfc_expr *e, gfc_expr *fn)
+copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
{
- gfc_expr *fcn;
- gfc_isym_id id;
+ gfc_expr *fcn, *e = c->expr;
- if (e->rank == 0 || e->expr_type == EXPR_FUNCTION)
- fcn = gfc_copy_expr (e);
- else
+ fcn = gfc_copy_expr (e);
+ if (c->iterator)
{
- id = fn->value.function.isym->id;
+ gfc_constructor_base newbase;
+ gfc_expr *new_expr;
+ gfc_constructor *new_c;
+ newbase = NULL;
+ new_expr = gfc_get_expr ();
+ new_expr->expr_type = EXPR_ARRAY;
+ new_expr->ts = e->ts;
+ new_expr->where = e->where;
+ new_expr->rank = 1;
+ new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
+ new_c->iterator = c->iterator;
+ new_expr->value.constructor = newbase;
+ c->iterator = NULL;
+
+ fcn = new_expr;
+ }
+
+ if (fcn->rank != 0)
+ {
+ gfc_isym_id id = fn->value.function.isym->id;
+
if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
- fcn = gfc_build_intrinsic_call (current_ns,
- fn->value.function.isym->id,
+ fcn = gfc_build_intrinsic_call (current_ns, id,
fn->value.function.isym->name,
- fn->where, 3, gfc_copy_expr (e),
- NULL, NULL);
+ fn->where, 3, fcn, NULL, NULL);
else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
- fcn = gfc_build_intrinsic_call (current_ns,
- fn->value.function.isym->id,
+ fcn = gfc_build_intrinsic_call (current_ns, id,
fn->value.function.isym->name,
- fn->where, 2, gfc_copy_expr (e),
- NULL);
+ fn->where, 2, fcn, NULL);
else
gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
}
- (void) gfc_expr_walker (&fcn, callback_reduction, NULL);
-
return fcn;
}
@@ -305,10 +317,10 @@ callback_reduction (gfc_expr **e, int *walk_subtre
- only have a single element in the array which contains an
iterator. */
- if (c == NULL || (c->iterator != NULL && gfc_constructor_next (c) == NULL))
+ if (c == NULL)
return 0;
- res = copy_walk_reduction_arg (c->expr, fn);
+ res = copy_walk_reduction_arg (c, fn);
c = gfc_constructor_next (c);
while (c)
@@ -320,7 +332,7 @@ callback_reduction (gfc_expr **e, int *walk_subtre
new_expr->where = fn->where;
new_expr->value.op.op = op;
new_expr->value.op.op1 = res;
- new_expr->value.op.op2 = copy_walk_reduction_arg (c->expr, fn);
+ new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
res = new_expr;
c = gfc_constructor_next (c);
}