2012-12-03 Tobias Burnus <burnus@net-b.de>
Janus Weil <janus@gcc.gnu.org>
PR fortran/37336
* class.c (gfc_is_finalizable): New function.
* gfortran.h (gfc_is_finalizable): Its prototype.
* module.c (mio_component): Read initializer for vtype's _final.
* resolve.c (resolve_fl_derived0): Call gfc_is_finalizable.
* trans-expr.c (gfc_vtable_final_get): New function.
(conv_parent_component_references): Fix comment.
(gfc_conv_variable): Fix for scalar coarray components.
* trans-intrinsic.c (conv_intrinsic_move_alloc): For BT_CLASS,
pass the BT_CLASS type and not the declared type to
gfc_deallocate_scalar_with_status.
* trans.h (gfc_vtable_final_get): New prototype.
@@ -2013,6 +2013,48 @@ cleanup:
}
+/* Check if a derived type is finalizable. That is the case if it
+ (1) has a FINAL subroutine or
+ (2) has a nonpointer nonallocatable component of finalizable type.
+ If it is finalizable, return an expression containing the
+ finalization wrapper. */
+
+bool
+gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
+{
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ /* (1) Check for FINAL subroutines. */
+ if (derived->f2k_derived && derived->f2k_derived->finalizers)
+ goto yes;
+
+ /* (2) Check for components of finalizable type. */
+ for (c = derived->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED
+ && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+ && gfc_is_finalizable (c->ts.u.derived, NULL))
+ goto yes;
+
+ return false;
+
+yes:
+ /* Make sure vtab is generated. */
+ vtab = gfc_find_derived_vtab (derived);
+ if (final_expr)
+ {
+ /* Return finalizer expression. */
+ gfc_component *final;
+ final = vtab->ts.u.derived->components->next->next->next->next->next;
+ gcc_assert (strcmp (final->name, "_final") == 0);
+ gcc_assert (final->initializer
+ && final->initializer->expr_type != EXPR_NULL);
+ *final_expr = final->initializer;
+ }
+ return true;
+}
+
+
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */
@@ -2951,6 +2951,7 @@ void gfc_add_class_array_ref (gfc_expr *);
#define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash")
#define gfc_add_size_component(e) gfc_add_component_ref(e,"_size")
#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
+#define gfc_add_final_component(e) gfc_add_component_ref(e,"_final")
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
@@ -2967,6 +2968,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
gfc_intrinsic_op, bool,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
+bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
#define CLASS_DATA(sym) sym->ts.u.derived->components
@@ -2597,7 +2597,7 @@ mio_component (gfc_component *c, int vtype)
c->attr.class_ok = 1;
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
- if (!vtype)
+ if (!vtype || strcmp (c->name, "_final") == 0)
mio_expr (&c->initializer);
if (c->attr.proc_pointer)
@@ -12814,6 +12814,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
/* Add derived type to the derived type list. */
add_dt_to_dt_list (sym);
+ /* Check if the type is finalizable. This is done in order to ensure that the
+ finalization wrapper is generated early enough. */
+ gfc_is_finalizable (sym, NULL);
+
return SUCCESS;
}
@@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
#define VTABLE_EXTENDS_FIELD 2
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
+#define VTABLE_FINAL_FIELD 5
tree
@@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl)
}
+tree
+gfc_vtable_final_get (tree decl)
+{
+ return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
+}
+
+
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
#undef VTABLE_HASH_FIELD
@@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl)
#undef VTABLE_EXTENDS_FIELD
#undef VTABLE_DEF_INIT_FIELD
#undef VTABLE_COPY_FIELD
+#undef VTABLE_FINAL_FIELD
/* Obtain the vptr of the last class reference in an expression. */
@@ -1510,7 +1519,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
dt = ref->u.c.sym;
c = ref->u.c.component;
- /* Return if the component is not in the parent type. */
+ /* Return if the component is in the parent type. */
for (cmp = dt->components; cmp; cmp = cmp->next)
if (strcmp (c->name, cmp->name) == 0)
return;
@@ -1714,6 +1723,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
conv_parent_component_references (se, ref);
gfc_conv_component_ref (se, ref);
+ if (!ref->next && ref->u.c.sym->attr.codimension
+ && se->want_pointer && se->descriptor_only)
+ return;
break;
@@ -7321,7 +7321,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
/* Deallocate "to". */
tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
- to_expr2, to_expr->ts);
+ to_expr, to_expr->ts);
gfc_add_expr_to_block (&block, tmp);
/* Assign (_data) pointers. */
@@ -348,6 +348,7 @@ tree gfc_vtable_size_get (tree);
tree gfc_vtable_extends_get (tree);
tree gfc_vtable_def_init_get (tree);
tree gfc_vtable_copy_get (tree);
+tree gfc_vtable_final_get (tree);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree);