commit 492ea356ce4b9e40c417b3740cc298d6cc78e870 Author: Tobias Burnus Date: Wed Apr 27 19:44:52 2022 +0200 Fortran: Fix finalization resolution with deep copy (cont) gcc/fortran/ChangeLog: * resolve.c (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. --- gcc/fortran/resolve.c | 29 ++++--- 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 +++++++++++++++++++++++++ 4 files changed, 177 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 10c89de0eaa..84a538ee5bc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13582,18 +13582,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) { @@ -15107,6 +15099,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/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