Dear all,
that's the revised version of patch at
http://gcc.gnu.org/ml/fortran/2012-08/msg00095.html, taking the review
comments into account.
Reminder: This patch only generates the finalization wrapper, which is
in the virtual table. It does not add the required calls; hence, it
still doesn't allow to use finalization.
The patch consists of three parts:
a) The main patch, which implements the wrapper.
I am asking for approval for that patch.
b) A patch which removes the gfc_error "not yet implemented"
I suggest to only remove the error after finalization calls have been
added
c) A patch which bumps the .mod version
- or alternatively -
a patch which disables the _final generation in the vtable.
I have build and regtested (on x86-64-linux) the patch with (a) and
(a)+(b) applied.
I would like to include the patch (c) as modifying the vtable changes
the ABI. Bumping the .mod version is a reliable way to force
recompilation. The alternative is to wait until the final FINAL patch
before bumping the .mod version (and disable the "_final" generation).
One possibility, if deemed useful, is to combine the .mod version bump
with backward compatible reading of .mod files, i.e., only error out
when BT_CLASS is encountered in an old .mod file.
Is the patch (a) OK for the trunk? With which version of (c)?
(I am slightly inclined to do the .mod bump now. As a follow up, one can
also commit Janus' proc-pointer patch,
http://gcc.gnu.org/ml/fortran/2012-04/msg00033.html, though I think
someone has still to review it.)
Tobias
PS: When doing the ABI change, I am going to document it in the release
notes / wiki.
2012-08-29 Alessandro Fanfarillo <fanfarillo....@gmail.com>
Tobias Burnus <bur...@net-b.de>
PR fortran/37336
* gfortran.h (symbol_attribute): Add artificial.
* module.c (mio_symbol_attribute): Handle attr.artificial
* class.c (gfc_build_class_symbol): Defer creation of the vtab
if the DT has finalizers, mark generated symbols as
attr.artificial.
(has_finalizer_component, finalize_component,
finalization_scalarizer, generate_finalization_wrapper):
New static functions.
(gfc_find_derived_vtab): Add _final component and call
generate_finalization_wrapper.
* dump-parse-tree.c (show_f2k_derived): Use resolved
proc_tree->n.sym rather than unresolved proc_sym.
(show_attr): Handle attr.artificial.
* resolve.c (gfc_resolve_finalizers): Ensure that the vtab exists.
(resolve_fl_derived): Resolve finalizers before
generating the vtab.
(resolve_symbol): Also allow assumed-rank arrays with CONTIGUOUS;
skip artificial symbols.
(resolve_fl_derived0): Skip artificial symbols.
2012-08-29 Tobias Burnus <bur...@net-b.de>
PR fortran/51632
* gfortran.dg/coarray_class_1.f90: New.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 21a91ba..9d58aab 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -34,7 +34,7 @@ along with GCC; see the file COPYING3. If not see
declared type of the class variable and its attributes
(pointer/allocatable/dimension/...).
* _vptr: A pointer to the vtable entry (see below) of the dynamic type.
-
+
For each derived type we set up a "vtable" entry, i.e. a structure with the
following fields:
* _hash: A hash value serving as a unique identifier for this type.
@@ -42,6 +42,9 @@ along with GCC; see the file COPYING3. If not see
* _extends: A pointer to the vtable entry of the parent derived type.
* _def_init: A pointer to a default initialized variable of this type.
* _copy: A procedure pointer to a copying procedure.
+ * _final: A procedure pointer to a wrapper function, which frees
+ allocatable components and calls FINAL subroutines.
+
After these follow procedure pointer components for the specific
type-bound procedures. */
@@ -572,7 +575,9 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_DERIVED;
- if (delayed_vtab)
+ if (delayed_vtab
+ || (ts->u.derived->f2k_derived
+ && ts->u.derived->f2k_derived->finalizers))
c->ts.u.derived = NULL;
else
{
@@ -689,6 +694,702 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
}
+/* Returns true if any of its nonpointer nonallocatable components or
+ their nonpointer nonallocatable subcomponents has a finalization
+ subroutine. */
+
+static bool
+has_finalizer_component (gfc_symbol *derived)
+{
+ gfc_component *c;
+
+ for (c = derived->components; c; c = c->next)
+ {
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->finalizers)
+ return true;
+
+ if (c->ts.type == BT_DERIVED
+ && !c->attr.pointer && !c->attr.allocatable
+ && has_finalizer_component (c->ts.u.derived))
+ return true;
+ }
+ return false;
+}
+
+
+/* Call DEALLOCATE for the passed component if it is allocatable, if it is
+ neither allocatable nor a pointer but has a finalizer, call it. If it
+ is a nonpointer component with allocatable or finalizes components, walk
+ them. Either of the is required; other nonallocatables and pointers aren't
+ handled gracefully.
+ Note: The DEALLOCATE handling takes care of finalizers, coarray
+ deregistering and allocatable components of the allocatable. */
+
+static void
+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
+ gfc_expr *stat, gfc_code **code)
+{
+ gfc_expr *e;
+ gfc_ref *ref;
+
+ if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS
+ && !comp->attr.allocatable)
+ return;
+
+ if ((comp->ts.type == BT_DERIVED && comp->attr.pointer)
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.pointer))
+ return;
+
+ if (comp->ts.type == BT_DERIVED && !comp->attr.allocatable
+ && (comp->ts.u.derived->f2k_derived == NULL
+ || comp->ts.u.derived->f2k_derived->finalizers == NULL)
+ && !has_finalizer_component (comp->ts.u.derived))
+ return;
+
+ e = gfc_copy_expr (expr);
+ if (!e->ref)
+ e->ref = ref = gfc_get_ref ();
+ else
+ {
+ for (ref = e->ref; ref->next; ref = ref->next)
+ ;
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ }
+ ref->type = REF_COMPONENT;
+ ref->u.c.sym = derived;
+ ref->u.c.component = comp;
+ e->ts = comp->ts;
+
+ if (comp->attr.dimension
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.dimension))
+ {
+ ref->next = gfc_get_ref ();
+ ref->next->type = REF_ARRAY;
+ ref->next->u.ar.type = AR_FULL;
+ ref->next->u.ar.dimen = 0;
+ ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
+ : comp->as;
+ e->rank = ref->next->u.ar.as->rank;
+ }
+
+ if (comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
+ {
+ /* Call DEALLOCATE (comp, stat=ignore). */
+ gfc_code *dealloc;
+
+ dealloc = XCNEW (gfc_code);
+ dealloc->op = EXEC_DEALLOCATE;
+ dealloc->loc = gfc_current_locus;
+
+ dealloc->ext.alloc.list = gfc_get_alloc ();
+ dealloc->ext.alloc.list->expr = e;
+
+ dealloc->expr1 = stat;
+ if (*code)
+ {
+ (*code)->next = dealloc;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = dealloc;
+ }
+ else if (comp->ts.type == BT_DERIVED
+ && comp->ts.u.derived->f2k_derived
+ && comp->ts.u.derived->f2k_derived->finalizers)
+ {
+ /* Call FINAL_WRAPPER (comp); */
+ gfc_code *final_wrap;
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ vtab = gfc_find_derived_vtab (comp->ts.u.derived);
+ for (c = vtab->ts.u.derived->components; c; c = c->next)
+ if (strcmp (c->name, "_final") == 0)
+ break;
+
+ gcc_assert (c);
+ final_wrap = XCNEW (gfc_code);
+ final_wrap->op = EXEC_CALL;
+ final_wrap->loc = gfc_current_locus;
+ final_wrap->next->loc = gfc_current_locus;
+ final_wrap->next->symtree = c->initializer->symtree;
+ final_wrap->next->resolved_sym = c->initializer->symtree->n.sym;
+ final_wrap->next->ext.actual = gfc_get_actual_arglist ();
+ final_wrap->next->ext.actual->expr = e;
+
+ if (*code)
+ {
+ (*code)->next = final_wrap;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = final_wrap;
+ }
+ else
+ {
+ gfc_component *c;
+
+ for (c = comp->ts.u.derived->components; c; c = c->next)
+ finalize_component (e, c->ts.u.derived, c, stat, code);
+ }
+}
+
+
+/* Generate code equivalent to
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr),
+ ptr). */
+
+static gfc_code *
+finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
+ gfc_namespace *sub_ns)
+{
+ gfc_code *block;
+ gfc_expr *expr, *expr2, *expr3;
+
+ /* C_F_POINTER(). */
+ block = XCNEW (gfc_code);
+ block->op = EXEC_CALL;
+ block->loc = gfc_current_locus;
+ gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+ block->resolved_sym = block->symtree->n.sym;
+ block->resolved_sym->attr.flavor = FL_PROCEDURE;
+ block->resolved_sym->attr.intrinsic = 1;
+ block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
+ gfc_commit_symbol (block->resolved_sym);
+
+ /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->next = gfc_get_actual_arglist ();
+ block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0);
+
+ /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
+
+ /* TRANSFER. */
+ expr2 = gfc_get_expr ();
+ expr2->expr_type = EXPR_FUNCTION;
+ expr2->value.function.name = "__transfer0";
+ expr2->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
+ /* Set symtree for -fdump-parse-tree. */
+ gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false);
+ expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ expr2->symtree->n.sym->attr.intrinsic = 1;
+ gfc_commit_symbol (expr2->symtree->n.sym);
+ expr2->value.function.actual = gfc_get_actual_arglist ();
+ expr2->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ expr2->ts.type = BT_INTEGER;
+ expr2->ts.kind = gfc_index_integer_kind;
+
+ /* TRANSFER's second argument: 0_c_intptr_t. */
+ expr2->value.function.actual = gfc_get_actual_arglist ();
+ expr2->value.function.actual->next = gfc_get_actual_arglist ();
+ expr2->value.function.actual->next->expr
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ expr2->value.function.actual->next->next = gfc_get_actual_arglist ();
+
+ /* TRANSFER's first argument: C_LOC (array). */
+ expr = gfc_get_expr ();
+ expr->expr_type = EXPR_FUNCTION;
+ gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+ expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
+ expr->symtree->n.sym->attr.intrinsic = 1;
+ expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
+ expr->value.function.esym = expr->symtree->n.sym;
+ expr->value.function.actual = gfc_get_actual_arglist ();
+ expr->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ expr->symtree->n.sym->result = expr->symtree->n.sym;
+ gfc_commit_symbol (expr->symtree->n.sym);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = gfc_index_integer_kind;
+ expr2->value.function.actual->expr = expr;
+
+ /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ block->ext.actual->expr = gfc_get_expr ();
+ expr = block->ext.actual->expr;
+ expr->expr_type = EXPR_OP;
+ expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ expr->value.op.op1 = gfc_get_expr ();
+ expr->value.op.op1->expr_type = EXPR_FUNCTION;
+ expr->value.op.op1->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
+ gfc_get_sym_tree ("storage_size", sub_ns, &expr->value.op.op1->symtree,
+ false);
+ expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
+ gfc_commit_symbol (expr->value.op.op1->symtree->n.sym);
+ expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
+ expr->value.op.op1->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
+ expr->value.op.op1->value.function.actual->next->expr
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ expr->value.op.op1->ts = expr->value.op.op2->ts;
+ expr->ts = expr->value.op.op1->ts;
+
+ /* Offset calculation: idx * (STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE). */
+ block->ext.actual->expr = gfc_get_expr ();
+ expr3 = block->ext.actual->expr;
+ expr3->expr_type = EXPR_OP;
+ expr3->value.op.op = INTRINSIC_TIMES;
+ expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
+ expr3->value.op.op2 = expr;
+ expr3->ts = expr->ts;
+
+ /* <array addr> + <offset>. */
+ block->ext.actual->expr = gfc_get_expr ();
+ block->ext.actual->expr->expr_type = EXPR_OP;
+ block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
+ block->ext.actual->expr->value.op.op1 = expr2;
+ block->ext.actual->expr->value.op.op2 = expr3;
+ block->ext.actual->expr->ts = expr->ts;
+
+ /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
+ block->ext.actual->next = gfc_get_actual_arglist ();
+ block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
+ block->ext.actual->next->next = gfc_get_actual_arglist ();
+
+ return block;
+}
+
+
+/* Generate the wrapper finalization/polymorphic freeing subroutine for the
+ derived type "derived". The function first calls the approriate FINAL
+ subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
+ components (but not the inherited ones). Last, it calls the wrapper
+ subroutine of the parent. The generated wrapper procedure takes as argument
+ an assumed-rank array.
+ If neither allocatable components nor FINAL subroutines exists, the vtab
+ will contain a NULL pointer. */
+
+static void
+generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
+ const char *tname, gfc_component *vtab_final)
+{
+ gfc_symbol *final, *array, *nelem;
+ gfc_symbol *ptr = NULL, *idx = NULL;
+ gfc_component *comp;
+ gfc_namespace *sub_ns;
+ gfc_code *last_code;
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ bool finalizable_comp = false;
+ gfc_expr *ancestor_wrapper = NULL;
+
+ /* Search for the ancestor's finalizers. */
+ if (derived->attr.extension && derived->components
+ && (!derived->components->ts.u.derived->attr.abstract
+ || has_finalizer_component (derived)))
+ {
+ gfc_symbol *vtab;
+ gfc_component *comp;
+
+ vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+ for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
+ if (comp->name[0] == '_' && comp->name[1] == 'f')
+ {
+ ancestor_wrapper = comp->initializer;
+ break;
+ }
+ }
+
+ /* No wrapper of the ancestor and no own FINAL subroutines and
+ allocatable components: Return a NULL() expression. */
+ if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
+ && !derived->attr.alloc_comp
+ && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ && !has_finalizer_component (derived))
+ {
+ vtab_final->initializer = gfc_get_null_expr (NULL);
+ return;
+ }
+
+ /* Check whether there are new allocatable components. */
+ for (comp = derived->components; comp; comp = comp->next)
+ {
+ if (comp == derived->components && derived->attr.extension
+ && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ continue;
+
+ if (comp->ts.type != BT_CLASS && !comp->attr.pointer
+ && (comp->attr.alloc_comp || comp->attr.allocatable
+ || (comp->ts.type == BT_DERIVED
+ && has_finalizer_component (comp->ts.u.derived))))
+ finalizable_comp = true;
+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable)
+ finalizable_comp = true;
+ }
+
+ /* If there is no new finalizer and no new allocatable, return with
+ an expr to the ancestor's one. */
+ if ((!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ && !finalizable_comp)
+ {
+ vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
+ return;
+ }
+
+ /* We now create a wrapper, which does the following:
+ 1. It calls the suitable finalization subroutine for this type
+ 2. In a loop over all noninherited allocatable components and noninherited
+ components with allocatable components and DEALLOCATE those; this will
+ take care of finalizers, coarray deregistering and allocatable
+ nested components.
+ 3. Call the ancestor's finalizer. */
+
+ /* Declare the wrapper function; it takes an assumed-rank array
+ as argument. */
+
+ /* Set up the namespace. */
+ sub_ns = gfc_get_namespace (ns, 0);
+ sub_ns->sibling = ns->contained;
+ ns->contained = sub_ns;
+ sub_ns->resolved = 1;
+
+ /* Set up the procedure symbol. */
+ sprintf (name, "__final_%s", tname);
+ gfc_get_symbol (name, sub_ns, &final);
+ sub_ns->proc_name = final;
+ final->attr.flavor = FL_PROCEDURE;
+ final->attr.subroutine = 1;
+ final->attr.pure = 1;
+ final->attr.artificial = 1;
+ final->attr.if_source = IFSRC_DECL;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ final->module = ns->proc_name->name;
+ gfc_set_sym_referenced (final);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("array", sub_ns, &array);
+ array->ts.type = BT_DERIVED;
+ array->ts.u.derived = derived;
+ array->attr.flavor = FL_VARIABLE;
+ array->attr.dummy = 1;
+ array->attr.contiguous = 1;
+ array->attr.dimension = 1;
+ array->attr.artificial = 1;
+ array->as = gfc_get_array_spec();
+ array->as->type = AS_ASSUMED_RANK;
+ array->as->rank = -1;
+ array->attr.intent = INTENT_INOUT;
+ gfc_set_sym_referenced (array);
+ final->formal = gfc_get_formal_arglist ();
+ final->formal->sym = array;
+ gfc_commit_symbol (array);
+
+ /* Obtain the size (number of elements) of "array" MINUS ONE,
+ which is used in the scalarization. */
+ gfc_get_symbol ("nelem", sub_ns, &nelem);
+ nelem->ts.type = BT_INTEGER;
+ nelem->ts.kind = gfc_index_integer_kind;
+ nelem->attr.flavor = FL_VARIABLE;
+ nelem->attr.artificial = 1;
+ gfc_set_sym_referenced (nelem);
+ gfc_commit_symbol (nelem);
+
+ /* Generate: nelem = SIZE (array) - 1. */
+ last_code = XCNEW (gfc_code);
+ last_code->op = EXEC_ASSIGN;
+ last_code->loc = gfc_current_locus;
+
+ last_code->expr1 = gfc_lval_expr_from_sym (nelem);
+
+ last_code->expr2 = gfc_get_expr ();
+ last_code->expr2->expr_type = EXPR_OP;
+ last_code->expr2->value.op.op = INTRINSIC_MINUS;
+ last_code->expr2->value.op.op2
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
+
+ last_code->expr2->value.op.op1 = gfc_get_expr ();
+ last_code->expr2->value.op.op1->expr_type = EXPR_FUNCTION;
+ last_code->expr2->value.op.op1->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
+ gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
+ false);
+ last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
+ gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
+ last_code->expr2->value.op.op1->value.function.actual
+ = gfc_get_actual_arglist ();
+ last_code->expr2->value.op.op1->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ /* dim=NULL. */
+ last_code->expr2->value.op.op1->value.function.actual->next
+ = gfc_get_actual_arglist ();
+ /* kind=c_intptr_t. */
+ last_code->expr2->value.op.op1->value.function.actual->next->next
+ = gfc_get_actual_arglist ();
+ last_code->expr2->value.op.op1->value.function.actual->next->next->expr
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ last_code->expr2->value.op.op1->ts
+ = last_code->expr2->value.op.op1->value.function.isym->ts;
+
+ sub_ns->code = last_code;
+
+ /* Call final subroutines. We now generate code like:
+ use iso_c_binding
+ integer, pointer :: ptr
+ type(c_ptr) :: cptr
+ integer(c_intptr_t) :: i, addr
+
+ select case (rank (array))
+ case (3)
+ call final_rank3 (array)
+ case default:
+ do i = 0, size (array)-1
+ addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array)
+ call c_f_pointer (transfer (addr, cptr), ptr)
+ call elemental_final (ptr)
+ end do
+ end select */
+
+ if (derived->f2k_derived && derived->f2k_derived->finalizers)
+ {
+ gfc_finalizer *fini, *fini_elem = NULL;
+ gfc_code *block = NULL;
+
+ /* SELECT CASE (RANK (array)). */
+ last_code->next = XCNEW (gfc_code);
+ last_code = last_code->next;
+ last_code->op = EXEC_SELECT;
+ last_code->loc = gfc_current_locus;
+
+ last_code->expr1 = gfc_get_expr ();
+ last_code->expr1->expr_type = EXPR_FUNCTION;
+ last_code->expr1->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
+ gfc_get_sym_tree ("rank", sub_ns, &last_code->expr1->symtree,
+ false);
+ last_code->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ last_code->expr1->symtree->n.sym->attr.intrinsic = 1;
+ gfc_commit_symbol (last_code->expr1->symtree->n.sym);
+ last_code->expr1->value.function.actual = gfc_get_actual_arglist ();
+ last_code->expr1->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ last_code->expr1->ts = last_code->expr1->value.function.isym->ts;
+
+ for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+ {
+ if (fini->proc_tree->n.sym->attr.elemental)
+ {
+ fini_elem = fini;
+ continue;
+ }
+
+ /* CASE (fini_rank). */
+ if (block)
+ {
+ block->block = XCNEW (gfc_code);
+ block = block->block;
+ }
+ else
+ {
+ block = XCNEW (gfc_code);
+ last_code->block = block;
+ }
+ block->loc = gfc_current_locus;
+ block->op = EXEC_SELECT;
+ block->ext.block.case_list = gfc_get_case ();
+ block->ext.block.case_list->where = gfc_current_locus;
+ if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+ block->ext.block.case_list->low
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ fini->proc_tree->n.sym->formal->sym->as->rank);
+ else
+ block->ext.block.case_list->low
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ block->ext.block.case_list->high
+ = block->ext.block.case_list->low;
+
+ /* CALL fini_rank (array). */
+ block->next = XCNEW (gfc_code);
+ block->next->op = EXEC_CALL;
+ block->next->loc = gfc_current_locus;
+ block->next->symtree = fini->proc_tree;
+ block->next->resolved_sym = fini->proc_tree->n.sym;
+ block->next->ext.actual = gfc_get_actual_arglist ();
+ block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ }
+
+ /* Elemental call - scalarized. */
+ if (fini_elem)
+ {
+ gfc_iterator *iter;
+
+ /* CASE DEFAULT. */
+ if (block)
+ {
+ block->block = XCNEW (gfc_code);
+ block = block->block;
+ }
+ else
+ {
+ block = XCNEW (gfc_code);
+ last_code->block = block;
+ }
+ block->loc = gfc_current_locus;
+ block->op = EXEC_SELECT;
+ block->ext.block.case_list = gfc_get_case ();
+
+ gfc_get_symbol ("idx", sub_ns, &idx);
+ idx->ts.type = BT_INTEGER;
+ idx->ts.kind = gfc_index_integer_kind;
+ idx->attr.flavor = FL_VARIABLE;
+ idx->attr.artificial = 1;
+ gfc_set_sym_referenced (idx);
+ gfc_commit_symbol (idx);
+
+ gfc_get_symbol ("ptr", sub_ns, &ptr);
+ ptr->ts.type = BT_DERIVED;
+ ptr->ts.u.derived = derived;
+ ptr->attr.flavor = FL_VARIABLE;
+ ptr->attr.pointer = 1;
+ ptr->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+ block->op = EXEC_DO;
+ block->loc = gfc_current_locus;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code ();
+ block->block->op = EXEC_DO;
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * STORAGE_SIZE (array), c_ptr), ptr). */
+ block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
+ block = block->block->next;
+
+ /* CALL final_elemental (array). */
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+ block->op = EXEC_CALL;
+ block->loc = gfc_current_locus;
+ block->symtree = fini_elem->proc_tree;
+ block->resolved_sym = fini_elem->proc_sym;
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
+ }
+ }
+
+ /* Finalize and deallocate allocatable components. The same manual
+ scalarization is used as above. */
+
+ if (finalizable_comp)
+ {
+ gfc_symbol *stat;
+ gfc_code *block = NULL;
+ gfc_iterator *iter;
+
+ if (!idx)
+ {
+ gfc_get_symbol ("idx", sub_ns, &idx);
+ idx->ts.type = BT_INTEGER;
+ idx->ts.kind = gfc_index_integer_kind;
+ idx->attr.flavor = FL_VARIABLE;
+ idx->attr.artificial = 1;
+ gfc_set_sym_referenced (idx);
+ gfc_commit_symbol (idx);
+ }
+
+ if (!ptr)
+ {
+ gfc_get_symbol ("ptr", sub_ns, &ptr);
+ ptr->ts.type = BT_DERIVED;
+ ptr->ts.u.derived = derived;
+ ptr->attr.flavor = FL_VARIABLE;
+ ptr->attr.pointer = 1;
+ ptr->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+ }
+
+ gfc_get_symbol ("ignore", sub_ns, &stat);
+ stat->attr.flavor = FL_VARIABLE;
+ stat->attr.artificial = 1;
+ stat->ts.type = BT_INTEGER;
+ stat->ts.kind = gfc_default_integer_kind;
+ gfc_set_sym_referenced (stat);
+ gfc_commit_symbol (stat);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ last_code->next = XCNEW (gfc_code);
+ last_code = last_code->next;
+ last_code->op = EXEC_DO;
+ last_code->loc = gfc_current_locus;
+ last_code->ext.iterator = iter;
+ last_code->block = gfc_get_code ();
+ last_code->block->op = EXEC_DO;
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * STORAGE_SIZE (array), c_ptr), ptr). */
+ last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
+ block = last_code->block->next;
+
+ for (comp = derived->components; comp; comp = comp->next)
+ {
+ if (comp == derived->components && derived->attr.extension
+ && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ continue;
+
+ finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
+ gfc_lval_expr_from_sym (stat), &block);
+ if (!last_code->block->next)
+ last_code->block->next = block;
+ }
+
+ }
+
+ /* Call the finalizer of the ancestor. */
+ if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ {
+ last_code->next = XCNEW (gfc_code);
+ last_code = last_code->next;
+ last_code->op = EXEC_CALL;
+ last_code->loc = gfc_current_locus;
+ last_code->symtree = ancestor_wrapper->symtree;
+ last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
+
+ last_code->ext.actual = gfc_get_actual_arglist ();
+ last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ }
+
+ gfc_commit_symbol (final);
+ vtab_final->initializer = gfc_lval_expr_from_sym (final);
+ vtab_final->ts.interface = final;
+}
+
+
/* Add procedure pointers for all type-bound procedures to a vtab. */
static void
@@ -731,7 +1432,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
/* If the type is a class container, use the underlying derived type. */
if (derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
-
+
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@@ -831,6 +1532,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
+ c->attr.artificial = 1;
c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED;
c->ts.u.derived = derived;
@@ -842,6 +1544,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
sprintf (name, "__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
+ def_init->attr.artificial = 1;
def_init->attr.save = SAVE_IMPLICIT;
def_init->attr.access = ACCESS_PUBLIC;
def_init->attr.flavor = FL_VARIABLE;
@@ -876,6 +1579,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
copy->attr.flavor = FL_PROCEDURE;
copy->attr.subroutine = 1;
copy->attr.pure = 1;
+ copy->attr.artificial = 1;
copy->attr.if_source = IFSRC_DECL;
/* This is elemental so that arrays are automatically
treated correctly by the scalarizer. */
@@ -889,7 +1593,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
src->ts.u.derived = derived;
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
- src->attr.intent = INTENT_IN;
+ src->attr.artificial = 1;
+ src->attr.intent = INTENT_IN;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
@@ -898,6 +1603,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
dst->ts.u.derived = derived;
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
+ dst->attr.artificial = 1;
dst->attr.intent = INTENT_OUT;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
@@ -912,6 +1618,20 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.interface = copy;
}
+ /* Add component _final, which contains a procedure pointer to
+ a wrapper which handles both the freeing of allocatable
+ components and the calls to finalization subroutines.
+ Note: The actual wrapper function can only be generated
+ at resolution time. */
+
+ if (gfc_add_component (vtype, "_final", &c) == FAILURE)
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+ generate_finalization_wrapper (derived, ns, tname, c);
+
/* Add procedure pointers for type-bound procedures. */
add_procs_to_declared_vtab (derived, vtype);
}
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index cb8fab4..9d6f93c 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -613,6 +613,8 @@ show_attr (symbol_attribute *attr, const char * module)
if (attr->save != SAVE_NONE)
fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
+ if (attr->artificial)
+ fputs (" ARTIFICIAL", dumpfile);
if (attr->allocatable)
fputs (" ALLOCATABLE", dumpfile);
if (attr->asynchronous)
@@ -788,7 +790,7 @@ show_f2k_derived (gfc_namespace* f2k)
for (f = f2k->finalizers; f; f = f->next)
{
show_indent ();
- fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
+ fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
}
/* Type-bound procedures. */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d67d57b..b3224aa 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -761,6 +761,10 @@ typedef struct
/* Set if a function must always be referenced by an explicit interface. */
unsigned always_explicit:1;
+ /* Set if the symbol is generated and, hence, standard violations
+ shouldn't be flaged. */
+ unsigned artificial:1;
+
/* Set if the symbol has been referenced in an expression. No further
modification of type or type parameters is permitted. */
unsigned referenced:1;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index bfd8b01..5cfc335 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1844,13 +1844,14 @@ typedef enum
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
- AB_IMPLICIT_PURE
+ AB_IMPLICIT_PURE, AB_ARTIFICIAL
}
ab_attribute;
static const mstring attr_bits[] =
{
minit ("ALLOCATABLE", AB_ALLOCATABLE),
+ minit ("ARTIFICIAL", AB_ARTIFICIAL),
minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
minit ("DIMENSION", AB_DIMENSION),
minit ("CODIMENSION", AB_CODIMENSION),
@@ -1975,6 +1976,8 @@ mio_symbol_attribute (symbol_attribute *attr)
{
if (attr->allocatable)
MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
+ if (attr->artificial)
+ MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
if (attr->asynchronous)
MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
if (attr->dimension)
@@ -2090,6 +2093,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_ALLOCATABLE:
attr->allocatable = 1;
break;
+ case AB_ARTIFICIAL:
+ attr->artificial = 1;
+ break;
case AB_ASYNCHRONOUS:
attr->asynchronous = 1;
break;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 312713b..129c9bb 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11220,8 +11220,9 @@ error:
/* TODO: Remove this error when finalization is finished. */
gfc_error ("Finalization at %L is not yet implemented",
&derived->declared_at);
+ gfc_find_derived_vtab (derived);
return result;
}
@@ -11925,6 +11926,9 @@ resolve_fl_derived0 (gfc_symbol *sym)
for ( ; c != NULL; c = c->next)
{
+ if (c->attr.artificial)
+ continue;
+
/* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
{
@@ -12321,6 +12325,10 @@ resolve_fl_derived (gfc_symbol *sym)
&sym->declared_at) == FAILURE)
return FAILURE;
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
+
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
@@ -12341,10 +12349,6 @@ resolve_fl_derived (gfc_symbol *sym)
if (resolve_typebound_procedures (sym) == FAILURE)
return FAILURE;
- /* Resolve the finalizer procedures. */
- if (gfc_resolve_finalizers (sym) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
@@ -12541,6 +12545,9 @@ resolve_symbol (gfc_symbol *sym)
symbol_attribute class_attr;
gfc_array_spec *as;
+ if (sym->attr.artificial)
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external
@@ -12674,11 +12681,12 @@ resolve_symbol (gfc_symbol *sym)
/* F2008, C530. */
if (sym->attr.contiguous
&& (!class_attr.dimension
- || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
+ || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
+ && !class_attr.pointer)))
{
gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
- "array pointer or an assumed-shape array", sym->name,
- &sym->declared_at);
+ "array pointer or an assumed-shape or assumed-rank array",
+ sym->name, &sym->declared_at);
return;
}
2012-08-29 Alessandro Fanfarillo <fanfarillo....@gmail.com>
Tobias Burnus <bur...@net-b.de>
PR fortran/37336
* resolve.c (gfc_resolve_finalizers): Remove not-implemented
error.
2012-08-29 Alessandro Fanfarillo <fanfarillo....@gmail.com>
Tobias Burnus <bur...@net-b.de>
PR fortran/37336
* gfortran.dg/coarray_poly_3.f90: Update dg-error.
* gfortran.dg/auto_dealloc_2.f90: Update scan-tree-dump-times.
* gfortran.dg/class_19.f03: Ditto.
* gfortran.dg/finalize_4.f03: Remove dg-excess-errors
for not implemented.
* gfortran.dg/finalize_5.f03: Ditto.
* gfortran.dg/finalize_7.f03: Ditto.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 129c9bb..011d199 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11218,10 +11218,6 @@ error:
" defined at %L, suggest also scalar one",
derived->name, &derived->declared_at);
- /* TODO: Remove this error when finalization is finished. */
- gfc_error ("Finalization at %L is not yet implemented",
- &derived->declared_at);
-
gfc_find_derived_vtab (derived);
return result;
}
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index e607b6a..9096b85 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -25,5 +25,5 @@ contains
end program
-! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03
index 63b8e06..884d6ae 100644
--- a/gcc/testsuite/gfortran.dg/class_19.f03
+++ b/gcc/testsuite/gfortran.dg/class_19.f03
@@ -39,5 +39,5 @@ program main
end program main
-! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_3.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
index e6b19ae..8edd8d3 100644
--- a/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
@@ -3,13 +3,13 @@
!
-subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" }
type t
end type t
class(t), contiguous, allocatable :: x(:)
end
-subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" }
type t
end type t
class(t), contiguous, allocatable :: x(:)[:]
diff --git a/gcc/testsuite/gfortran.dg/finalize_4.f03 b/gcc/testsuite/gfortran.dg/finalize_4.f03
index 11e094f..b4c08f2 100644
--- a/gcc/testsuite/gfortran.dg/finalize_4.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_4.f03
@@ -48,6 +48,3 @@ PROGRAM finalizer
DEALLOCATE(mat)
END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
diff --git a/gcc/testsuite/gfortran.dg/finalize_5.f03 b/gcc/testsuite/gfortran.dg/finalize_5.f03
index b9ec376..fb81531 100644
--- a/gcc/testsuite/gfortran.dg/finalize_5.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_5.f03
@@ -107,6 +107,3 @@ PROGRAM finalizer
IMPLICIT NONE
! Nothing here, errors above
END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
diff --git a/gcc/testsuite/gfortran.dg/finalize_7.f03 b/gcc/testsuite/gfortran.dg/finalize_7.f03
index 6ca4f55..5807ed5 100644
--- a/gcc/testsuite/gfortran.dg/finalize_7.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_7.f03
@@ -52,6 +52,3 @@ PROGRAM finalizer
IMPLICIT NONE
! Nothing here
END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
-------------------------------------------------------
NOTE: Only one of the two patchlets should be committed
not both!
-------------------------------------------------------
2012-08-19 Alessandro Fanfarillo <fanfarillo....@gmail.com>
Tobias Burnus <bur...@net-b.de>
PR fortran/37336
* module.c (MOD_VERSION): Bump to for recompilation
after the vtable ABI has changed.
* class.c (gfc_find_derived_vtab): Disable the FINAL
wrapper generation.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 9d58aab..8c51302 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1624,13 +1624,14 @@ gfc_find_derived_vtab (gfc_symbol *derived)
Note: The actual wrapper function can only be generated
at resolution time. */
+ /* TODO: Enabled when FINAL is implemented. */
if (gfc_add_component (vtype, "_final", &c) == FAILURE)
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
- generate_finalization_wrapper (derived, ns, tname, c);
+ generate_finalization_wrapper (derived, ns, tname, c);*/
/* Add procedure pointers for type-bound procedures. */
add_procs_to_declared_vtab (derived, vtype);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index bfd8b01..b8f0b02 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -82,7 +82,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "9"
+#define MOD_VERSION "10"
/* Structure that describes a position within a module file. */
