Fortran: Fix ICE in deallocating PDTs [PR121191]

2025-10-13  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/121191
	* trans-array.cc (has_parameterized_comps): New function which
	checks if a derived type has parameterized components.
	( gfc_deallocate_pdt_comp): Use it to prevent deallocation of
	PDTs if there are no parameterized components.

gcc/testsuite/
	PR fortran/121191
	* gfortran.dg/pdt_59.f03: New test.

gcc/fortran/trans-array.cc

@@ -11385,9 +11385,27 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
 /* Recursively traverse an object of parameterized derived type, generating
    code to deallocate parameterized components.  */
 
+static bool
+has_parameterized_comps (gfc_symbol * der_type)
+{
+  /* A type without parameterized components causes gimplifier problems.  */
+  bool parameterized_comps = false;
+  for (gfc_component *c = der_type->components; c; c = c->next)
+    if (c->attr.pdt_array || c->attr.pdt_string)
+      parameterized_comps = true;
+    else if (c->ts.type == BT_DERIVED
+	     && c->ts.u.derived->attr.pdt_type
+	     && strcmp (der_type->name, c->ts.u.derived->name))
+      parameterized_comps = has_parameterized_comps (c->ts.u.derived);
+  return parameterized_comps;
+}
+
 tree
 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
 {
+  if (!has_parameterized_comps (der_type))
+    return NULL_TREE;
+
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				DEALLOCATE_PDT_COMP, 0, NULL);
 }

gcc/testsuite/gfortran.dg/pdt_59.f03

@@ -0,0 +1,47 @@
+! { dg-do compile }
+!
+! Test the fix for PR122191, which used to ICE in compilation.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module input_output_pair_m
+  implicit none
+
+  type input_output_pair_t(k)
+    integer, kind :: k
+    integer :: a, b
+  end type
+
+  type mini_batch_t(k)
+    integer, kind :: k = kind(1.)
+    type(input_output_pair_t(k)), allocatable :: input_output_pairs_(:)
+  end type
+
+  interface
+
+    module function default_real_construct()
+      implicit none
+      type(mini_batch_t) default_real_construct
+    end function
+
+  end interface
+
+end module
+
+submodule(input_output_pair_m) input_output_pair_smod
+contains
+  function default_real_construct()
+   type(mini_batch_t) default_real_construct
+   allocate (default_real_construct%input_output_pairs_(2))
+   default_real_construct%input_output_pairs_%a = [42,43]
+   default_real_construct%input_output_pairs_%b = [420,421]
+  end
+end submodule
+
+  use input_output_pair_m
+  type(mini_batch_t), allocatable :: res
+  res = default_real_construct()
+  if (any (res%input_output_pairs_%a /= [42,43])) stop 1
+  if (any (res%input_output_pairs_%b /= [420,421])) stop 2
+  if (allocated (res)) deallocate (res)
+end