[Patch, fortran] PR96495 - [gfortran] Composition of user-defined operators does not copy ALLOCATABLE property of derived type

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 970 bytes --]

This patch detects a scalar function result that has allocatable components
and is being used inside a scalarization loop. Before this patch, the
components would be deallocated and nullified within the scalarization loop
and so would cause a segfault on the second cycle of the loop.

The stored result has to be found by identifying the expression in the loop
ss chain. This is then used for the deallocation of the allocatable
components in the loop post block, which keeps gimple happy and prevents
the segfault.

Regtests on FC31/x86_64 - OK for master?

Paul

This patch fixes PR96495 - frees result components outside loop.

2020-29-08  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.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 1393 bytes --]

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

[-- Attachment #3: alloc_comp_result_2.f90 --]
[-- Type: text/x-fortran, Size: 1577 bytes --]

! { dg-do run }
!
! 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 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

  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