From: Paul Thomas <pault@gcc.gnu.org>
Date: Wed, 5 Nov 2025 12:17:10 +0000 (+0000)
Subject: Fortran: Add non-PDT type extension to PDTs [PR122566]
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=4983e9745edae3807243693e8865835b45f08c95;p=thirdparty%2Fgcc.git

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 5b222cd0ce5..96ee6bf7b68 100644
--- 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
index 00000000000..b3493b16f2e
--- /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" } }