From e86a02f87d8a11480c1421ef2dd71b8b5f43d938 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 24 Sep 2020 11:52:30 +0100 Subject: [PATCH] This patch fixes PR96495 - frees result components outside loop. 2020-24-09 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. --- gcc/fortran/trans-expr.c | 26 ++++++- gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90 | 93 +++++++++++++++++------ 2 files changed, 95 insertions(+), 24 deletions(-) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 36ff9b5..a690839 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 (&post, tmp); + + if (scalar_res_outside_loop) + gfc_add_expr_to_block (&parmse.loop->post, tmp); + else + gfc_prepend_expr_to_block (&post, tmp); } } diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90 index 89ff5ac..6b09187 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90 @@ -1,28 +1,75 @@ ! { dg-do run } -! Tests the fix for PR40440, in which gfortran tried to deallocate -! the allocatable components of the actual argument of CALL SUB ! -! Contributed by Juergen Reuter -! Reduced testcase from Tobias Burnus +! Test the fix for PR96495 - segfaults at runtime at locations below. ! +! Contributed by Paul Luckner +! +module foo_m + implicit none - type t - integer, allocatable :: A(:) - end type t - type (t) :: arg - arg = t ([1,2,3]) - call sub (func (arg)) + + 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 - function func (a) - type(t), pointer :: func - type(t), target :: a - integer, save :: i = 0 - if (i /= 0) STOP 1! multiple calls would cause this abort - i = i + 1 - func => a - end function func - subroutine sub (a) - type(t), intent(IN), target :: a - if (any (a%A .ne. [1,2,3])) STOP 2 - end subroutine sub -end + + 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 \ No newline at end of file -- 2.7.4