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 --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 2568f7378926ba87b333195e9b9cb4de845c5382..20260ec57ce79f5268affefc3c15a27bef45f25c 100644 (file)
--- 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 496ee45294e41c81f4b911ea7fc0c9d53a7916c2..729e3b523fa4f0876e26635a33089a181e45dd25 100644 (file)
--- 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 2164b37e4cb2d5247386ce892ad943300719d751..06edc998b56fe239e10803b953cf705296f6d51a 100644 (file)
--- 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 6a465f480dd5adc6c448ede9e55837e8f82644e5..52cebf51d79945eb5d87720000b0b648f48178eb 100644 (file)
--- 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 (file)
index 0000000..ec9cde0
--- /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" } }