This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>, Alessandro Fanfarillo <alessandro dot fanfarillo at gmail dot com>, "Rouson, Damian" <rouson at sandia dot gov>
- Date: Sun, 19 Aug 2012 19:50:47 +0200
- Subject: Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
- References: <50295E1A.5050108@net-b.de>
Dear all,
attached is a slightly updated patch:
* Call finalizers of nonallocatable, nonpointer components
* Generate FINAL wrapper for abstract types which have a finalizer. (The
allocatable components are deallocated in the first type (abstract or
not) which has a finalizer, i.e. abstract + finalizer or first
nonabstract type.)
I had to disable some resolve warning; I did so by introducing an
attr.artificial. I used it to also fix PR 51632, where we errored out
for __def_init and __copy where there were coarray components.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
2012-08-19 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.h (symbol_attribute): Add artifical and final_comp.
* parse.c (parse_derived): Set final_comp.
* module.c (mio_symbol_attribute): Handle final.comp.
* class.c (gfc_build_class_symbol): Defer creation of the vtab
if the DT has finalizers, mark generated symbols as
attr.artificial.
(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.
* resolve.c (gfc_resolve_finalizers): Remove not-implemented
error and 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-19 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@net-b.de>
PR fortran/51632
* gfortran.dg/coarray_class_1.f90: New.
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/class.c b/gcc/fortran/class.c
index 21a91ba..122cc43 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,672 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
}
+/* 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. */
+
+void
+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
+ gfc_expr *stat, gfc_code **code)
+{
+ gfc_expr *e;
+ e = gfc_copy_expr (expr);
+ e->ref = gfc_get_ref ();
+ e->ref->type = REF_COMPONENT;
+ e->ref->u.c.sym = derived;
+ e->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))
+ {
+ e->ref->next = gfc_get_ref ();
+ e->ref->next->type = REF_ARRAY;
+ e->ref->next->u.ar.type = AR_FULL;
+ e->ref->next->u.ar.dimen = 0;
+ e->ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
+ : comp->as;
+ e->rank = e->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 (c->name[0] == '_' && c->name[1] == 'f')
+ 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;
+
+ gcc_assert ((comp->attr.alloc_comp || comp->attr.final_comp)
+ && comp->ts.type != BT_CLASS);
+ for (c = comp->ts.u.derived->components; c; c = c->next)
+ if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
+ && (comp->attr.alloc_comp || comp->attr.allocatable
+ || comp->attr.final_comp))
+ || ((comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable)))
+ finalize_component (e, comp->ts.u.derived, comp, 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;
+ block->symtree = gfc_find_symtree (sub_ns->sym_root, "c_f_pointer");
+ 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. */
+ expr2->symtree = gfc_find_symtree (sub_ns->sym_root, "transfer");
+ 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;
+ expr->symtree = gfc_find_symtree (sub_ns->sym_root, "c_loc");
+ 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);
+ expr->value.op.op1->symtree = gfc_find_symtree (sub_ns->sym_root,
+ "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 alloc_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
+ || derived->components->attr.final_comp))
+ {
+ 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))
+ {
+ 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->attr.final_comp))
+ alloc_comp = true;
+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable)
+ alloc_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)
+ && !alloc_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);
+ last_code->expr2->value.op.op1->symtree
+ = gfc_find_symtree (sub_ns->sym_root, "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);
+ last_code->expr1->symtree = gfc_find_symtree (sub_ns->sym_root, "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 (alloc_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;
+
+ if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
+ && (comp->attr.alloc_comp || comp->attr.allocatable
+ || comp->attr.final_comp))
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
+ {
+ 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 +1402,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 +1502,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 +1514,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 +1549,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 +1563,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 +1573,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 +1588,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..528b276 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -788,7 +788,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 7c4c0a4..d05e88a 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;
@@ -784,7 +788,8 @@ typedef struct
possibly nested. zero_comp is true if the derived type has no
component at all. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
- private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
+ private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
+ final_comp:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a4ff199..232956a 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1840,7 +1840,7 @@ typedef enum
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_FINAL_COMP,
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,
@@ -2057,6 +2057,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->coarray_comp)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+ if (attr->final_comp)
+ MIO_NAME (ab_attribute) (AB_FINAL_COMP, attr_bits);
if (attr->lock_comp)
MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
if (attr->zero_comp)
@@ -2198,6 +2200,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_COARRAY_COMP:
attr->coarray_comp = 1;
break;
+ case AB_FINAL_COMP:
+ attr->final_comp = 1;
+ break;
case AB_LOCK_COMP:
attr->lock_comp = 1;
break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 44b1900..4cafefe 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2250,6 +2250,16 @@ endType:
sym->attr.lock_comp = 1;
}
+ /* Look for finalizers. */
+ if (c->attr.final_comp
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->f2k_derived
+ && CLASS_DATA (c)->ts.u.derived->f2k_derived->finalizers)
+ || (c->ts.type == BT_DERIVED
+ && c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->finalizers))
+ sym->attr.final_comp = 1;
+
/* Check for F2008, C1302 - and recall that pointers may not be coarrays
(5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
unless there are nondirect [allocatable or pointer] components
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ac5a362..f19943d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11191,10 +11203,7 @@ 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;
}
@@ -11898,6 +11907,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)
{
@@ -12294,6 +12306,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. */
@@ -12314,10 +12330,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;
}
@@ -12514,6 +12526,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
@@ -12647,11 +12662,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;
}
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" }
--- /dev/null 2012-08-16 07:16:46.391724752 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_class_1.f90 2012-08-19 19:23:41.000000000 +0200
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/51632
+!
+! Was rejected before as __def_init and __copy were
+! resolved and coarray components aren't valid in this
+! context
+!
+module periodic_2nd_order_module
+ implicit none
+
+ type periodic_2nd_order
+ real, allocatable :: global_f(:)[:]
+ contains
+ procedure :: output
+ end type
+
+contains
+ subroutine output (this)
+ class(periodic_2nd_order), intent(in) :: this
+ end subroutine
+end module