From: Paul Thomas Date: Wed, 3 Dec 2025 09:40:26 +0000 (+0000) Subject: Fortran: Implement finalization PDTs [PR103371] X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=57aca7d7f8c4317288e708aa9e20ab88179c8c66;p=thirdparty%2Fgcc.git Fortran: Implement finalization PDTs [PR103371] 2025-12-03 Paul Thomas gcc/fortran PR fortran/103371 * decl.cc (gfc_get_pdt_instance): Remove the requirement that PDT components be of the same type as the enclosing type. Apply initializers other than the default to PDT components. * primary.cc (gfc_match_rvalue): Make combination of the two actual_arglists conditional on 'type_spec_list' having been seen as well together with applying component names to all the arguments. * trans-decl.cc (gfc_init_default_dt): Add 'pdt_ok' to the args and use it to signal that a PDT can be default initialized. (gfc_init_default_pdt): New function to check that a pdt is OK for default intialization before calling gfc_init_default_dt. (gfc_trans_deferred_vars): Use gfc_init_default_pdt. * trans.h: Add bool 'pdt_ok' to prototype with defaul value of false. gcc/testsuite PR fortran/103371 * gfortran.dg/pdt_71.f03: New test. --- diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 2568f737892..20260ec57ce 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -3982,8 +3982,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (gfc_current_state () == COMP_DERIVED && !(gfc_state_stack->previous && gfc_state_stack->previous->state == COMP_DERIVED) - && gfc_current_block ()->attr.pdt_template - && !strcmp (gfc_current_block ()->name, (*sym)->name)) + && gfc_current_block ()->attr.pdt_template) { if (ext_param_list) *ext_param_list = gfc_copy_actual_arglist (param_list); @@ -4447,7 +4446,25 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, type_param_spec_list = old_param_spec_list; if (!(c2->attr.pointer || c2->attr.allocatable)) - c2->initializer = gfc_default_initializer (&c2->ts); + { + if (!c1->initializer + || c1->initializer->expr_type != EXPR_FUNCTION) + c2->initializer = gfc_default_initializer (&c2->ts); + else + { + gfc_symtree *s; + c2->initializer = gfc_copy_expr (c1->initializer); + s = gfc_find_symtree (pdt->ns->sym_root, + gfc_dt_lower_string (c2->ts.u.derived->name)); + if (s) + c2->initializer->symtree = s; + c2->initializer->ts = c2->ts; + if (!s) + gfc_insert_parameter_exprs (c2->initializer, + type_param_spec_list); + gfc_simplify_expr (params->expr, 1); + } + } if (c2->attr.allocatable) instance->attr.alloc_comp = 1; diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 496ee45294e..729e3b523fa 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -4173,11 +4173,21 @@ gfc_match_rvalue (gfc_expr **result) symtree->n.sym->ts.type = BT_DERIVED; } - /* Append the type_params and the component_values. */ - for (tmp = ctr_arglist; tmp && tmp->next;) - tmp = tmp->next; - tmp->next = actual_arglist; - actual_arglist = ctr_arglist; + if (type_spec_list) + { + /* Append the type_params and the component_values. */ + for (tmp = ctr_arglist; tmp && tmp->next;) + tmp = tmp->next; + tmp->next = actual_arglist; + actual_arglist = ctr_arglist; + tmp = actual_arglist; + /* Can now add all the component names. */ + for (c = pdt_sym->components; c && tmp; c = c->next) + { + tmp->name = c->name; + tmp = tmp->next; + } + } } } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 2164b37e4cb..06edc998b56 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4566,7 +4566,8 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) and using trans_assignment to do the work. Set dealloc to false if no deallocation prior the assignment is needed. */ void -gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc, + bool pdt_ok) { gfc_expr *e; tree tmp; @@ -4575,7 +4576,8 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) gcc_assert (block); /* Initialization of PDTs is done elsewhere. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type + && !pdt_ok) return; gcc_assert (!sym->attr.allocatable); @@ -4594,6 +4596,28 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) } +/* Initialize a PDT, when all the components have an initializer. */ +static void +gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc) +{ + /* Allowed in the case where all the components have initializers and + there are no LEN components. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_component *c = sym->ts.u.derived->components; + if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE) + return; + for (; c; c = c->next) + if (c->attr.pdt_len || !c->initializer) + return; + } + else + return; + gfc_init_default_dt (sym, block, dealloc, true); + return; +} + + /* Initialize INTENT(OUT) derived type dummies. As well as giving them their default initializer, if they have allocatable components, they have their allocatable components deallocated. */ @@ -4985,6 +5009,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_expr_to_block (&tmpblock, tmp); } + if (is_pdt_type) + gfc_init_default_pdt (sym, &tmpblock, true); + if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp) tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, sym->backend_decl, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 6a465f480dd..52cebf51d79 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -666,7 +666,8 @@ tree gfc_get_symbol_decl (gfc_symbol *); tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool); /* Assign a default initializer to a derived type. */ -void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); +void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool, + bool pdt_ok = false); /* Substitute a temporary variable in place of the real one. */ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); diff --git a/gcc/testsuite/gfortran.dg/pdt_71.f03 b/gcc/testsuite/gfortran.dg/pdt_71.f03 new file mode 100644 index 00000000000..ec9cde06731 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_71.f03 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the second part of the fix for PR103371. +! +! Compiled but gave the wrong result for the component 'z%x%n'. +! +! Contributed by Arseny Solokha +! +module m1 + implicit none + type t + integer :: n + end type + type t2 + ! t and t2 must be resolved to types in m1, not components in t2 + type(t) :: t(10) = t(1) + type(t) :: x = t(1) + integer :: t2 + type(t2), pointer :: p => NULL() + end type +end + +module m2 + type :: t(tn) + integer, kind :: tn + integer(kind=tn) :: n + end type + type :: t2(tm) + integer, kind :: tm + type(t(tm)) :: x = t(tm)(2*tm) + end type +end + + call test_m2 +contains + subroutine test_m2 + use m2 + type(t2(KIND (1))) :: z + print *, kind (z%x%n), z%x%n + end subroutine +end +! { dg-final { scan-tree-dump-times "Pdtt2_4.1.x.n = 8" 1 "original" } } +! { dg-final { scan-tree-dump-times "z = Pdtt2_4.1" 1 "original" } }