Fortran: Fix ICE in pdt_1[3-5].f03 with -fcheck=all [PR102901]

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

gcc/fortran
	PR fortran/102901
	* trans-array.cc (structure_alloc_comps): Do not use
	gfc_check_pdt_dummy with pointer or allocatable components.

gcc/testsuite/
	PR fortran/102901
	* gfortran.dg/pdt_56.f03: Copy of pdt_13.f03 compiled with
	-fcheck=all.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index db34de44401b0e1636d7eb5b1da83aa28b05b892..9dd61f98ca7671d28c28721cd7cefeb79a4f3610 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11180,7 +11180,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
            comp = gfc_class_data_get (comp);
 
          /* Recurse in to PDT components.  */
-         if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+         if (((c->ts.type == BT_DERIVED
+               && !c->attr.allocatable && !c->attr.pointer)
+              || (c->ts.type == BT_CLASS
+                  && !CLASS_DATA (c)->attr.allocatable
+                  && !CLASS_DATA (c)->attr.pointer))
              && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
            {
              tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,

diff --git a/gcc/testsuite/gfortran.dg/pdt_56.f03 b/gcc/testsuite/gfortran.dg/pdt_56.f03
new file mode 100644 (file)
index 0000000..681d479
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_56.f03
@@ -0,0 +1,96 @@
+! { dg-do compile }
+! { dg-options "-fcheck=all" }
+!
+! Test the fix for PR102901, where pdt_13/14/15.f03 segfaulted in compilation
+! with -fcheck=all.
+!
+! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+! This is pdt_13.f03.
+!
+module precision_module
+  implicit none
+  integer, parameter :: sp = selected_real_kind(6, 37)
+  integer, parameter :: dp = selected_real_kind(15, 307)
+  integer, parameter :: qp = selected_real_kind( 30, 291)
+end module precision_module
+
+module link_module
+  use precision_module
+
+  type link(real_kind)
+    integer, kind :: real_kind
+    real (kind=real_kind) :: n
+    type (link(real_kind)), pointer :: next => NULL()
+  end type link
+
+contains
+
+  function push_8 (self, arg) result(current)
+    real(dp) :: arg
+    type (link(real_kind=dp)), pointer :: self
+    type (link(real_kind=dp)), pointer :: current
+
+    if (associated (self)) then
+      current => self
+      do while (associated (current%next))
+        current => current%next
+      end do
+
+      allocate (current%next)
+      current => current%next
+    else
+      allocate (current)
+      self => current
+    end if
+
+    current%n = arg
+    current%next => NULL ()
+  end function push_8
+
+  function pop_8 (self) result(res)
+    type (link(real_kind=dp)), pointer :: self
+    type (link(real_kind=dp)), pointer :: current => NULL()
+    type (link(real_kind=dp)), pointer :: previous => NULL()
+    real(dp) :: res
+
+    res = 0.0_8
+    if (associated (self)) then
+      current => self
+      do while (associated (current) .and. associated (current%next))
+         previous => current
+         current => current%next
+      end do
+
+      previous%next => NULL ()
+
+      res = current%n
+      if (associated (self, current)) then
+        deallocate (self)
+      else
+        deallocate (current)
+      end if
+
+    end if
+  end function pop_8
+
+end module link_module
+
+program ch2701
+  use precision_module
+  use link_module
+  implicit none
+  integer, parameter :: wp = dp
+  type (link(real_kind=wp)), pointer :: root => NULL()
+  type (link(real_kind=wp)), pointer :: current
+
+  current => push_8 (root, 1.0_8)
+  current => push_8 (root, 2.0_8)
+  current => push_8 (root, 3.0_8)
+
+  if (int (pop_8 (root)) .ne. 3) STOP 1
+  if (int (pop_8 (root)) .ne. 2) STOP 2
+  if (int (pop_8 (root)) .ne. 1) STOP 3
+  if (int (pop_8 (root)) .ne. 0) STOP 4
+
+end program ch2701