This patch ensures that the finalization expression is generated and
that use-associated finalizers are properly accessed.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
2014-04-04 Tobias Burnus <bur...@net-b.de>
PR fortran/58880
PR fortran/60495
* resolve.c (gfc_resolve_finalizers): Ensure that vtables
and finalization wrappers are generated.
* trans.c (gfc_build_final_call): Ensure that use_assoc
is set for the finalization wrapper when applicable.
2014-04-04 Tobias Burnus <bur...@net-b.de>
PR fortran/58880
PR fortran/60495
* gfortran.dg/finalize_25.f90: New.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6e23e57..38755fe 100644
--- 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/fortran/trans.c b/gcc/fortran/trans.c
index 5961c26..9ea859e 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -869,6 +869,9 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
+ if (final_wrapper->symtree->n.sym->module)
+ final_wrapper->symtree->n.sym->attr.use_assoc = 1;
+
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
diff --git a/gcc/testsuite/gfortran.dg/finalize_25.f90 b/gcc/testsuite/gfortran.dg/finalize_25.f90
new file mode 100644
index 0000000..73dc568
--- /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
