[gcc r16-5848] Fortran: Implement finalization PDTs [PR103371]
Paul Thomas
pault@gcc.gnu.org
Wed Dec 3 09:40:38 GMT 2025
https://gcc.gnu.org/g:57aca7d7f8c4317288e708aa9e20ab88179c8c66
commit r16-5848-g57aca7d7f8c4317288e708aa9e20ab88179c8c66
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Wed Dec 3 09:40:26 2025 +0000
Fortran: Implement finalization PDTs [PR103371]
2025-12-03 Paul Thomas <pault@gcc.gnu.org>
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:
---
gcc/fortran/decl.cc | 23 ++++++++++++++++---
gcc/fortran/primary.cc | 20 ++++++++++++----
gcc/fortran/trans-decl.cc | 31 +++++++++++++++++++++++--
gcc/fortran/trans.h | 3 ++-
gcc/testsuite/gfortran.dg/pdt_71.f03 | 44 ++++++++++++++++++++++++++++++++++++
5 files changed, 110 insertions(+), 11 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 2568f7378926..20260ec57ce7 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 496ee45294e4..729e3b523fa4 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 2164b37e4cb2..06edc998b56f 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 6a465f480dd5..52cebf51d799 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 000000000000..ec9cde067315
--- /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 <asolokha@gmx.com>
+!
+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" } }
More information about the Gcc-cvs
mailing list