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.

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index f03144f94275d51053a431e41b5d67272da56187..f423dd728aaa6685b78aabd1f0fc9be95ee08ad3 100644 (file)
--- 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 e0ae41f12c6d7649838362d3e7922811f045acf5..271d2633dfba9e130d02ec2b82d6afcdeab54035 100644 (file)
--- 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 (file)
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" } }