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.

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 <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