From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1729) id 711973851A8C; Wed, 29 Jun 2022 14:46:36 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 711973851A8C 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 (cont) X-Act-Checkin: gcc X-Git-Author: Tobias Burnus X-Git-Refname: refs/heads/devel/omp/gcc-12 X-Git-Oldrev: 6d3366dd4764c541401ff6c3d79eac3d85a01143 X-Git-Newrev: 319298fb1af1c38008ea96a212e6bf552c7af004 Message-Id: <20220629144636.711973851A8C@sourceware.org> Date: Wed, 29 Jun 2022 14:46:36 +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:36 -0000 https://gcc.gnu.org/g:319298fb1af1c38008ea96a212e6bf552c7af004 commit 319298fb1af1c38008ea96a212e6bf552c7af004 Author: Tobias Burnus Date: Wed Apr 27 19:44:52 2022 +0200 Fortran: Fix finalization resolution with deep copy (cont) gcc/fortran/ChangeLog: * resolve.cc (gfc_resolve_finalizers): Remove gfc_resolve_finalizers calls, use gfc_is_finalizable. (resolve_fl_derived): Resolve derived-type components first. gcc/testsuite/ChangeLog: * gfortran.dg/abstract_type_6.f03: Remove dg-error as now hidden by other errors; copy to ... * gfortran.dg/abstract_type_6a.f03: ... here; remove some error to diagnose the error. * gfortran.dg/finalize_39.f90: New test. Diff: --- gcc/fortran/ChangeLog.omp | 7 ++ gcc/fortran/resolve.cc | 29 ++++--- gcc/testsuite/ChangeLog.omp | 8 ++ gcc/testsuite/gfortran.dg/abstract_type_6.f03 | 3 +- gcc/testsuite/gfortran.dg/abstract_type_6a.f03 | 46 ++++++++++ gcc/testsuite/gfortran.dg/finalize_39.f90 | 112 +++++++++++++++++++++++++ 6 files changed, 192 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index 34fbe861a5d..0a735989f0c 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,10 @@ +2022-04-27 Tobias Burnus + + * resolve.cc (gfc_resolve_finalizers): Remove + gfc_resolve_finalizers calls, use gfc_is_finalizable. + (resolve_fl_derived): Resolve derived-type components + first. + 2022-04-25 Tobias Burnus * resolve.cc (gfc_resolve_finalizers): Also resolve allocatable comps. diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 21638e532d6..d18c051ffc9 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -13634,18 +13634,10 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) 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 - || (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)) - return false; /* Error. */ - has_final = has_final || has_final2; - } + if (c->ts.type == BT_DERIVED + && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) + has_final |= gfc_is_finalizable (c->ts.u.derived, NULL); + /* Return early if not finalizable. */ if (!has_final) { @@ -15159,6 +15151,19 @@ resolve_fl_derived (gfc_symbol *sym) return false; } + gfc_component *c = (sym->attr.is_class + ? CLASS_DATA (sym->components) : sym->components); + for ( ; c; c = c->next) + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !c->ts.u.derived->resolve_symbol_called) + { + if (c->ts.u.derived->components == NULL + && !c->ts.u.derived->attr.zero_comp + && !c->ts.u.derived->attr.use_assoc) + continue; + resolve_symbol (c->ts.u.derived); + } + /* Resolve the finalizer procedures. */ if (!gfc_resolve_finalizers (sym, NULL)) return false; diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp index ccd842bb129..bc57cf741f5 100644 --- a/gcc/testsuite/ChangeLog.omp +++ b/gcc/testsuite/ChangeLog.omp @@ -1,3 +1,11 @@ +2022-04-27 Tobias Burnus + + * gfortran.dg/abstract_type_6.f03: Remove dg-error as + now hidden by other errors; copy to ... + * gfortran.dg/abstract_type_6a.f03: ... here; remove + some error to diagnose the error. + * gfortran.dg/finalize_39.f90: New test. + 2022-04-25 Tobias Burnus * gfortran.dg/finalize_38.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 index ebef02ed82a..98b70a83d43 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 @@ -31,7 +31,8 @@ TYPE, EXTENDS(middle) :: bottom CONTAINS ! useful proc to satisfy deferred procedure in top. Because we've ! extended middle we wouldn't get told off if we forgot this. - PROCEDURE :: proc_a => bottom_a ! { dg-error "must be a module procedure" } + PROCEDURE :: proc_a => bottom_a ! Invalid, but not diagnosted due to other errors + ! -> abstract_type_6a.f03 ! calls middle%proc_b and then provides extra behavior PROCEDURE :: proc_b => bottom_b ! calls top_c and then provides extra behavior diff --git a/gcc/testsuite/gfortran.dg/abstract_type_6a.f03 b/gcc/testsuite/gfortran.dg/abstract_type_6a.f03 new file mode 100644 index 00000000000..b05e22d77e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/abstract_type_6a.f03 @@ -0,0 +1,46 @@ +! { dg-do compile } +! Test the fix for PR43266, in which an ICE followed correct error messages. +! +! Split off from abstract_type_6.f03 as this dg-error wasn't diagosed due to +! diagnosing the other issues first. +! +! Contributed by Tobias Burnus +! Reported in http://groups.google.ca/group/comp.lang.fortran/browse_thread/thread/f5ec99089ea72b79 +! +!---------------- +! library code + +module m +TYPE, ABSTRACT :: top +CONTAINS +END TYPE top + +! Concrete middle class with useful behavior +TYPE, EXTENDS(top) :: middle +CONTAINS +END TYPE middle + +!---------------- +! client code + +TYPE, EXTENDS(middle) :: bottom +CONTAINS + ! useful proc to satisfy deferred procedure in top. Because we've + ! extended middle we wouldn't get told off if we forgot this. + PROCEDURE :: proc_a => bottom_a ! { dg-error "must be a module procedure" } + ! calls middle%proc_b and then provides extra behavior + PROCEDURE :: proc_b => bottom_b + ! calls top_c and then provides extra behavior + PROCEDURE :: proc_c => bottom_c +END TYPE bottom +contains +SUBROUTINE bottom_b(obj) + CLASS(Bottom) :: obj + ! other stuff +END SUBROUTINE bottom_b + +SUBROUTINE bottom_c(obj) + CLASS(Bottom) :: obj + ! other stuff +END SUBROUTINE bottom_c +end module diff --git a/gcc/testsuite/gfortran.dg/finalize_39.f90 b/gcc/testsuite/gfortran.dg/finalize_39.f90 new file mode 100644 index 00000000000..f6c90b18d99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_39.f90 @@ -0,0 +1,112 @@ +module m + implicit none + private + + type, public :: MyForm + integer :: nValues = 0, nValuesUnpacked = 0, nVariables = 0 + integer, dimension ( : ), allocatable :: iaUnpacked + real, dimension ( :, : ), allocatable :: Value + contains + procedure, private, pass :: InitializeEmpty + procedure, private, pass :: InitializeCopy + generic :: Initialize => InitializeEmpty, InitializeCopy + final :: Finalize + end type MyForm + + type, public :: MyElementForm + class ( MyForm ), allocatable :: Element + contains + final :: FinalizeElement + end type MyElementForm + +contains + + subroutine InitializeEmpty ( PS, iaUnpacked, nValuesUnpacked, nVariables, ClearOption ) + class ( MyForm ), intent ( inout ) :: PS + integer, dimension ( : ), intent ( in ) :: iaUnpacked + integer, intent ( in ) :: nValuesUnpacked, nVariables + logical, intent ( in ), optional :: ClearOption + + logical :: ClearRequested + + ClearRequested = .false. + if ( present ( ClearOption ) ) & + ClearRequested = ClearOption + + PS % nVariables = nVariables + PS % nValues = size ( iaUnpacked ) + PS % nValuesUnpacked = nValuesUnpacked + + allocate ( PS % iaUnpacked ( PS % nValues ) ) + allocate ( PS % Value ( PS % nValues, PS % nVariables ) ) + if ( ClearRequested ) & + call Clear ( PS % Value ) + end subroutine InitializeEmpty + + subroutine InitializeCopy ( PS, PS_Source ) + class ( MyForm ), intent ( inout ) :: PS + class ( MyForm ), intent ( in ) :: PS_Source + + PS % nVariables = PS_Source % nVariables + PS % nValues = PS_Source % nValues + PS % nValuesUnpacked = PS_Source % nValuesUnpacked + + allocate ( PS % iaUnpacked ( PS % nValues ) ) + allocate ( PS % Value ( PS % nValues, PS % nVariables ) ) + end subroutine InitializeCopy + + elemental subroutine Finalize ( PS ) + type ( MyForm ), intent ( inout ) :: PS + + if ( allocated ( PS % Value ) ) & + deallocate ( PS % Value ) + if ( allocated ( PS % iaUnpacked ) ) & + deallocate ( PS % iaUnpacked ) + end subroutine Finalize + + subroutine LoadVariable ( PackedValue, UnpackedValue, iaUnpacked, nValues ) + real, dimension ( : ), intent ( inout ) :: PackedValue + real, dimension ( : ), intent ( in ) :: UnpackedValue + integer, dimension ( : ), intent ( in ) :: iaUnpacked + integer, intent ( in ) :: nValues + + integer :: iV + + do iV = 1, nValues + PackedValue ( iV ) = UnpackedValue ( iaUnpacked ( iV ) ) + end do + end subroutine LoadVariable + + subroutine AddVariable ( PackedValue, UnpackedValue, iaUnpacked, nValues ) + real, dimension ( : ), intent ( inout ) :: PackedValue + real, dimension ( : ), intent ( in ) :: UnpackedValue + integer, dimension ( : ), intent ( in ) :: iaUnpacked + integer, intent ( in ) :: nValues + + integer :: iV + + do iV = 1, nValues + PackedValue ( iV ) = PackedValue ( iV ) + UnpackedValue ( iaUnpacked ( iV ) ) + end do + end subroutine AddVariable + + subroutine StoreVariable ( UnpackedValue, PackedValue, iaUnpacked, nValues ) + real, dimension ( : ), intent ( inout ) :: UnpackedValue + real, dimension ( : ), intent ( in ) :: PackedValue + integer, dimension ( : ), intent ( in ) :: iaUnpacked + integer, intent ( in ) :: nValues + + integer :: iV + + do iV = 1, nValues + UnpackedValue ( iaUnpacked ( iV ) ) = PackedValue ( iV ) + end do + end subroutine StoreVariable + + + impure elemental subroutine FinalizeElement ( PSE ) + type ( MyElementForm ), intent ( inout ) :: PSE + if ( allocated ( PSE % Element ) ) & + deallocate ( PSE % Element ) + end subroutine FinalizeElement +end module m