FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

This patch fixes PR96495 - frees result components outside loop.

Browse source 
2020-24-09  Paul Thomas  <pault@gcc.gnu.org>

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.
This commit is contained in:
Paul Thomas 2020-09-24 11:52:30 +01:00
parent fe28d34079
commit e86a02f87d
2 changed files with 95 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
gcc/fortran/trans-expr.c
View file

@ -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);
}
}

93
gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90
View file

@ -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 <juergen.reuter@desy.de>
! Reduced testcase from Tobias Burnus <burnus@gcc.gnu.org>
! Test the fix for PR96495 - segfaults at runtime at locations below.
!
! Contributed by Paul Luckner <paul.luckner@rwth-aachen.de>
!
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