}
-/* 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. */
{
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
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. */
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
--- /dev/null
+! { 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" } }