public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r11-3430] This patch fixes PR96495 - frees result components outside loop.
@ 2020-09-24 10:52 Paul Thomas
0 siblings, 0 replies; only message in thread
From: Paul Thomas @ 2020-09-24 10:52 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:e86a02f87d8a11480c1421ef2dd71b8b5f43d938
commit r11-3430-ge86a02f87d8a11480c1421ef2dd71b8b5f43d938
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Thu Sep 24 11:52:30 2020 +0100
This patch fixes PR96495 - frees result components outside loop.
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.
Diff:
---
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 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 (&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 89ff5ac4182..6b0918715d7 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 <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
\ No newline at end of file
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-09-24 10:52 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-09-24 10:52 [gcc r11-3430] This patch fixes PR96495 - frees result components outside loop Paul Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).