Fortran: Pass PDTs to dummies with VALUE attribute [PR99709]

2025-08-31  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/99709
	* trans-array.cc (structure_alloc_comps): For the case
	COPY_ALLOC_COMP, do a deep copy of non-allocatable PDT arrays
	Suppress the use of 'duplicate_allocatable' for PDT arrays.
	* trans-expr.cc (conv_dummy_value): When passing to a PDT dummy
	with the VALUE attribute, do a deep copy to ensure that
	parameterized components are reallocated.

gcc/testsuite/
	PR fortran/99709
	* gfortran.dg/pdt_41.f03: New test.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 193bac51240282d38a8742b44a635fb5148d3535..0449c26ce6d5c03472dad40cdd3e4b6338bb64f0 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10710,6 +10710,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
                                  cdecl, NULL_TREE);
          dcmp = fold_convert (TREE_TYPE (comp), dcmp);
 
+         if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
+             && !c->attr.allocatable)
+           {
+             tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
+                                        0, 0);
+             gfc_add_expr_to_block (&fnblock, tmp);
+             continue;
+           }
+
          if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
            {
              tree ftn_tree;
@@ -10829,7 +10838,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
                                           false, false, size, NULL_TREE);
              gfc_add_expr_to_block (&fnblock, tmp);
            }
-         else if (c->attr.pdt_array)
+         else if (c->attr.pdt_array
+                  && !c->attr.allocatable && !c->attr.pointer)
            {
              tmp = duplicate_allocatable (dcmp, comp, ctype,
                                           c->as ? c->as->rank : 0,

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 69952b33eaa8090d646376fb25db4fa97dacc441..6a21e8c10e85a03062b8dfb01cf0226ff76a8ea3 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6520,6 +6520,20 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
 
   gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
 
+  if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type)
+    {
+      tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
+      gfc_add_modify (&parmse->pre, tmp, parmse->expr);
+      gfc_add_expr_to_block (&parmse->pre,
+                            gfc_copy_alloc_comp (e->ts.u.derived,
+                                                 parmse->expr, tmp,
+                                                 e->rank, 0));
+      parmse->expr = tmp;
+      tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
+      gfc_add_expr_to_block (&parmse->post, tmp);
+      return;
+    }
+
   /* Absent actual argument for optional scalar dummy.  */
   if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
     {

diff --git a/gcc/testsuite/gfortran.dg/pdt_41.f03 b/gcc/testsuite/gfortran.dg/pdt_41.f03
new file mode 100644 (file)
index 0000000..be2e871
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_41.f03
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Test the fix for pr99709 in which the object being passed to a PDT dummy
+! with the value attribute was not a deep copy.
+!
+! Contribute by Xiao Liu  <xiao.liu@compiler-dev.com>
+!
+program value_f2008
+  implicit none
+  type :: matrix(k)
+    integer, len :: k
+    integer :: elements(k, k)
+    !integer :: elements(2, 2)
+  end type matrix
+
+  type, extends(matrix) :: child
+  end type child
+
+  integer, parameter :: array_parm(2, 2) = reshape([1, 2, 3, 4], [2, 2])
+
+  type(child(2)) :: obj
+  obj%elements = array_parm
+
+  call test_value_attr(2, obj)
+  if (any (obj%elements /= array_parm)) stop 1 
+
+  call test(2, obj)
+  if (any (obj%elements /= 0)) stop 2 
+
+contains
+
+  subroutine test(n,  nonconstant_length_object)
+    integer :: n
+    type(child(n)) :: nonconstant_length_object
+    if (nonconstant_length_object%k /= 2) stop 3
+    if (any (nonconstant_length_object%elements /= array_parm)) stop 4
+    nonconstant_length_object%elements = 0
+  end subroutine test
+
+  subroutine test_value_attr(n,  nonconstant_length_object)
+    integer :: n
+    type(child(n)), value :: nonconstant_length_object
+    if (nonconstant_length_object%k /= 2) stop 5
+    if (any (nonconstant_length_object%elements /= array_parm)) stop 6
+    nonconstant_length_object%elements = 0
+  end subroutine test_value_attr
+end program value_f2008