From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1729) id 6069B384D18C; Wed, 29 Jun 2022 14:46:31 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 6069B384D18C Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Kwok Yeung To: gcc-cvs@gcc.gnu.org Subject: [gcc/devel/omp/gcc-12] Fortran: Fix finalization resolution with deep copy X-Act-Checkin: gcc X-Git-Author: Tobias Burnus X-Git-Refname: refs/heads/devel/omp/gcc-12 X-Git-Oldrev: f0ac4511d300eefd776314d2958bd72a6b5ae9e9 X-Git-Newrev: 6d3366dd4764c541401ff6c3d79eac3d85a01143 Message-Id: <20220629144631.6069B384D18C@sourceware.org> Date: Wed, 29 Jun 2022 14:46:31 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 29 Jun 2022 14:46:31 -0000 https://gcc.gnu.org/g:6d3366dd4764c541401ff6c3d79eac3d85a01143 commit 6d3366dd4764c541401ff6c3d79eac3d85a01143 Author: Tobias Burnus 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 + + * resolve.cc (gfc_resolve_finalizers): Also resolve allocatable comps. + 2022-04-20 Andrew Stubbs * 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 + + * gfortran.dg/finalize_38.f90: New test. + 2022-04-20 Andrew Stubbs * 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