https://gcc.gnu.org/g:a50d2acc48f45c6bbf256e51440d181794079a0f
commit r13-9209-ga50d2acc48f45c6bbf256e51440d181794079a0f
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Mon Nov 11 09:01:11 2024 +0000
Fortran: Suppress invalid finalization of artificial variable [PR116388]
2024-11-11 Tomas Trnka <tr...@scm.com>
Paul Thomas <pa...@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.
(cherry picked from commit 42a2df0b7985b2a4732ba1c29726ac7aabd5eeae)
Diff:
---
gcc/fortran/class.cc | 5 +-
gcc/testsuite/gfortran.dg/finalize_58.f90 | 77 +++++++++++++++++++++++++++++++
2 files changed, 80 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index bffc0ffff3a3..ddf840761605 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -1084,8 +1084,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 000000000000..54960e6b0305
--- /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 <tr...@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
