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)
{
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;
--- /dev/null
+! { 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 <burnus@gcc.gnu.org>
+! 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
--- /dev/null
+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
projects / thirdparty / gcc.git / commitdiff
