Fortran: Fix ICE arising from PDT class components [PR110012]

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

gcc/fortran
	PR fortran/110012
	* decl.cc (gfc_get_pdt_instance): Continue to loop through the
	type parameters components if param_list is null and the
	parameter is not KIND with a default initializer.
	* resolve.cc (resolve_fl_derived): If the data component is a
	PDT template, find the instance and build the class.

gcc/testsuite
	PR fortran/110012
	* gfortran.dg/pdt_77.f03: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 0e55171068b9082c3b5a2fdec651caab997b27df..8f18f9e61a2cfe2130b793e18da56097afa52fcb 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4027,6 +4027,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
       if (!pdt->attr.use_assoc && !c1)
        goto error_return;
 
+      /* Resolution PDT class components of derived types are handled here.
+        They can arrive without a parameter list and no KIND parameters.  */
+      if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
+       continue;
+
       kind_expr = NULL;
       if (!name_seen)
        {

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index db6b52f307608ce2c71fb5f6ee90de2695a7c615..153ff42f290e1e022230718699daa53da83ddcac 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -17628,6 +17628,22 @@ resolve_fl_derived (gfc_symbol *sym)
       gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
       gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
 
+      if (data->ts.u.derived->attr.pdt_template)
+       {
+         match m;
+         m = gfc_get_pdt_instance (sym->param_list, &data->ts.u.derived,
+                                   &data->param_list);
+         if (m != MATCH_YES
+             || !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+           {
+             gfc_error ("Failed to build PDT class component at %L",
+                        &sym->declared_at);
+             return false;
+           }
+         data = gfc_find_component (sym, "_data", true, true, NULL);
+         vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
+       }
+
       /* Nothing more to do for unlimited polymorphic entities.  */
       if (data->ts.u.derived->attr.unlimited_polymorphic)
        {
@@ -17639,7 +17655,7 @@ resolve_fl_derived (gfc_symbol *sym)
          gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
          gcc_assert (vtab);
          vptr->ts.u.derived = vtab->ts.u.derived;
-         if (!resolve_fl_derived0 (vptr->ts.u.derived))
+         if (vptr->ts.u.derived && !resolve_fl_derived0 (vptr->ts.u.derived))
            return false;
        }
     }

diff --git a/gcc/testsuite/gfortran.dg/pdt_77.f03 b/gcc/testsuite/gfortran.dg/pdt_77.f03
new file mode 100644 (file)
index 0000000..627c0f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_77.f03
@@ -0,0 +1,63 @@
+! { dg-do run }
+!
+! Test the fix for PR110012, which failed to compile with an ICE.
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+module pde_class
+  type, abstract :: pde(npde)
+    integer,len :: npde
+  end type
+end module
+
+module navier_stokes_type
+  use pde_class
+  type, extends(pde) :: navier_stokes
+    integer, allocatable :: data_(:)
+  end type
+contains
+  subroutine alloc_navier_stokes(p , n)
+    class(pde(:)), allocatable :: p
+    integer :: n
+    allocate(navier_stokes(npde=n) :: p)
+    select type (p)
+      type is (navier_stokes(*))
+        p%data_ = [(i, i = 1, p%npde)]
+    end select
+  end subroutine
+end module
+
+module mfe_disc_type
+  use pde_class
+  type :: foo
+    class(pde(:)), allocatable :: p ! This caused the ICE in resolution.
+  end type
+end module
+
+program test
+  call navier_stokes_test
+  call mfe_disc_test
+contains
+  subroutine navier_stokes_test
+    use navier_stokes_type
+    class (pde(:)), allocatable :: x
+    call alloc_navier_stokes (x, 4)
+    select type (x)
+      type is (navier_stokes(*))
+        if (any (x%data_ /= [1,2,3,4])) stop 1
+    end select
+  end subroutine
+
+  subroutine mfe_disc_test
+    use navier_stokes_type
+    use mfe_disc_type
+    type (foo), allocatable :: x
+    allocate (x)
+    call alloc_navier_stokes (x%p, 3)
+    select type (z => x%p)
+      type is (navier_stokes(*))
+        if (any (z%data_ /= [1,2,3])) stop 2
+    end select
+    if (allocated (x) .and. allocated (x%p)) deallocate (x%p)
+  end subroutine
+end program