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 --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 36ff9b5cbc64d5157179488763525c7da2e6debe..a690839f591f794c0d215a4617ff3baae2a89d8b 100644 (file)
--- 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 89ff5ac4182be02d063119baa662eb823fc528d5..6b0918715d77018c19376614ba26397d4937b70d 100644 (file)
--- 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