[gcc r14-11522] Fortran: Fix freeing procedure pointer components [PR119380]

[Andre Vehreschild via Gcc-cvs]

https://gcc.gnu.org/g:f955c5b409a96bd12765680517ce583d7086c62d

commit r14-11522-gf955c5b409a96bd12765680517ce583d7086c62d
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date:   Fri Mar 21 09:13:29 2025 +0100

    Fortran: Fix freeing procedure pointer components [PR119380]
    
    Backported from gcc-15.
    
            PR fortran/119380
    
    gcc/fortran/ChangeLog:
    
            * trans-array.cc (structure_alloc_comps): Prevent freeing of
            procedure pointer components.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/proc_ptr_comp_54.f90: New test.

Diff:
---
 gcc/fortran/trans-array.cc                     |  4 ++--
 gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90 | 30 ++++++++++++++++++++++++++
 2 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c1c2b933b279..50286e4120e6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9694,13 +9694,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree 
decl, tree dest,
          if (c->ts.type == BT_CLASS)
            {
              attr = &CLASS_DATA (c)->attr;
-             if (attr->class_pointer)
+             if (attr->class_pointer || c->attr.proc_pointer)
                continue;
            }
          else
            {
              attr = &c->attr;
-             if (attr->pointer)
+             if (attr->pointer || attr->proc_pointer)
                continue;
            }
 
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90 
b/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90
new file mode 100644
index 000000000000..73abc590e9ef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90
@@ -0,0 +1,30 @@
+!{ dg-do run }
+
+! Check that components of procedure pointer aren't freeed.
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+
+  implicit none
+
+  type foo_t
+    integer, allocatable :: i_
+    procedure(f), pointer, nopass :: f_
+    procedure(c), pointer, nopass :: c_
+  end type
+
+  class(foo_t), allocatable :: ff
+
+  associate(foo => foo_t(1,f))
+  end associate
+
+contains
+
+  function f()
+    logical, allocatable :: f
+    f = .true.
+  end function
+
+  function c()
+    class(foo_t), allocatable :: c
+    allocate(c)
+  end function
+end