public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-12] Fortran: Fix finalization resolution with deep copy
@ 2022-06-29 14:46 Kwok Yeung
0 siblings, 0 replies; only message in thread
From: Kwok Yeung @ 2022-06-29 14:46 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:6d3366dd4764c541401ff6c3d79eac3d85a01143
commit 6d3366dd4764c541401ff6c3d79eac3d85a01143
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Apr 25 15:12:01 2022 +0200
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.cc (gfc_resolve_finalizers): Also resolve allocatable comps.
gcc/testsuite/ChangeLog:
* gfortran.dg/finalize_38.f90: New test.
Diff:
---
gcc/fortran/ChangeLog.omp | 4 +
gcc/fortran/resolve.cc | 11 ++-
gcc/testsuite/ChangeLog.omp | 4 +
gcc/testsuite/gfortran.dg/finalize_38.f90 | 135 ++++++++++++++++++++++++++++++
4 files changed, 151 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 791dba879c0..34fbe861a5d 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,7 @@
+2022-04-25 Tobias Burnus <tobias@codesourcery.com>
+
+ * resolve.cc (gfc_resolve_finalizers): Also resolve allocatable comps.
+
2022-04-20 Andrew Stubbs <ams@codesourcery.com>
* openmp.cc (gfc_match_omp_requires): Check requires unified_address
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 36bc6328a9c..21638e532d6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -13630,11 +13630,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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 8ebaa141543..ccd842bb129 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,7 @@
+2022-04-25 Tobias Burnus <tobias@codesourcery.com>
+
+ * gfortran.dg/finalize_38.f90: New test.
+
2022-04-20 Andrew Stubbs <ams@codesourcery.com>
* c-c++-common/gomp/usm-4.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/finalize_38.f90 b/gcc/testsuite/gfortran.dg/finalize_38.f90
new file mode 100644
index 00000000000..442e1753311
--- /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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-06-29 14:46 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-06-29 14:46 [gcc/devel/omp/gcc-12] Fortran: Fix finalization resolution with deep copy Kwok Yeung
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).