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.

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 <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
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