Fortran: Suppress invalid finalization of artificial variable [PR116388]

2024-11-11  Tomas Trnka  <trnka@scm.com>
	    Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/116388
	* class.cc (finalize_component): Leading underscore in the name
	of 'byte_stride' to suppress invalid finalization.

gcc/testsuite/
	PR fortran/116388
	* gfortran.dg/finalize_58.f90: New test.

2 files changed, 80 insertions, 2 deletions

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 4b2234a..fc709fe 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -1152,8 +1152,9 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 
       gcc_assert (c);
 
-      /* Set scalar argument for storage_size.  */
-      gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+      /* Set scalar argument for storage_size. A leading underscore in
+	 the name prevents an unwanted finalization.  */
+      gfc_get_symbol ("_comp_byte_stride", sub_ns, &byte_stride);
       byte_stride->ts = e->ts;
       byte_stride->attr.flavor = FL_VARIABLE;
       byte_stride->attr.value = 1;
diff --git a/gcc/testsuite/gfortran.dg/finalize_58.f90 b/gcc/testsuite/gfortran.dg/finalize_58.f90
new file mode 100644
index 0000000..54960e6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_58.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! Test fix for PR116388 in which an artificial variable in the finalization
+! wrapper was generating an invalid finalization.
+!
+! Contributed by Tomas Trnka  <trnka@scm.com>
+!
+module FinalizerTestModule
+
+   use, intrinsic :: ISO_C_BINDING
+
+   implicit none
+
+   type, public :: AType
+      type(C_ptr) :: cptr = C_null_ptr
+      logical     :: cptr_invalid = .true.
+      integer, allocatable :: x(:)
+   contains
+      final              :: FinalizerA
+   end type
+
+   type, public :: BType
+      type(C_ptr) :: cptr = C_null_ptr
+      type(AType) :: a
+   contains
+      procedure, public  :: New => NewB
+      final              :: FinalizerB
+   end type
+
+   type, public :: CType
+      type(BType) :: b
+   contains
+      procedure, public :: New => NewC
+   end type
+
+   integer :: final_A = 0
+   integer :: final_B = 0
+contains
+
+   impure elemental subroutine FinalizerA(self)
+      type(AType), intent(inout) :: self
+      final_A = final_A + 1
+      if (.not. self%cptr_invalid) stop 1
+   end subroutine
+
+   subroutine NewB(self)
+      class(BType),     intent(out)           :: self
+
+   end subroutine
+
+   impure elemental subroutine FinalizerB(self)
+      type(BType), intent(inout) :: self
+      final_B = final_B + 1
+      if (transfer (self%cptr, C_LONG_LONG) /= 0) stop 2
+   end subroutine
+
+   subroutine NewC(self, b)
+      class(CType),  intent(out) :: self
+      type(BType),   intent(in)  :: b
+
+      self%b = b
+   end subroutine
+
+end module
+
+program finalizing_uninitialized
+   use FinalizerTestModule
+   implicit none
+
+   type(BType) :: b
+   type(CType) :: c
+
+   call b%New()
+   call c%New(b)
+   if (final_A /= 3) stop 3
+   if (final_B /= 3) stop 4
+end program