Fortran: Fix an excess finalization during allocation [PR104272]

2023-04-14  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/104272
	* gfortran.h : Add expr3_not_explicit bit field to gfc_code.
	* resolve.cc (resolve_allocate_expr): Set bit field when the
	default initializer is applied to expr3.
	* trans-stmt.cc (gfc_trans_allocate): If expr3_not_explicit is
	set, do not deallocate expr3.

gcc/testsuite/
	PR fortran/104272
	* gfortran.dg/class_result_8.f90 : Number of builtin_frees down
	from 6 to 5 without memory leaks.
	* gfortran.dg/finalize_52.f90: New test

5 files changed, 68 insertions, 3 deletions

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 130d5d7..db77d24 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3005,6 +3005,8 @@ typedef struct gfc_code
       /* Take the array specification from expr3 to allocate arrays
 	 without an explicit array specification.  */
       unsigned arr_spec_from_expr3:1;
+      /* expr3 is not explicit  */
+      unsigned expr3_not_explicit:1;
     }
     alloc;
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 58013d4..55d8e32 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8089,6 +8089,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
   if (!t)
     goto failure;
 
+  code->ext.alloc.expr3_not_explicit = 0;
   if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
 	&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
     {
@@ -8097,6 +8098,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 	 when the allocated type is different from the declared type but
 	 no SOURCE exists by setting expr3.  */
       code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+      code->ext.alloc.expr3_not_explicit = 1;
     }
   else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
 	   && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
@@ -8104,6 +8106,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
     {
       /* We have to zero initialize the integer variable.  */
       code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
+      code->ext.alloc.expr3_not_explicit = 1;
     }
 
   if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f788754..776f98d 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6458,12 +6458,15 @@ gfc_trans_allocate (gfc_code * code)
       /* Deallocate any allocatable components in expressions that use a
 	 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
 	 E.g. temporaries of a function call need freeing of their components
-	 here.  */
+	 here. Explicit derived type allocation of class entities uses expr3
+	 to carry the default initializer. This must not be deallocated or
+	 finalized.  */
       if ((code->expr3->ts.type == BT_DERIVED
 	   || code->expr3->ts.type == BT_CLASS)
 	  && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
 	  && code->expr3->ts.u.derived->attr.alloc_comp
-	  && !code->expr3->must_finalize)
+	  && !code->expr3->must_finalize
+	  && !code->ext.alloc.expr3_not_explicit)
 	{
 	  tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
 					   expr3, code->expr3->rank);
diff --git a/gcc/testsuite/gfortran.dg/class_result_8.f90 b/gcc/testsuite/gfortran.dg/class_result_8.f90
index 573dd44..9a1fb2b 100644
--- a/gcc/testsuite/gfortran.dg/class_result_8.f90
+++ b/gcc/testsuite/gfortran.dg/class_result_8.f90
@@ -37,5 +37,5 @@ program polymorphic_operators_memory_leaks
    call assign_a_type (a, add_a_type(a,b))
    print *, a%x
 end
-! { dg-final { scan-tree-dump-times "builtin_free" 6 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 5 "original" } }
 ! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/finalize_52.f90 b/gcc/testsuite/gfortran.dg/finalize_52.f90
new file mode 100644
index 0000000..be2ca17
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_52.f90
@@ -0,0 +1,57 @@
+! { dg-do run }
+!
+! Test the fix for PR104272 in which allocate caused an unwanted finalization
+!
+! Contributed by Kai Germaschewski  <kai.germaschewski@gmail.com>
+!
+module solver_m
+    implicit none
+
+    type, abstract, public :: solver_base_t
+    end type solver_base_t
+
+    type, public, extends(solver_base_t) :: solver_gpu_t
+       complex, dimension(:), allocatable :: x
+    contains
+       final :: solver_gpu_final
+    end type solver_gpu_t
+
+    type, public, extends(solver_gpu_t) :: solver_sparse_gpu_t
+    contains
+       final :: solver_sparse_gpu_final
+    end type solver_sparse_gpu_t
+
+    integer :: final_counts = 0
+
+ contains
+
+    impure elemental subroutine solver_gpu_final(this)
+       type(solver_gpu_t), intent(INOUT) :: this
+       final_counts = final_counts + 1
+    end subroutine solver_gpu_final
+
+    impure elemental subroutine solver_sparse_gpu_final(this)
+       type(solver_sparse_gpu_t), intent(INOUT) :: this
+       final_counts = final_counts + 10
+    end subroutine solver_sparse_gpu_final
+
+ end module solver_m
+
+ subroutine test
+    use solver_m
+    implicit none
+
+    class(solver_base_t), dimension(:), allocatable :: solver
+
+    allocate(solver_sparse_gpu_t :: solver(2))
+
+    if (final_counts .ne. 0) stop 1
+ end subroutine
+
+program main
+    use solver_m
+    implicit none
+
+    call test
+    if (final_counts .ne. 22) stop 2 ! Scalar finalizers for rank 1/size 2
+end program