2010-06-29 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/44582
	* trans-expr.c (arrayfunc_assign_needs_temporary): New function
	to determine if a function assignment can be made without a
	temporary.
	(gfc_trans_arrayfunc_assign): Move all the conditions that
	suppress the direct function call to the above new functon and
	call it.

2010-06-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/44582
	* gfortran.dg/aliasing_array_result_1.f90 : New test.



git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@161550 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 254 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 60d1e31876a..34c8f6407b5 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2010-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44582
+	* trans-expr.c (arrayfunc_assign_needs_temporary): New function
+	to determine if a function assignment can be made without a
+	temporary.
+	(gfc_trans_arrayfunc_assign): Move all the conditions that
+	suppress the direct function call to the above new functon and
+	call it.
+
 2010-06-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/40158
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 0164c163582..692b3e2f846 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4870,41 +4870,40 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 }
 
 
-/* Try to translate array(:) = func (...), where func is a transformational
-   array function, without using a temporary.  Returns NULL is this isn't the
-   case.  */
+/* There are quite a lot of restrictions on the optimisation in using an
+   array function assign without a temporary.  */
 
-static tree
-gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+static bool
+arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
 {
-  gfc_se se;
-  gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
   bool c = false;
-  gfc_component *comp = NULL;
+  gfc_symbol *sym = expr1->symtree->n.sym;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
-    return NULL;
+    return true;
 
-  /* Elemental functions don't need a temporary anyway.  */
+  /* Elemental functions are scalarized so that they don't need a
+     temporary in gfc_trans_assignment_1, so return a true.  Otherwise,
+     they would need special treatment in gfc_trans_arrayfunc_assign.  */
   if (expr2->value.function.esym != NULL
       && expr2->value.function.esym->attr.elemental)
-    return NULL;
+    return true;
 
-  /* Fail if rhs is not FULL or a contiguous section.  */
+  /* Need a temporary if rhs is not FULL or a contiguous section.  */
   if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
-    return NULL;
+    return true;
 
-  /* Fail if EXPR1 can't be expressed as a descriptor.  */
+  /* Need a temporary if EXPR1 can't be expressed as a descriptor.  */
   if (gfc_ref_needs_temporary_p (expr1->ref))
-    return NULL;
+    return true;
 
   /* Functions returning pointers need temporaries.  */
   if (expr2->symtree->n.sym->attr.pointer 
       || expr2->symtree->n.sym->attr.allocatable)
-    return NULL;
+    return true;
 
   /* Character array functions need temporaries unless the
      character lengths are the same.  */
@@ -4912,15 +4911,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
     {
       if (expr1->ts.u.cl->length == NULL
 	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
-	return NULL;
+	return true;
 
       if (expr2->ts.u.cl->length == NULL
 	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
-	return NULL;
+	return true;
 
       if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
 		     expr2->ts.u.cl->length->value.integer) != 0)
-	return NULL;
+	return true;
     }
 
   /* Check that no LHS component references appear during an array
@@ -4934,7 +4933,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
       if (ref->type == REF_ARRAY)
 	seen_array_ref= true;
       else if (ref->type == REF_COMPONENT && seen_array_ref)
-	return NULL;
+	return true;
     }
 
   /* Check for a dependency.  */
@@ -4942,6 +4941,62 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 				   expr2->value.function.esym,
 				   expr2->value.function.actual,
 				   NOT_ELEMENTAL))
+    return true;
+
+  /* If we have reached here with an intrinsic function, we do not
+     need a temporary.  */
+  if (expr2->value.function.isym)
+    return false;
+
+  /* If the LHS is a dummy, we need a temporary if it is not
+     INTENT(OUT).  */
+  if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
+    return true;
+
+  /* A PURE function can unconditionally be called without a temporary.  */
+  if (expr2->value.function.esym != NULL
+      && expr2->value.function.esym->attr.pure)
+    return false;
+
+  /* TODO a function that could correctly be declared PURE but is not
+     could do with returning false as well.  */
+
+  if (!sym->attr.use_assoc
+	&& !sym->attr.in_common
+	&& !sym->attr.pointer
+	&& !sym->attr.target
+	&& expr2->value.function.esym)
+    {
+      /* A temporary is not needed if the function is not contained and
+	 the variable is local or host associated and not a pointer or
+	 a target. */
+      if (!expr2->value.function.esym->attr.contained)
+	return false;
+
+      /* A temporary is not needed if the variable is local and not
+	 a pointer, a target or a result.  */
+      if (sym->ns->parent
+	    && expr2->value.function.esym->ns == sym->ns->parent)
+	return false;
+    }
+
+  /* Default to temporary use.  */
+  return true;
+}
+
+
+/* Try to translate array(:) = func (...), where func is a transformational
+   array function, without using a temporary.  Returns NULL if this isn't the
+   case.  */
+
+static tree
+gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+{
+  gfc_se se;
+  gfc_ss *ss;
+  gfc_component *comp = NULL;
+
+  if (arrayfunc_assign_needs_temporary (expr1, expr2))
     return NULL;
 
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3a555de59f2..6bdd576ca7a 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44582
+	* gfortran.dg/aliasing_array_result_1.f90 : New test.
+
 2010-06-29  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	* lib/lto.exp (lto_prune_warns): Also accept leading single quote.
diff --git a/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
new file mode 100644
index 00000000000..d8899d2ecf8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
@@ -0,0 +1,164 @@
+! { dg-do run }
+! Tests the fic for PR44582, where gfortran was found to
+! produce an incorrect result when the result of a function
+! was aliased by a host or use associated variable, to which
+! the function is assigned. In these cases a temporary is
+! required in the function assignments. The check has to be
+! rather restrictive.  Whilst the cases marked below might
+! not need temporaries, the TODOs are going to be tough.
+!
+! Reported by Yin Ma <yin@absoft.com> and
+! elaborated by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module foo
+  INTEGER, PARAMETER :: ONE = 1
+  INTEGER, PARAMETER :: TEN = 10
+  INTEGER, PARAMETER :: FIVE = TEN/2
+  INTEGER, PARAMETER :: TWO = 2
+  integer :: foo_a(ONE)
+  integer :: check(ONE) = TEN
+  LOGICAL :: abort_flag = .false. 
+contains
+  function foo_f()
+     integer :: foo_f(ONE)
+     foo_f = -FIVE
+     foo_f = foo_a - foo_f
+  end function foo_f
+  subroutine bar
+    foo_a = FIVE
+! This aliases 'foo_a' by host association.
+    foo_a = foo_f ()
+    if (any (foo_a .ne. check)) call myabort (0)
+  end subroutine bar
+  subroutine myabort(fl)
+    integer :: fl
+    print *, fl
+    abort_flag = .true.
+  end subroutine myabort
+end module foo
+
+function h_ext()
+  use foo
+  integer :: h_ext(ONE)
+  h_ext = -FIVE
+  h_ext = FIVE - h_ext
+end function h_ext
+
+function i_ext() result (h)
+  use foo
+  integer :: h(ONE)
+  h = -FIVE
+  h = FIVE - h
+end function i_ext
+
+subroutine tobias
+  use foo
+  integer :: a(ONE)
+  a = FIVE
+  call sub1(a)
+  if (any (a .ne. check)) call myabort (1)
+contains
+  subroutine sub1(x)
+    integer :: x(ONE)
+! 'x' is aliased by host association in 'f'.
+    x = f()
+  end subroutine sub1
+  function f()
+    integer :: f(ONE)
+    f = ONE
+    f = a + FIVE
+  end function f
+end subroutine tobias
+
+program test
+  use foo
+  implicit none
+  common /foo_bar/ c
+  integer :: a(ONE), b(ONE), c(ONE), d(ONE)
+  interface
+    function h_ext()
+      use foo
+      integer :: h_ext(ONE)
+    end function h_ext
+  end interface
+  interface
+    function i_ext() result (h)
+      use foo
+      integer :: h(ONE)
+    end function i_ext
+  end interface
+
+  a = FIVE
+! This aliases 'a' by host association
+  a = f()
+  if (any (a .ne. check)) call myabort (2)
+  a = FIVE
+  if (any (f() .ne. check)) call myabort (3)
+  call bar
+  foo_a = FIVE
+! This aliases 'foo_a' by host association.
+  foo_a = g ()
+  if (any (foo_a .ne. check)) call myabort (4)
+  a = FIVE
+  a = h()           ! TODO: Needs no temporary
+  if (any (a .ne. check)) call myabort (5)
+  a = FIVE
+  a = i()           ! TODO: Needs no temporary
+  if (any (a .ne. check)) call myabort (6)
+  a = FIVE
+  a = h_ext()       ! Needs no temporary - was OK
+  if (any (a .ne. check)) call myabort (15)
+  a = FIVE
+  a = i_ext()       ! Needs no temporary - was OK
+  if (any (a .ne. check)) call myabort (16)
+  c = FIVE
+! This aliases 'c' through the common block.
+  c = j()
+  if (any (c .ne. check)) call myabort (7)
+  call aaa
+  call tobias
+  if (abort_flag) call abort
+contains
+  function f()
+     integer :: f(ONE)
+     f = -FIVE
+     f = a - f
+  end function f
+  function g()
+     integer :: g(ONE)
+     g = -FIVE
+     g = foo_a - g
+  end function g
+  function h()
+     integer :: h(ONE)
+     h = -FIVE
+     h = FIVE - h
+  end function h
+  function i() result (h)
+     integer :: h(ONE)
+     h = -FIVE
+     h = FIVE - h
+  end function i
+  function j()
+     common /foo_bar/ cc
+     integer :: j(ONE), cc(ONE)
+     j = -FIVE
+     j = cc - j
+  end function j
+  subroutine aaa()
+    d = TEN - TWO
+! This aliases 'd' through 'get_d'.
+    d = bbb()
+    if (any (d .ne. check)) call myabort (8)
+  end subroutine aaa
+  function bbb()
+    integer :: bbb(ONE)
+    bbb = TWO
+    bbb = bbb + get_d()
+  end function bbb
+  function get_d()
+    integer :: get_d(ONE)
+    get_d = d
+  end function get_d
+end program test
+! { dg-final { cleanup-modules "foo" } }