re PR fortran/58880 ([OOP] ICE on valid with FINAL function and type extension)

2014-04-11  Tobias Burnus  <burnus@net-b.de>

        PR fortran/58880
        PR fortran/60495
        * resolve.c (gfc_resolve_finalizers): Ensure that vtables
        and finalization wrappers are generated.

2014-04-11  Tobias Burnus  <burnus@net-b.de>

        PR fortran/58880
        PR fortran/60495
        * gfortran.dg/finalize_25.f90: New.

From-SVN: r209327

gcc/fortran/ChangeLog

+2014-04-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58880
+	PR fortran/60495
+	* resolve.c (gfc_resolve_finalizers): Ensure that vtables
+	and finalization wrappers are generated.
+
 2014-04-11  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* intrinsic.texi (RANDOM_SEED): Improve example.

gcc/fortran/resolve.c

@@ -11200,15 +11200,36 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
    the requirements of the standard for procedures used as finalizers.  */
 
 static bool
-gfc_resolve_finalizers (gfc_symbol* derived)
+gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
 {
   gfc_finalizer* list;
   gfc_finalizer** prev_link; /* For removing wrong entries from the list.  */
   bool result = true;
   bool seen_scalar = false;
+  gfc_symbol *vtab;
+  gfc_component *c;
 
+  /* Return early when not finalizable. Additionally, ensure that derived-type
+     components have a their finalizables resolved.  */
   if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+    {
+      bool has_final = false;
+      for (c = derived->components; c; c = c->next)
+	if (c->ts.type == BT_DERIVED
+	    && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
+	  {
+	    bool has_final2 = false;
+	    if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final))
+	      return false;  /* Error.  */
+	    has_final = has_final || has_final2;
+	  }
+      if (!has_final)
+	{
+	  if (finalizable)
+	    *finalizable = false;
 	  return true;
+	}
+    }
 
   /* Walk over the list of finalizer-procedures, check them, and if any one
      does not fit in with the standard's definition, print an error and remove
@@ -11330,12 +11351,15 @@ gfc_resolve_finalizers (gfc_symbol* derived)
 	/* Remove wrong nodes immediately from the list so we don't risk any
 	   troubles in the future when they might fail later expectations.  */
 error:
-	result = false;
 	i = list;
 	*prev_link = list->next;
 	gfc_free_finalizer (i);
+	result = false;
     }
 
+  if (result == false)
+    return false;
+
   /* Warn if we haven't seen a scalar finalizer procedure (but we know there
      were nodes in the list, must have been for arrays.  It is surely a good
      idea to have a scalar version there if there's something to finalize.  */
@@ -11344,8 +11368,14 @@ error:
 		 " defined at %L, suggest also scalar one",
 		 derived->name, &derived->declared_at);
 
-  gfc_find_derived_vtab (derived);
-  return result;
+  vtab = gfc_find_derived_vtab (derived);
+  c = vtab->ts.u.derived->components->next->next->next->next->next;
+  gfc_set_sym_referenced (c->initializer->symtree->n.sym);
+
+  if (finalizable)
+    *finalizable = true;
+
+  return true;
 }
 
 
@@ -12513,7 +12543,7 @@ resolve_fl_derived (gfc_symbol *sym)
     return false;
 
   /* Resolve the finalizer procedures.  */
-  if (!gfc_resolve_finalizers (sym))
+  if (!gfc_resolve_finalizers (sym, NULL))
     return false;
 
   if (sym->attr.is_class && sym->ts.u.derived == NULL)

gcc/testsuite/ChangeLog

+2014-04-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/58880
+	PR fortran/60495
+	* gfortran.dg/finalize_25.f90: New.
+
 2014-04-11  Joern Rennecke  <joern.rennecke@embecosm.com>
 
 	* gcc.target/epiphany/t1068-2.c: New file.

gcc/testsuite/gfortran.dg/finalize_25.f90

+! { dg-do run }
+!
+! PR fortran/58880
+! PR fortran/60495
+!
+! Contributed by Andrew Benson and Janus Weil
+!
+
+module gn
+  implicit none
+  type sl
+     integer, allocatable, dimension(:) :: lv
+   contains
+     final :: sld
+  end type
+  type :: nde
+     type(sl) :: r
+  end type nde
+
+  integer :: cnt = 0
+
+contains
+
+  subroutine sld(s)
+    type(sl) :: s
+    cnt = cnt + 1
+    ! print *,'Finalize sl'
+  end subroutine
+  subroutine ndm(s)
+    type(nde), intent(inout) :: s
+    type(nde)                :: i
+    i=s
+  end subroutine ndm
+end module
+
+program main
+  use gn
+  type :: nde2
+     type(sl) :: r
+  end type nde2
+  type(nde) :: x
+
+  cnt = 0
+  call ndm(x)
+  if (cnt /= 2) call abort()
+
+  cnt = 0
+  call ndm2()
+  if (cnt /= 3) call abort()
+contains
+  subroutine ndm2
+    type(nde2) :: s,i
+    i=s
+  end subroutine ndm2
+end program main