Fortran: Fix finalization resolution with deep copy

Follow-up patch to
"Fortran/OpenMP: Support mapping of DT with allocatable components"
https://gcc.gnu.org/pipermail/gcc-patches/2022-March/591144.html

gcc/fortran/ChangeLog:

        * resolve.c (gfc_resolve_finalizers): Also resolve allocatable comps.

gcc/testsuite/ChangeLog:

        * gfortran.dg/finalize_38.f90: New test.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 59faa4c119d84e92d945080951e33366221b6f52..10c89de0eaa958581e87f13a8bef8aa0f2d583bf 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -13578,11 +13578,16 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
   if (parent)
     gfc_resolve_finalizers (parent, finalizable);
 
-  /* Ensure that derived-type components have a their finalizers resolved.  */
+  /* Ensure that derived-type components have a their finalizers resolved;
+     handle allocatables but avoid issues with (in)direct allocatable types. */
   bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
   for (c = derived->components; c; c = c->next)
-    if (c->ts.type == BT_DERIVED
-       && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.proc_pointer
+       && (!c->attr.allocatable
+           || (c->ts.u.derived != derived
+               && c->ts.u.derived->f2k_derived
+               && c->ts.u.derived->f2k_derived->finalizers
+               && !c->ts.u.derived->f2k_derived->finalizers->proc_tree)))
       {
        bool has_final2 = false;
        if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))

diff --git a/gcc/testsuite/gfortran.dg/finalize_38.f90 b/gcc/testsuite/gfortran.dg/finalize_38.f90
new file mode 100644 (file)
index 0000000..442e175
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_38.f90
@@ -0,0 +1,135 @@
+! { dg-do compile }
+!
+! Check finalization
+!
+module Real_2D__Form
+
+  implicit none
+  private
+  
+  integer, parameter :: &
+    KDR = kind ( 1.0d0 ), &
+    KDI = kind ( 1 ), &
+    KDL = kind ( .true. )
+
+  type, public :: Real_2D_Form
+    real ( KDR ), dimension ( :, : ), allocatable :: &
+      Value
+  contains
+    procedure, private, pass :: &
+      Initialize_R_2D
+    procedure, private, pass :: &
+      Initialize_R_2D_FromValue
+    procedure, private, pass :: &
+      Initialize_R_2D_Copy
+    generic :: &
+      Initialize &
+        => Initialize_R_2D, Initialize_R_2D_FromValue, Initialize_R_2D_Copy
+    final :: &
+      Finalize_R_2D
+  end type Real_2D_Form
+  
+  type, public :: Real_2D_2D_Form
+    type ( Real_2D_Form ), dimension ( :, : ), allocatable :: &
+      Value
+  contains
+    final :: &
+      Finalize_R_2D_2D
+  end type Real_2D_2D_Form
+
+contains
+
+  subroutine Initialize_R_2D ( A, nValues, ClearOption, iaLowerBoundOption )
+    class ( Real_2D_Form ), intent ( inout ) :: &
+      A
+    integer ( KDI ), dimension ( 2 ), intent ( in ) :: &
+      nValues
+    logical ( KDL ), intent ( in ), optional :: &
+      ClearOption
+    integer ( KDI ), dimension ( 2 ), intent ( in ), optional :: &
+      iaLowerBoundOption
+
+    integer ( KDI ), dimension ( 2 ) :: &
+      iaLB
+    logical ( KDL ) :: &
+      ClearRequested
+
+    if ( any ( nValues < 0 ) ) return
+    
+    if ( all ( nValues == 0 ) ) then
+      allocate ( A % Value ( 0, 0 ) )
+      return
+    end if 
+    
+    ClearRequested = .false.
+    if ( present ( ClearOption ) ) ClearRequested = ClearOption
+
+    iaLB = 1
+    if ( present ( iaLowerBoundOption ) ) iaLB = iaLowerBoundOption
+    
+    allocate &
+      ( A % Value &
+          ( iaLB ( 1 ) : iaLB ( 1 ) + nValues ( 1 ) - 1, &
+            iaLB ( 2 ) : iaLB ( 2 ) + nValues ( 2 ) - 1 ) )
+    
+    !if ( ClearRequested ) call Clear ( A % Value )
+
+  end subroutine Initialize_R_2D
+  
+  
+  subroutine Initialize_R_2D_FromValue ( A, Value, iaLowerBoundOption )
+    
+    class ( Real_2D_Form ), intent ( inout ) :: &
+      A
+    real ( KDR ), dimension ( :, : ), intent ( in ) :: &
+      Value
+    integer ( KDI ), dimension ( 2 ), intent ( in ), optional :: &
+      iaLowerBoundOption
+
+    call A % Initialize_R_2D &
+           ( shape ( Value ), iaLowerBoundOption = iaLowerBoundOption )
+    A % Value = Value 
+
+  end subroutine Initialize_R_2D_FromValue
+  
+  
+  subroutine Initialize_R_2D_Copy ( A, B, iaLowerBoundOption )
+    
+    class ( Real_2D_Form ), intent ( inout ) :: &
+      A
+    type (  Real_2D_Form ), intent ( in ) :: &
+      B
+    integer ( KDI ), intent ( in ), optional :: &
+      iaLowerBoundOption
+      
+    integer ( KDI ), dimension ( 2 ) :: &
+      iaLB
+    
+    iaLB = lbound ( B % Value ) 
+    if ( present ( iaLowerBoundOption ) ) iaLB = iaLowerBoundOption
+
+    call A % Initialize_R_2D_FromValue ( B % Value, iaLowerBoundOption = iaLB )
+  
+  end subroutine Initialize_R_2D_Copy 
+  
+ 
+  elemental subroutine Finalize_R_2D ( A )
+
+    type ( Real_2D_Form ), intent ( inout ) :: &
+      A
+
+    if ( allocated ( A % Value ) ) deallocate ( A % Value )
+
+  end subroutine Finalize_R_2D
+  
+  
+  elemental subroutine Finalize_R_2D_2D ( A )
+
+    type ( Real_2D_2D_Form ), intent ( inout ) :: &
+      A
+
+    if ( allocated ( A % Value ) ) deallocate ( A % Value )
+
+  end subroutine Finalize_R_2D_2D
+
+end module Real_2D__Form