Hello All, Another Jerry/Claude review has caused a resubmission in this case: "Patch: 8 (bug12) Verdict: Blocker: an absent OPTIONAL INTENT(OUT) dummy segfaults. Array dummies get no initialization at all. git gcc-verify fails".
These are all fixed in the attached. Note that array dummies were OK but not tested. The patch passes regression testing on FC44/x86_64 - OK for mainline? Regards Paul On Thu, 8 Oct 2026 at 13:36, Paul Richard Thomas <[email protected]> wrote: > > 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 8aa2fd5197198bfb4f2a55aa692af6e4259e3d24 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Tue, 20 Oct 2026 11:33:29 +0100 Subject: [PATCH] Fortran: [PDT] (8/16) Parameterized derived type errors [PR82173] 2026-10-20 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. (gfc_check_pdt_dummy): Incorporate a new argument 'intent_out'; use it to switch to the above path in structure_alloc_comps. * trans-array.h : Add the new argument to the prototype of gfc_check_pdt_dummy. * trans-decl.cc (gfc_get_symbol_decl): gfc_defer_symbol_init is now called for intent_out dummies. (gfc_trans_deferred_vars): Call gfc_check_pdt_dummy with the new argument set. For optional arguments, gfc_conv_expr_present is used to apply a condition to the gfc_check_pdt_dummy result. 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 | 19 +++++- gcc/testsuite/gfortran.dg/pdt_bug12.f90 | 83 +++++++++++++++++++++++++ 4 files changed, 152 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 5d0d9ba1fda..08252ac4f2c 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) @@ -5204,11 +5205,25 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->attr.dummy) { + bool intent_out = false; + tree present = NULL_TREE; + /* 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); + if (sym->attr.optional) + { + present = gfc_conv_expr_present (sym, false); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + present, tmp, + build_empty_stmt (input_location)); + } + 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..e4ddc8fb39c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug12.f90 @@ -0,0 +1,83 @@ +! { 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 , a2) + type(t(3)), intent(out) :: a + type(t(3)), optional, intent(out) :: a2 + if (a%tag /= 77) a%tag = 0 + if (present (a2)) then + if (a2%tag /= 77) a2%tag = 0 ! Reference optional + end if + end subroutine + subroutine resetp (a) + type(t(*)), intent(out) :: a + if (a%tag /= 77) a%tag = 0 + end subroutine + subroutine reset_array (a, a2) + type(t(3)), intent(out) :: a(:) + type(t(3)), optional, intent(out) :: a2(:) + if (any (a%tag /= 77)) a%tag = 0 + if (present (a2)) then + if (any (a2%tag /= 77)) a2%tag = 0 ! ditto + end if + end subroutine +end module +program k1 + use mk + type(t(3)) :: a, opt + type(t(3)) :: b(2), b2(2) + a%tag = 5 + a%v = 0.0 + opt = a + b = a + b2 = b + +! First with missing optional argument: + 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 + +! Then with the missing argument: + call reset (a, opt) + if (opt%tag /= 77) stop 4 + if (any (opt%arr /= [1_4,2_4])) stop 5 + if ((opt%der%i /= 1) .or. (int (100 * opt%der%j) /= 200)) stop 6 + a%tag = 5 + +! Then and assumed parameter: + call resetp (a) + if (a%tag /= 77) stop 7 + if (any (a%arr /= [1_4,2_4])) stop 8 + if ((a%der%i /= 1) .or. (int (100 * a%der%j) /= 200)) stop 9 + +! Finally with an array + call reset_array (b) + if (any (b%tag /= 77)) stop 10 + if (any (b(1)%arr /= [1_4,2_4]) .or. any (b(2)%arr /= [1_4,2_4])) stop 11 + if (any (b%der%i /= 1) .or. any (int (100 * b%der%j) /= 200)) stop 12 + +! Again with the optional argument + call reset_array (b, b2) + if (any (b2%tag /= 77)) stop 13 + if (any (b2(1)%arr /= [1_4,2_4]) .or. any (b2(2)%arr /= [1_4,2_4])) stop 14 + if (any (b2%der%i /= 1) .or. any (int (100 * b2%der%j) /= 200)) stop 15 +end program -- 2.56.0
