This patch detects a scalar function result that has allocatable components
and is being used inside a scalarization loop. Before this patch, the
components would be deallocated and nullified within the scalarization loop
and so would cause a segfault on the second cycle of the loop.
The stored result has to be found by identifying the expression in the loop
ss chain. This is then used for the deallocation of the allocatable
components in the loop post block, which keeps gimple happy and prevents
the segfault.
Regtests on FC31/x86_64 - OK for master?
Paul
This patch fixes PR96495 - frees result components outside loop.
2020-29-08 Paul Thomas
gcc/fortran
PR fortran/96495
* trans-expr.c (gfc_conv_procedure_call): Take the deallocation
of allocatable result components of a scalar result outside the
scalarization loop. Find and use the stored result.
gcc/testsuite/
PR fortran/96495
* gfortran.dg/alloc_comp_result_2.f90 : New test.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 36ff9b5cbc6..a690839f591 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6421,6 +6421,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (!finalized && !e->must_finalize)
{
+ bool scalar_res_outside_loop;
+ scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
+ && parm_rank == 0
+ && parmse.loop;
+
+ if (scalar_res_outside_loop)
+ {
+ /* Go through the ss chain to find the argument and use
+ the stored value. */
+ gfc_ss *tmp_ss = parmse.loop->ss;
+ for (; tmp_ss; tmp_ss = tmp_ss->next)
+ if (tmp_ss->info
+ && tmp_ss->info->expr == e
+ && tmp_ss->info->data.scalar.value != NULL_TREE)
+ {
+ tmp = tmp_ss->info->data.scalar.value;
+ break;
+ }
+ }
+
if ((e->ts.type == BT_CLASS
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|| e->ts.type == BT_DERIVED)
@@ -6429,7 +6449,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (e->ts.type == BT_CLASS)
tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
tmp, parm_rank);
- gfc_prepend_expr_to_block (, tmp);
+
+ if (scalar_res_outside_loop)
+ gfc_add_expr_to_block (>post, tmp);
+ else
+ gfc_prepend_expr_to_block (, tmp);
}
}
! { dg-do run }
!
! Test the fix for PR96495 - segfaults at runtime at locations below.
!
! Contributed by Paul Luckner
!
module foo_m
implicit none
type foo
integer, allocatable :: j(:)
end type
interface operator(.unary.)
module procedure neg_foo
end interface
interface operator(.binary.)
module procedure foo_sub_foo
end interface
interface operator(.binaryElemental.)
module procedure foo_add_foo
end interface
contains
elemental function foo_add_foo(f, g) result(h)
!! an example for an elemental binary operator
type(foo), intent(in) :: f, g
type(foo) :: h
allocate (h%j(size(f%j)), source = f%j+g%j)
end function
elemental function foo_sub_foo(f, g) result(h)
!! an example for an elemental binary operator
type(foo), intent(in) :: f, g
type(foo) :: h
allocate (h%j(size(f%j)), source = f%j-3*g%j)
end function
pure function neg_foo(f) result(g)
!! an example for a unary operator
type(foo), intent(in) :: f
type(foo) :: g
allocate (g%j(size(f%j)), source = -f%j)
end function
end module
program main_tmp
use foo_m
implicit none
type(foo) f, g(2)
allocate (f%j(3))
f%j = [2, 3, 4]
g = f
if (any (g(2)%j .ne. [2, 3, 4])) stop 1
g = g .binaryElemental. (f .binary. f) ! threw "Segmentation fault"
if (any (g(2)%j .ne. [-2,-3,-4])) stop 2
g = g .binaryElemental. ( .unary. f) ! threw "Segmentation fault"
if (any (g(2)%j .ne. [-4,-6,-8])) stop 3
end program
