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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 572a7ff5249c9776d11960dc262316ccf2068fe9..c14e209752c1e902418412f2aae427fb7d9bebb1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+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.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6e23e570b179da2e2db8cbf8b1ab82fafe4701c8..38755fef6a27ee1db5fec00f8c4f20e6794dbaf6 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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)
-    return true;
+    {
+      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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9e895272f3481129f6c67cf1a46b8ab732828807..ad54ae8cebd30bbeada8e89e8ecb5cdf4622c27b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/finalize_25.f90 b/gcc/testsuite/gfortran.dg/finalize_25.f90
new file mode 100644 (file)
index 0000000..cdbec4c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_25.f90
@@ -0,0 +1,55 @@
+! { 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