re PR fortran/83567 (Parametrized derived types: Segmentation fault when…

re PR fortran/83567 (Parametrized derived types: Segmentation fault when assigning a function return value)

2017-12-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83567
	* trans-expr.c (gfc_trans_assignment_1): Free parameterized
	components of the lhs if dealloc is set.
	*trans-decl.c (gfc_trans_deferred_vars): Do not free the
	parameterized components of function results on leaving scope.


2017-12-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83567
	* gfortran.dg/pdt_26.f90 : New test.

From-SVN: r256019

gcc/fortran/ChangeLog

+2017-12-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/83567
+	* trans-expr.c (gfc_trans_assignment_1): Free parameterized
+	components of the lhs if dealloc is set.
+	*trans-decl.c (gfc_trans_deferred_vars): Do not free the
+	parameterized components of function results on leaving scope.
+
 2017_12_27  Louis Krupp  <louis.krupp@zoho.com>
 
 	PR fortran/83092

gcc/fortran/trans-decl.c

@@ -4344,9 +4344,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 					   sym->as ? sym->as->rank : 0,
 					   sym->param_list);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
-	      tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
-					     sym->backend_decl,
-					     sym->as ? sym->as->rank : 0);
+	      if (!sym->attr.result)
+		tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
+					       sym->backend_decl,
+					       sym->as ? sym->as->rank : 0);
+	      else
+		tmp = NULL_TREE;
 	      gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
 	    }
 	  else if (sym->attr.dummy)
@@ -4376,8 +4379,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 					   sym->param_list);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	      tmp = gfc_class_data_get (sym->backend_decl);
-	      tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
-					     data->as ? data->as->rank : 0);
+	      if (!sym->attr.result)
+		tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
+					       data->as ? data->as->rank : 0);
+	      else
+		tmp = NULL_TREE;
 	      gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
 	    }
 	  else if (sym->attr.dummy)

gcc/fortran/trans-expr.c

@@ -10076,6 +10076,28 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  gfc_trans_runtime_check (true, false, cond, &loop.pre,
 				   &expr1->where, msg);
 	}
+
+      /* Deallocate the lhs parameterized components if required.  */ 
+      if (dealloc && expr2->expr_type == EXPR_FUNCTION)
+	{
+	  if (expr1->ts.type == BT_DERIVED
+	      && expr1->ts.u.derived
+	      && expr1->ts.u.derived->attr.pdt_type)
+	    {
+	      tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
+					     expr1->rank);
+	      gfc_add_expr_to_block (&lse.pre, tmp);
+	    }
+	  else if (expr1->ts.type == BT_CLASS
+		   && CLASS_DATA (expr1)->ts.u.derived
+		   && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
+	    {
+	      tmp = gfc_class_data_get (lse.expr);
+	      tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
+					     tmp, expr1->rank);
+	      gfc_add_expr_to_block (&lse.pre, tmp);
+	    }
+	}
     }
 
   /* Assignments of scalar derived types with allocatable components

gcc/testsuite/ChangeLog

+2017-12-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/83567
+	* gfortran.dg/pdt_26.f90 : New test.
+
 2017_12_27  Louis Krupp  <louis.krupp@zoho.com>
 
 	PR fortran/83092

gcc/testsuite/gfortran.dg/pdt_26.f03

+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR83567 in which the parameterized component 'foo' was
+! being deallocated before return from 'addw', with consequent segfault in 
+! the main program.
+!
+! Contributed by Berke Durak  <berke.durak@gmail.com>
+! The function 'addvv' has been made elemental so that the test can check that
+! arrays are correctly treated and that no memory leaks occur.
+!
+module pdt_m
+  implicit none
+  type :: vec(k)
+     integer, len :: k=3
+     integer :: foo(k)=[1,2,3]
+  end type vec
+contains
+  elemental function addvv(a,b) result(c)
+    type(vec(k=*)), intent(in) :: a
+    type(vec(k=*)), intent(in) :: b
+    type(vec(k=a%k)) :: c
+
+    c%foo=a%foo+b%foo
+  end function
+end module pdt_m
+
+program test_pdt
+  use pdt_m
+  implicit none
+  type(vec) :: u,v,w, a(2), b(2), c(2)
+  integer :: i
+
+  u%foo=[1,2,3]
+  v%foo=[2,3,4]
+  w=addvv(u,v)
+  if (any (w%foo .ne. [3,5,7])) call abort
+  do i = 1 , a(1)%k
+    a%foo(i) = i + 4
+    b%foo(i) = i + 7
+  end do
+  c = addvv(a,b)
+  if (any (c(1)%foo .ne. [13,15,17])) call abort
+end program test_pdt
+! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } }