[patch, fortran] Really fix PR 56782

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

the attached patch completely fixes the regression,
PR 56782.

Regression-tested.  OK for trunk and 4.8?

	Thomas

2013-04-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/56782
        * frontend-passes.c (copy_walk_reduction_arg):  Do not
        call the expression walker with callback_reduction.
        (insert_iterator_function):  New function.
        (callback_reduction):  If an iterator is present, call
        insert_iterator_function and reset the iterator on the
        original array iterator.

2013-04-08  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/56782
        * gfortran.dg/array_constructor_45.f90:  New test.
        * gfortran.dg/array_constructor_46.f90:  New test.
        * gfortran.dg/array_constructor_40.f90:  Adjust number of
        while loops.

Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c	(Revision 197610)
+++ fortran/frontend-passes.c	(Arbeitskopie)
@@ -221,8 +221,47 @@ copy_walk_reduction_arg (gfc_expr *e, gfc_expr *fn
       fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
     }
 
-  (void) gfc_expr_walker (&fcn, callback_reduction, NULL);
+  return fcn;
+}
 
+/* Auxiliary function to create function with an an array expression with
+   iterator argument.  */
+
+static gfc_expr *
+insert_iterator_function (gfc_expr *e, gfc_expr *fn, gfc_iterator *iterator)
+{
+  gfc_expr *fcn, *new_expr;
+  gfc_isym_id id;
+  gfc_constructor_base newbase;
+  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, gfc_copy_expr(e), &(e->where));
+  new_c->iterator = iterator;
+  new_expr->value.constructor = newbase;
+
+  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,
+				    fn->value.function.isym->name,
+				    fn->where, 3, new_expr,
+				    NULL, NULL);
+  else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
+    fcn = gfc_build_intrinsic_call (current_ns,
+				    fn->value.function.isym->id,
+				    fn->value.function.isym->name,
+				    fn->where, 2, new_expr,
+				    NULL);
+  else
+    gfc_internal_error ("Illegal id in insert_iterator_function");
+
   return fcn;
 }
 
@@ -300,15 +339,19 @@ callback_reduction (gfc_expr **e, int *walk_subtre
 
   c = gfc_constructor_first (arg->value.constructor);
 
-  /* Don't do any simplififcation if we have
-     - no element in the constructor or
-     - only have a single element in the array which contains an
-     iterator.  */
+  /* Don't do any simplififcation if we have no element
+     in the constructor.  */
 
-  if (c == NULL || (c->iterator != NULL && gfc_constructor_next (c) == NULL))
+  if (c == NULL)
     return 0;
 
-  res = copy_walk_reduction_arg (c->expr, fn);
+  if (c->iterator)
+    {
+      res = insert_iterator_function (c->expr, fn, c->iterator);
+      c->iterator = NULL;
+    }
+  else
+    res = copy_walk_reduction_arg (c->expr, fn);
 
   c = gfc_constructor_next (c);
   while (c)
@@ -320,7 +363,15 @@ 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);
+
+      if (c->iterator)
+	{
+	  new_expr->value.op.op2 = insert_iterator_function (c->expr, fn, c->iterator);
+	  c->iterator = NULL;
+	}
+      else
+	new_expr->value.op.op2 = copy_walk_reduction_arg (c->expr, fn);
+
       res = new_expr;
       c = gfc_constructor_next (c);
     }
Index: testsuite/gfortran.dg/array_constructor_40.f90
===================================================================
--- testsuite/gfortran.dg/array_constructor_40.f90	(Revision 197233)
+++ testsuite/gfortran.dg/array_constructor_40.f90	(Arbeitskopie)
@@ -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" } }

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

! { 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" } }