From d21f10259f64723f8deae3bccc15128075de4851 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 31 Aug 2025 16:47:18 +0100 Subject: Fortran: Pass PDTs to dummies with VALUE attribute [PR99709] 2025-08-31 Paul Thomas 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. --- gcc/fortran/trans-array.cc | 12 ++++++++- gcc/fortran/trans-expr.cc | 14 +++++++++++ gcc/testsuite/gfortran.dg/pdt_41.f03 | 47 ++++++++++++++++++++++++++++++++++++ 3 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_41.f03 (limited to 'gcc') diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 193bac5..0449c26 100644 --- 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 69952b3..6a21e8c 100644 --- 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 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 +! +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 -- cgit v1.1