Fortran: Add non-PDT type extension to PDTs [PR122566]

2025-11-05  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/122566
	* decl.cc (gfc_get_pdt_instance): Add non-PDT type exstention.

gcc/testsuite/
	PR fortran/122566
	* gfortran.dg/pdt_68.f03: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5b222cd0ce514cda1aa1c8e5c05e8da25be302e7..96ee6bf7b686104e0d512007b30ee74a4998d788 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4191,30 +4191,36 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
         to obtain the instance of the extended type.  */
       if (gfc_current_state () != COMP_DERIVED
          && c1 == pdt->components
-         && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
-         && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
+         && c1->ts.type == BT_DERIVED
+         && c1->ts.u.derived
          && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
        {
-         gfc_formal_arglist *f;
+         if (c1->ts.u.derived->attr.pdt_template)
+           {
+             gfc_formal_arglist *f;
 
-         old_param_spec_list = type_param_spec_list;
+             old_param_spec_list = type_param_spec_list;
 
-         /* Obtain a spec list appropriate to the extended type..*/
-         actual_param = gfc_copy_actual_arglist (type_param_spec_list);
-         type_param_spec_list = actual_param;
-         for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
-           actual_param = actual_param->next;
-         if (actual_param)
-           {
-             gfc_free_actual_arglist (actual_param->next);
-             actual_param->next = NULL;
-           }
+             /* Obtain a spec list appropriate to the extended type..*/
+             actual_param = gfc_copy_actual_arglist (type_param_spec_list);
+             type_param_spec_list = actual_param;
+             for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+               actual_param = actual_param->next;
+             if (actual_param)
+               {
+                 gfc_free_actual_arglist (actual_param->next);
+                 actual_param->next = NULL;
+               }
 
-         /* Now obtain the PDT instance for the extended type.  */
-         c2->param_list = type_param_spec_list;
-         m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
-                                   &c2->param_list);
-         type_param_spec_list = old_param_spec_list;
+             /* Now obtain the PDT instance for the extended type.  */
+             c2->param_list = type_param_spec_list;
+             m = gfc_get_pdt_instance (type_param_spec_list,
+                                       &c2->ts.u.derived,
+                                       &c2->param_list);
+             type_param_spec_list = old_param_spec_list;
+           }
+         else
+           c2->ts = c1->ts;
 
          c2->ts.u.derived->refs++;
          gfc_set_sym_referenced (c2->ts.u.derived);

diff --git a/gcc/testsuite/gfortran.dg/pdt_68.f03 b/gcc/testsuite/gfortran.dg/pdt_68.f03
new file mode 100644 (file)
index 0000000..b3493b1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_68.f03
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check the fix for PR122566.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module double_precision_file_m
+  implicit none
+
+  type file_t
+    integer :: i
+  end type
+
+  type, extends(file_t) :: double_precision_file_t
+  end type
+
+  type, extends(double_precision_file_t) :: training_configuration_t(m)
+    integer, kind :: m = kind(1.)
+  end type
+
+contains
+  pure module function training_configuration()
+    type(training_configuration_t) training_configuration
+    training_configuration%file_t = file_t(42) ! Needed parent type to be introduced explicitly
+  end function
+end module
+
+  use double_precision_file_m
+  type(training_configuration_t) :: x
+  x = training_configuration ()
+  if (x%i /= 42) stop 1
+end
+! { dg-final { scan-tree-dump-times "double_precision_file_t.file_t" 2 "original" } }