Fortran: Dependency check in PDT specification assignments [PR83763]

2025-09-15  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/83763
	* trans-decl.cc (gfc_trans_deferred_vars): Ensure that the
	parameterized components of PDTs that do not have allocatable
	components are deallocated on leaving scope.
	* trans-expr.cc (gfc_trans_assignment_1): Do a dependency check
	on PDT assignments. If there is a dependency between lhs and
	rhs, deallocate the lhs parameterized components after the rhs
	has been evaluated.

gcc/testsuite/
	PR fortran/83763
	* gfortran.dg/pdt_46.f03: New test.

3 files changed, 100 insertions, 22 deletions

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index f03144f..f423dd7 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4908,21 +4908,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	{
 	  is_pdt_type = true;
 	  gfc_init_block (&tmpblock);
-	  if (!(sym->attr.dummy
-		|| sym->attr.pointer
-		|| sym->attr.allocatable))
+	  if (!sym->attr.dummy && !sym->attr.pointer)
 	    {
-	      tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
-					   sym->backend_decl,
-					   sym->as ? sym->as->rank : 0,
-					   sym->param_list);
-	      gfc_add_expr_to_block (&tmpblock, tmp);
-	      if (!sym->attr.result)
+	      if (!sym->attr.allocatable)
+		{
+		  tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
+					       sym->backend_decl,
+					       sym->as ? sym->as->rank : 0,
+					       sym->param_list);
+		  gfc_add_expr_to_block (&tmpblock, tmp);
+		}
+
+	      if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp)
 		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)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e0ae41f1..271d263 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -13213,26 +13213,39 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	}
 
       /* Deallocate the lhs parameterized components if required.  */
-      if (dealloc && expr2->expr_type == EXPR_FUNCTION
-	  && !expr1->symtree->n.sym->attr.associate_var)
+      if (dealloc
+	  && !expr1->symtree->n.sym->attr.associate_var
+	  && ((expr1->ts.type == BT_DERIVED
+	       && expr1->ts.u.derived
+	       && expr1->ts.u.derived->attr.pdt_type)
+	      || (expr1->ts.type == BT_CLASS
+		   && CLASS_DATA (expr1)->ts.u.derived
+		   && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)))
 	{
-	  if (expr1->ts.type == BT_DERIVED
-	      && expr1->ts.u.derived
-	      && expr1->ts.u.derived->attr.pdt_type)
+	  bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
+
+	  tmp = lse.expr;
+	  if (pdt_dep)
 	    {
-	      tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
-					     expr1->rank);
-	      gfc_add_expr_to_block (&lse.pre, tmp);
+	      /* Create a temporary for deallocation after assignment.  */
+	      tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
+	      gfc_add_modify (&lse.pre, tmp, lse.expr);
 	    }
-	  else if (expr1->ts.type == BT_CLASS
-		   && CLASS_DATA (expr1)->ts.u.derived
-		   && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
+
+	  if (expr1->ts.type == BT_DERIVED)
+	    tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
+					   expr1->rank);
+	  else if (expr1->ts.type == BT_CLASS)
 	    {
-	      tmp = gfc_class_data_get (lse.expr);
+	      tmp = gfc_class_data_get (tmp);
 	      tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
 					     tmp, expr1->rank);
-	      gfc_add_expr_to_block (&lse.pre, tmp);
 	    }
+
+	  if (tmp && pdt_dep)
+	    gfc_add_expr_to_block (&rse.post, tmp);
+	  else if (tmp)
+	    gfc_add_expr_to_block (&lse.pre, tmp);
 	}
     }
 
diff --git a/gcc/testsuite/gfortran.dg/pdt_46.f03 b/gcc/testsuite/gfortran.dg/pdt_46.f03
new file mode 100644
index 0000000..67d32df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_46.f03
@@ -0,0 +1,62 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR83763 in which a dependency was not handled correctly, which
+! resulted in a runtime segfault.
+!
+! Contributed by Berke Durak  <berke.durak@gmail.com>
+!
+module bar
+  implicit none
+
+  type :: foo(n)
+     integer, len :: n = 10
+     real :: vec(n)
+  end type foo
+
+contains
+
+  function baz(a) result(b)
+    type(foo(n = *)), intent(in) :: a
+    type(foo(n = a%n)) :: b
+
+    b%vec = a%vec * 10
+  end function baz
+
+end module bar
+
+program test
+  use bar
+  implicit none
+  call main1   ! Original report
+  call main2   ! Check for memory loss with allocatable 'x' and 'y'.
+
+contains
+
+  subroutine main1
+    type(foo(5)) :: x, y
+    integer :: a(5) = [1,2,3,4,5]
+
+    x = foo(5)(a)
+    x = baz (x)            ! Segmentation fault because dependency not handled.
+    if (any (x%vec /= 10 * a)) stop 1
+    y = x
+    x = baz (y)            ! No dependecy and so this worked.
+    if (any (x%vec /= 100 * a)) stop 2
+  end subroutine main1
+
+  subroutine main2
+    type(foo(5)), allocatable :: x, y
+    integer :: a(5) = [1,2,3,4,5]
+
+    x = foo(5)(a)
+    x = baz (x)            ! Segmentation fault because dependency not handled.
+    if (any (x%vec /= 10 * a)) stop 3
+    y = x
+    x = baz (y)            ! No dependecy and so this worked.
+    if (any (x%vec /= 100 * a)) stop 4
+  end subroutine main2
+
+end program test
+! { dg-final { scan-tree-dump-times "__builtin_free" 16 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 12 "original" } }