The attached patch applies F2023 19.6.5(24) "Invocation of a procedure that has a nonpointer, nonallocatable INTENT (OUT) dummy argument causes all nonpointer, default-initialized subcomponents of the dummy argument to become defined.", thereby fixing bug12-intent-out-default-init.f90.
Although this is one of the larger patches in this series, it can be readily followed with the ChangeLog and the comments. Passes regtesting on FC44/x86_64. OK for mainline. Cheers Paul
From 0b120537078af61ffbf177192b3fff492284d5eb Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Wed, 7 Oct 2026 10:32:15 +0100 Subject: [PATCH] Fortran: [meta-bug] [PDT] Parameterized derived type errors [PR82173] 2026-10-07 Paul Thomas <[email protected]> gcc/fortran PR fortran/82173 * trans-array.cc (structure_alloc_comps): CHECK_PDT_INTENT_OUT_ DUMMY added to enum and flag 'intent_out' set. If any of - 'intent_out' is false, the component has a codimension, is a pointer, is a parmeterized kind, a KIND or LEN parameter, does not have an initializer then continue through the components. Otherwise, convert the initializer and set the component for constants, array constructors or structure constructors. gcc/testsuite/ PR fortran/82173 * gfortran.dg/pdt_bug12.f90: New test. --- gcc/fortran/trans-array.cc | 56 ++++++++++++++++++++++--- gcc/fortran/trans-array.h | 3 +- gcc/fortran/trans-decl.cc | 10 ++++- gcc/testsuite/gfortran.dg/pdt_bug12.f90 | 44 +++++++++++++++++++ 4 files changed, 104 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug12.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index ab1aa6d457d..2045424a861 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9986,7 +9986,7 @@ gfc_caf_is_dealloc_only (int caf_mode) enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY, - BCAST_ALLOC_COMP}; + CHECK_PDT_INTENT_OUT_DUMMY, BCAST_ALLOC_COMP}; static gfc_actual_arglist *pdt_param_list; static bool generating_copy_helper; @@ -10161,6 +10161,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int caf_dereg_mode; symbol_attribute *attr; bool deallocate_called; + bool intent_out = purpose == CHECK_PDT_INTENT_OUT_DUMMY; gfc_init_block (&fnblock); @@ -11381,6 +11382,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, break; case CHECK_PDT_DUMMY: + case CHECK_PDT_INTENT_OUT_DUMMY: comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -11397,18 +11399,58 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, { tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, c->as ? c->as->rank : 0, - pdt_param_list); + pdt_param_list, intent_out); gfc_add_expr_to_block (&fnblock, tmp); } if (!c->attr.pdt_len) - continue; + { + gfc_se tse; + if (!intent_out + || c->attr.codimension + || c->attr.pointer + || IS_PDT (c) || IS_CLASS_PDT (c) + || c->attr.pdt_comp || c->attr.pdt_kind + || !c->initializer + || !gfc_is_constant_expr (c->initializer)) // Just in case! + continue; + + /* F2023 19.6.5(24) "Invocation of a procedure that has a + nonpointer, nonallocatable INTENT (OUT) dummy argument causes + all nonpointer default-initialized subcomponents of the dummy + argument to become defined." */ + if (c->initializer->expr_type == EXPR_CONSTANT) + { + gfc_init_se (&tse, NULL); + gfc_conv_expr (&tse, c->initializer); + gfc_add_modify (&fnblock, comp, tse.expr); + } + else if (c->initializer->expr_type == EXPR_STRUCTURE) + { + tmp = gfc_trans_structure_assign (comp, c->initializer, + true, false); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (c->initializer->expr_type == EXPR_ARRAY) + { + tree type = TREE_TYPE (TREE_TYPE (comp)); + tree len = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp)); + len = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (len), len, + TYPE_SIZE_UNIT (type)); + + tmp = gfc_build_constant_array_constructor (c->initializer, type); + tmp = gfc_build_memcpy_call (gfc_conv_array_data (comp), tmp, len); + gfc_add_expr_to_block (&fnblock, tmp); + } + else + continue; + } else { gfc_se tse; gfc_expr *c_expr = NULL; gfc_actual_arglist *param = pdt_param_list; - gfc_init_se (&tse, NULL); for (; param; param = param->next) if (!strcmp (c->name, param->name) @@ -11612,13 +11654,15 @@ gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) tree gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, - gfc_actual_arglist *param_list) + gfc_actual_arglist *param_list, bool intent_out) { tree res; gfc_actual_arglist *old_param_list = pdt_param_list; pdt_param_list = param_list; res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - CHECK_PDT_DUMMY, 0, NULL); + intent_out ? CHECK_PDT_INTENT_OUT_DUMMY : + CHECK_PDT_DUMMY, + 0, NULL); pdt_param_list = old_param_list; return res; } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 15bade95b28..00bd73c1e22 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -69,7 +69,8 @@ tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *); tree gfc_deallocate_pdt_comp (gfc_symbol *, tree, int); -tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *); +tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *, + bool intent_out = false); tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index e1420a77972..44e8b8dde76 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1749,7 +1749,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) && (gfc_current_ns == sym->ns || (gfc_current_ns == sym->ns->parent && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) - && !(sym->attr.use_assoc || sym->attr.dummy || sym->attr.result)) + && !(sym->attr.use_assoc || sym->attr.result + || (sym->attr.dummy && sym->attr.intent != INTENT_OUT))) gfc_defer_symbol_init (sym); if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp) @@ -5203,11 +5204,16 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->attr.dummy) { + bool intent_out = false; + /* F2023 19.6.5(24) */ + if (sym->attr.intent == INTENT_OUT) + intent_out = true; tmp = gfc_check_pdt_dummy (sym->ts.u.derived, sym->backend_decl, sym->as ? sym->as->rank : 0, - sym->param_list); + sym->param_list, intent_out); gfc_add_expr_to_block (&tmpblock, tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); } } diff --git a/gcc/testsuite/gfortran.dg/pdt_bug12.f90 b/gcc/testsuite/gfortran.dg/pdt_bug12.f90 new file mode 100644 index 00000000000..5421e72245c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug12.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Neither gfc nor ifx give the expected tag = 77 > Is this test correct? +! F2023 19.6.5(24) "Invocation of a procedure that has a nonpointer +! nonallocatable INTENT (OUT) dummy argument causes all nonpointer +! default-initialized subcomponents of the dummy argument to become defined. +! See attachment to PR82173 comment 10 - reproducers/bug12-intent-out-default-init.f90 +module mk + type :: s + integer :: i + real :: j + end type + + type :: t(n) + integer, len :: n = 1 + real :: v(n) + integer(4) :: tag = 77 + integer(4) :: arr(2) = [1_4 , 2_4] + type(s) :: der = s (1, 2.0) + end type +contains + subroutine reset (a) + type(t(3)), intent(out) :: a + if (a%tag /= 77) a%tag = 0 + end subroutine + subroutine resetp (a) + type(t(*)), intent(out) :: a + if (a%tag /= 77) a%tag = 0 + end subroutine +end module +program k1 + use mk + type(t(3)) :: a + a%tag = 5 + a%v = 0.0 + call reset (a) + if (a%tag /= 77) stop 1 + if (any (a%arr /= [1_4,2_4])) stop 2 + if ((a%der%i /= 1) .or. (int (100 * a%der%j) /= 200)) stop 3 + a%tag = 5 + call resetp (a) + if (a%tag /= 77) stop 4 + if (any (a%arr /= [1_4,2_4])) stop 5 + if ((a%der%i /= 1) .or. (int (100 * a%der%j) /= 200)) stop 6 +end program -- 2.55.0
