* [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
@ 2012-08-13 20:06 Tobias Burnus
2012-08-14 1:12 ` [EXTERNAL] " Rouson, Damian
` (2 more replies)
0 siblings, 3 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-08-13 20:06 UTC (permalink / raw)
To: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
[-- Attachment #1: Type: text/plain, Size: 6527 bytes --]
Dear all,
Attached is the first part of a patch which will implement finalization
support and polymorphic freeing in gfortran.
It addresses two needs:
a) For polymorphic ("CLASS") variables, allocatable components have to
be freed; however, at compile time only the allocatable components of
the declared type are known – and the dynamic type might have more
b) Fortran 2003 allows finalization subroutines ("FINAL", destructors),
which can be elemental, scalar or for a given rank (any array type is
allowed). Those should be called for DEALLOCATE, leaving the scope
(unless saved), intrinsic assignment and with intent(out).
The finalization is done as follows (F2008, "4.5.6.2 The finalization
process")
"(1) If the dynamic type of the entity has a final subroutine whose
dummy argument has the same kind type parameters and rank as the entity
being finalized, it is called with the entity as an actual argument.
Otherwise, if there is an elemental final subroutine whose dummy
argument has the same kind type parameters as the entity being
finalized, it is called with the entity as an actual argument.
Otherwise, no subroutine is called at this point.
"(2) All finalizable components that appear in the type definition are
finalized in a processor-dependent order. If the entity being finalized
is an array, each finalizable component of each element of that entity
is finalized separately.
"(3) If the entity is of extended type and the parent type is
finalizable, the parent component is finalized."
The idea is to create a wrapper function which handles those steps - and
attach a reference to the dynamic type (i.e. add it via proc-pointer to
the vtable). Additionally, the wrapper can be directly called for TYPE.
The attached patch implements the generation of the wrapper subroutine;
it does not yet implement the actual calls. The wrapper is generated on
Fortran AST level and creates code similar to
subroutine final_wrapper_for_type_t (array)
type(t), intent(inout) :: array(..)
integer, pointer :: ptr
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, c_ptr), ptr)
call elemental_final (ptr)
end do
end select
! For all noninherited allocatable components, call
! DEALLOCATE(array(:)%comp, stat=ignore)
! scalarized as above
call final_wrapper_of_parent (array(...)%parent)
end subroutine final_wrapper_for_type_t
Note 1: The call to the parent type requires packing support for
assumed-rank arrays, which has not yet been implemented (also required
for TS29113, though not for this usage). That is, without further
patches, the wrapper will only work for scalars or if the parent has no
wrapper subroutine.
Note 2: The next step will be to add the calls to the wrapper, starting
with an explicit DEALLOCATE.
I intent to commit the patch, when approved, without allowing FINAL at
resolution time; that way there is no false impression that finalization
actually works.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
* * *
Note: The patch will break gfortran's OOP ABI. It does so by adding
"_final" to the virtual table (vtab).
I think breaking the ABI for this functionality is unavoidable. The ABI
change only affects code which uses the CLASS (polymorphic variables)
and the issue only raises if one mixes old with new code for the same
derived type. However, if one does so (e.g. by incomplete
recompilation), segfaults and similar issues will occur. Hence, I am
considering to bump the .mod version; that will effectively force a
recompilation and thus avoid the issue. The down side is that it will
also break packages (e.g. of Linux distributions) which ship .mod files
(sorry!). What do you think?
I think it could then be combined with Janus' proc-pointer patch, which
changes the assembler name of (non-Bind(C)) procedure pointers, declared
at module level. Again, by forcing recompilation, the .mod version bump
should ensure that users don't see the ABI breakage. His patch is at
http://gcc.gnu.org/ml/fortran/2012-04/msg00033.html (I think is okay,
but I believe it has not yet been reviewed.)
Tobias
PS: I used the following test case to test whether the wrapper
generation and scalarization works; it properly prints 11,22,33,44,55,66
and also the dump looks okay for various versions.
The scalarization code should work relatively well; there is only one
call to an external function: For SIZE gfortran - for what ever reason -
doesn't generate inline code, but calls libgfortran.
But now the test code:
module m
type tt
end type tt
type t
! type(tt), allocatable :: comp1
integer :: val
contains
final bar1
end type t
type t1t
! type(tt), allocatable :: comp1
integer :: val
!contains
! final bar1
end type t1t
type, extends(t) :: t2
type(tt), allocatable :: comp2
contains
final bar2
end type t2
class(t), allocatable, save :: a
class(t2), allocatable, save :: b
contains
impure elemental subroutine bar1(x)
! subroutine bar1(x)
type(t), intent(inout) :: x!(:)
print *, 'bar1, ....'
print *, '..........', x%val
end subroutine bar1
subroutine bar2(y)
type(t2),intent(inout) :: y(:,:)
end subroutine bar2
end
use m
use iso_c_binding
type(t1t) ::x(3,2)
interface
subroutine fini(x) bind(C,name="__m_MOD___final_m_T")
type(*) :: x(..)
end subroutine
end interface
x%val = reshape([11,22,33,44,55,66],shape(x))
print *, storage_size(x)
call fini(x)
end
And one example for a dump:
__final_m_T (struct array7_t & restrict array)
{
integer(kind=8) idx;
integer(kind=8) nelem;
struct t * ptr;
{
struct array7_t * D.1977;
D.1977 = (struct array7_t *) array;
nelem = (integer(kind=8)) (integer(kind=4)) _gfortran_size0 (D.1977) + -1;
}
switch ((integer(kind=4)) array->dtype & 7)
{
default:;
{
integer(kind=8) D.1981;
D.1981 = nelem;
idx = 0;
if (idx <= D.1981)
{
while (1)
{
{
logical(kind=4) D.1991;
{
integer(kind=8) transfer.3;
integer(kind=8) D.1989;
integer(kind=8) D.1988;
static integer(kind=8) C.1987 = 0;
void * D.1986;
void * D.1985;
integer(kind=8) D.1984;
D.1985 = (void *) array->data;
D.1986 = D.1985;
D.1984 = 8;
D.1988 = 8;
__builtin_memcpy ((void *) &transfer.3, (void *) &D.1986, MAX_EXPR
<MIN_EXPR <D.1988, D.1984>, 0>);
ptr = (struct t *) (idx * 4 + transfer.3);
}
bar1 (ptr);
L.11:;
D.1991 = idx == D.1981;
idx = idx + 1;
if (D.1991) goto L.12;
}
}
}
L.12:;
}
goto L.9;
}
L.9:;
L.8:;
}
[-- Attachment #2: final-wrapper.diff --]
[-- Type: text/x-patch, Size: 31943 bytes --]
2012-08-13 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* class.c (gfc_build_class_symbol): Defer creation of the vtab
if the DT has finalizers.
(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.
2012-08-13 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@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/class.c b/gcc/fortran/class.c
index 21a91ba..b263372 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,633 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
}
+/* Call DEALLOCATE for the passed component - or if it is a nonallocatable,
+ nonpointer derived type with allocatable components, DEALLOCATE its
+ allocatable components instead.
+ Either of the two 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
+ {
+ gfc_component *c;
+
+ gcc_assert (comp->attr.alloc_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->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, false);
+ 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;
+
+ if (derived->attr.abstract)
+ {
+ vtab_final->initializer = gfc_get_null_expr (NULL);
+ return;
+ }
+
+ /* Search for the ancestor's finalizers. */
+ if (derived->attr.extension && derived->components
+ && !derived->components->ts.u.derived->attr.abstract)
+ {
+ 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
+ && !derived->components->ts.u.derived->attr.abstract)
+ continue;
+
+ if (comp->ts.type != BT_CLASS && !comp->attr.pointer
+ && (comp->attr.alloc_comp || comp->attr.allocatable))
+ 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.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->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;
+ 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;
+ 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;
+ 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;
+ 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;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+ }
+
+ gfc_get_symbol ("ignore", sub_ns, &stat);
+ stat->attr.flavor = FL_VARIABLE;
+ 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
+ && !derived->components->ts.u.derived->attr.abstract)
+ continue;
+
+ if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
+ && (comp->attr.alloc_comp || comp->attr.allocatable))
+ || (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 +1363,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];
@@ -912,6 +1544,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 681dc8d..ac776bf 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/resolve.c b/gcc/fortran/resolve.c
index c5810b2..0804a6c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11187,10 +11187,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;
}
@@ -12289,6 +12286,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. */
@@ -12309,10 +12310,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;
}
@@ -12642,11 +12639,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" }
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [EXTERNAL] [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-13 20:06 [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine Tobias Burnus
@ 2012-08-14 1:12 ` Rouson, Damian
2012-08-14 5:55 ` Tobias Burnus
2012-08-19 17:51 ` Tobias Burnus
2012-08-29 19:54 ` Tobias Burnus
2 siblings, 1 reply; 17+ messages in thread
From: Rouson, Damian @ 2012-08-14 1:12 UTC (permalink / raw)
To: Tobias Burnus, gcc patches, gfortran, Alessandro Fanfarillo
Cc: Morris, Karla NMN
Hi Tobias,
Thanks for your work on this. This is a big step. I would add to your
list the following:
(4) If the entity is of extended type and the parent type has a component
that is finalizable, the parent component's component is finalized.
In ForTrilnos, we need for this to happen even when the parent is abstract
but has a finalizable component. So far, the IBM, NAG, and Cray compilers
support this use case and we've had enough dialogue with committee members
that I'm confident it's required by the standard, although I can't cite
the specific part of the standard that requires it.
Please copy my staff member Karla Morris on any replies. Thanks again!
Damian
On 8/13/12 1:05 PM, "Tobias Burnus" <burnus@net-b.de> wrote:
>Dear all,
>
>Attached is the first part of a patch which will implement finalization
>support and polymorphic freeing in gfortran.
>
>
>It addresses two needs:
>
>a) For polymorphic ("CLASS") variables, allocatable components have to
>be freed; however, at compile time only the allocatable components of
>the declared type are known and the dynamic type might have more
>
>b) Fortran 2003 allows finalization subroutines ("FINAL", destructors),
>which can be elemental, scalar or for a given rank (any array type is
>allowed). Those should be called for DEALLOCATE, leaving the scope
>(unless saved), intrinsic assignment and with intent(out).
>
>
>The finalization is done as follows (F2008, "4.5.6.2 The finalization
>process")
>
>"(1) If the dynamic type of the entity has a final subroutine whose
>dummy argument has the same kind type parameters and rank as the entity
>being finalized, it is called with the entity as an actual argument.
>Otherwise, if there is an elemental final subroutine whose dummy
>argument has the same kind type parameters as the entity being
>finalized, it is called with the entity as an actual argument.
>Otherwise, no subroutine is called at this point.
>
>"(2) All finalizable components that appear in the type definition are
>finalized in a processor-dependent order. If the entity being finalized
>is an array, each finalizable component of each element of that entity
>is finalized separately.
>
>"(3) If the entity is of extended type and the parent type is
>finalizable, the parent component is finalized."
>
>
>The idea is to create a wrapper function which handles those steps - and
>attach a reference to the dynamic type (i.e. add it via proc-pointer to
>the vtable). Additionally, the wrapper can be directly called for TYPE.
>
>
>The attached patch implements the generation of the wrapper subroutine;
>it does not yet implement the actual calls. The wrapper is generated on
>Fortran AST level and creates code similar to
>
>subroutine final_wrapper_for_type_t (array)
>type(t), intent(inout) :: array(..)
>integer, pointer :: ptr
>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, c_ptr), ptr)
>call elemental_final (ptr)
>end do
>end select
>
>! For all noninherited allocatable components, call
>! DEALLOCATE(array(:)%comp, stat=ignore)
>! scalarized as above
>
>call final_wrapper_of_parent (array(...)%parent)
>end subroutine final_wrapper_for_type_t
>
>
>Note 1: The call to the parent type requires packing support for
>assumed-rank arrays, which has not yet been implemented (also required
>for TS29113, though not for this usage). That is, without further
>patches, the wrapper will only work for scalars or if the parent has no
>wrapper subroutine.
>
>Note 2: The next step will be to add the calls to the wrapper, starting
>with an explicit DEALLOCATE.
>
>
>I intent to commit the patch, when approved, without allowing FINAL at
>resolution time; that way there is no false impression that finalization
>actually works.
>
>Build and regtested on x86-64-gnu-linux.
>OK for the trunk?
>
>* * *
>
>Note: The patch will break gfortran's OOP ABI. It does so by adding
>"_final" to the virtual table (vtab).
>
>I think breaking the ABI for this functionality is unavoidable. The ABI
>change only affects code which uses the CLASS (polymorphic variables)
>and the issue only raises if one mixes old with new code for the same
>derived type. However, if one does so (e.g. by incomplete
>recompilation), segfaults and similar issues will occur. Hence, I am
>considering to bump the .mod version; that will effectively force a
>recompilation and thus avoid the issue. The down side is that it will
>also break packages (e.g. of Linux distributions) which ship .mod files
>(sorry!). What do you think?
>
>I think it could then be combined with Janus' proc-pointer patch, which
>changes the assembler name of (non-Bind(C)) procedure pointers, declared
>at module level. Again, by forcing recompilation, the .mod version bump
>should ensure that users don't see the ABI breakage. His patch is at
>http://gcc.gnu.org/ml/fortran/2012-04/msg00033.html (I think is okay,
>but I believe it has not yet been reviewed.)
>
>Tobias
>
>PS: I used the following test case to test whether the wrapper
>generation and scalarization works; it properly prints 11,22,33,44,55,66
>and also the dump looks okay for various versions.
>
>The scalarization code should work relatively well; there is only one
>call to an external function: For SIZE gfortran - for what ever reason -
>doesn't generate inline code, but calls libgfortran.
>
>
>But now the test code:
>
>module m
>type tt
>end type tt
>
>type t
>! type(tt), allocatable :: comp1
>integer :: val
>contains
>final bar1
>end type t
>
>type t1t
>! type(tt), allocatable :: comp1
>integer :: val
>!contains
>! final bar1
>end type t1t
>
>type, extends(t) :: t2
>type(tt), allocatable :: comp2
>contains
>final bar2
>end type t2
>
>class(t), allocatable, save :: a
>class(t2), allocatable, save :: b
>
>contains
>impure elemental subroutine bar1(x)
>! subroutine bar1(x)
>type(t), intent(inout) :: x!(:)
>print *, 'bar1, ....'
>print *, '..........', x%val
>end subroutine bar1
>subroutine bar2(y)
>type(t2),intent(inout) :: y(:,:)
>end subroutine bar2
>end
>
>use m
>use iso_c_binding
>type(t1t) ::x(3,2)
>
>interface
>subroutine fini(x) bind(C,name="__m_MOD___final_m_T")
>type(*) :: x(..)
>end subroutine
>end interface
>
>x%val = reshape([11,22,33,44,55,66],shape(x))
>print *, storage_size(x)
>call fini(x)
>end
>
>
>And one example for a dump:
>
>__final_m_T (struct array7_t & restrict array)
>{
>integer(kind=8) idx;
>integer(kind=8) nelem;
>struct t * ptr;
>
>{
>struct array7_t * D.1977;
>
>D.1977 = (struct array7_t *) array;
>nelem = (integer(kind=8)) (integer(kind=4)) _gfortran_size0 (D.1977) + -1;
>}
>switch ((integer(kind=4)) array->dtype & 7)
>{
>default:;
>{
>integer(kind=8) D.1981;
>
>D.1981 = nelem;
>idx = 0;
>if (idx <= D.1981)
>{
>while (1)
>{
>{
>logical(kind=4) D.1991;
>
>{
>integer(kind=8) transfer.3;
>integer(kind=8) D.1989;
>integer(kind=8) D.1988;
>static integer(kind=8) C.1987 = 0;
>void * D.1986;
>void * D.1985;
>integer(kind=8) D.1984;
>
>D.1985 = (void *) array->data;
>D.1986 = D.1985;
>D.1984 = 8;
>D.1988 = 8;
>__builtin_memcpy ((void *) &transfer.3, (void *) &D.1986, MAX_EXPR
><MIN_EXPR <D.1988, D.1984>, 0>);
>ptr = (struct t *) (idx * 4 + transfer.3);
>}
>bar1 (ptr);
>L.11:;
>D.1991 = idx == D.1981;
>idx = idx + 1;
>if (D.1991) goto L.12;
>}
>}
>}
>L.12:;
>}
>goto L.9;
>}
>L.9:;
>L.8:;
>}
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [EXTERNAL] [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-14 1:12 ` [EXTERNAL] " Rouson, Damian
@ 2012-08-14 5:55 ` Tobias Burnus
0 siblings, 0 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-08-14 5:55 UTC (permalink / raw)
To: Rouson, Damian
Cc: gcc patches, gfortran, Alessandro Fanfarillo, Morris, Karla NMN
Hi Damian, dear all,
Rouson, Damian wrote:
> Thanks for your work on this. This is a big step. I would add to your
> list the following:
>
> (4) If the entity is of extended type and the parent type has a component
> that is finalizable, the parent component's component is finalized.
I believe that's already covered by (3) which invokes (1) for the parent
type – and handles the parent's components via (2). (Besides, in the
standard is not much more than (1)–(3); thus, if it weren't implied by
those, it likely wouldn't be part of the standard at all.)
> In ForTrilnos, we need for this to happen even when the parent is abstract
> but has a finalizable component.
I think that's (mostly) handled via the current wrapper subroutine (i.e.
the finalizer of an allocatable component, which has been added in an
abstract type, is finalized).
However, I think there are two issues with the current patch:
(a) If an abstract type has itself finalizer, it is currently not
called. (Only its components are finalized)
(b) The current patch doesn't finalize nonallocatable [nonpointer]
components, but those might also have a finalizer.
Thanks for your comments.
Tobias
> On 8/13/12 1:05 PM, "Tobias Burnus" <burnus@net-b.de> wrote:
>> The finalization is done as follows (F2008, "4.5.6.2 The finalization
>> process")
>>
>> "(1) If the dynamic type of the entity has a final subroutine whose
>> dummy argument has the same kind type parameters and rank as the entity
>> being finalized, it is called with the entity as an actual argument.
>> Otherwise, if there is an elemental final subroutine whose dummy
>> argument has the same kind type parameters as the entity being
>> finalized, it is called with the entity as an actual argument.
>> Otherwise, no subroutine is called at this point.
>>
>> "(2) All finalizable components that appear in the type definition are
>> finalized in a processor-dependent order. If the entity being finalized
>> is an array, each finalizable component of each element of that entity
>> is finalized separately.
>>
>> "(3) If the entity is of extended type and the parent type is
>> finalizable, the parent component is finalized."
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-13 20:06 [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine Tobias Burnus
2012-08-14 1:12 ` [EXTERNAL] " Rouson, Damian
@ 2012-08-19 17:51 ` Tobias Burnus
2012-08-23 5:52 ` Tobias Burnus
` (2 more replies)
2012-08-29 19:54 ` Tobias Burnus
2 siblings, 3 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-08-19 17:51 UTC (permalink / raw)
To: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
[-- Attachment #1: Type: text/plain, Size: 603 bytes --]
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
[-- Attachment #2: final-wrapper-v2.diff --]
[-- Type: text/x-patch, Size: 39897 bytes --]
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
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-19 17:51 ` Tobias Burnus
@ 2012-08-23 5:52 ` Tobias Burnus
2012-08-24 15:01 ` Alessandro Fanfarillo
2012-08-25 13:48 ` Mikael Morin
2 siblings, 0 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-08-23 5:52 UTC (permalink / raw)
To: fortran, gcc patches
* PING *
On August 19, 2012, Tobias Burnus wrote:
> 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
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-19 17:51 ` Tobias Burnus
2012-08-23 5:52 ` Tobias Burnus
@ 2012-08-24 15:01 ` Alessandro Fanfarillo
2012-08-24 19:03 ` Tobias Burnus
2012-08-25 13:48 ` Mikael Morin
2 siblings, 1 reply; 17+ messages in thread
From: Alessandro Fanfarillo @ 2012-08-24 15:01 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran, Rouson, Damian
[-- Attachment #1: Type: text/plain, Size: 963 bytes --]
Dear Tobias,
there are some problems with the final-wrapper-v2.diff patch; I get
the following error
final2.f90:71.15:
end module test
1
Internal Error at (1):
gfc_code2string(): Bad code
for every test case that I use; in attachment final2.f90.
Regards
Alessandro
2012/8/19 Tobias Burnus <burnus@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
--
[-- Attachment #2: final2.f90 --]
[-- Type: application/octet-stream, Size: 1600 bytes --]
module test
type t
contains
final :: final_scalar_t,finalizer1,finalizer2,finalizer3
end type t
type, extends(t) :: t1
contains
final :: final_scalar_t1
end type t1
type a1
integer :: i
contains
final :: finalizer_a1
end type a1
type a2
integer :: k
contains
final :: finalizer_a2
end type a2
type, extends(t1) :: t2
type(a1) :: aaa
type(a2) :: aaa2
class(t), allocatable :: ttt
contains
final :: final_scalar, finalizer1t2
end type t2
contains
subroutine finalizer_a1(aa)
type(a1), intent(in) :: aa
write(*,*) 'A1 - i='
end subroutine finalizer_a1
subroutine finalizer_a2(aa)
type(a2), intent(in) :: aa
write(*,*) 'A2 - k='
end subroutine finalizer_a2
subroutine final_scalar(t0)
type(t2),intent(in) :: t0
write(*,*) 'rank 0'
end subroutine final_scalar
subroutine final_scalar_t(t0)
type(t), intent(in) :: t0
write(*,*) 'rank 00'
end subroutine final_scalar_t
subroutine final_scalar_t1(t0)
type(t1), intent(in) :: t0
write(*,*) 'rank 0 su t1'
end subroutine final_scalar_t1
subroutine finalizer1(t1)
type(t) :: t1(:)
write(*,*) 'rank 1'
end subroutine finalizer1
subroutine finalizer1t2(tt2)
type(t2) :: tt2(:)
write(*,*) 'rank 1 t2'
end subroutine finalizer1t2
subroutine finalizer2(t2)
type(t) :: t2(:,:)
write(*,*) 'rank 2'
end subroutine finalizer2
subroutine finalizer3(t3)
type(t) :: t3(:,:,:)
write(*,*) 'rank 3'
end subroutine finalizer3
end module test
use test
implicit none
class(t), allocatable :: tt
allocate(t2 :: tt)
select type (tt)
type is (t2)
allocate(tt%ttt)
end select
deallocate(tt)
end
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-24 15:01 ` Alessandro Fanfarillo
@ 2012-08-24 19:03 ` Tobias Burnus
0 siblings, 0 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-08-24 19:03 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: gcc patches, gfortran, Rouson, Damian
[-- Attachment #1: Type: text/plain, Size: 573 bytes --]
Dear Alessandro,
Alessandro Fanfarillo wrote:
> there are some problems with the final-wrapper-v2.diff patch; I get
> Internal Error at (1):
> gfc_code2string(): Bad code
> for every test case that I use; in attachment final2.f90.
Fixed by the patch below. However, note that the current patch only
implement the wrapper function - it doesn't handle calling the wrapper
function. That's requires a follow up patch. (That was the reason that I
did not do extensive test.)
The patch is a complete module.c patch, not incrementally based on the
previous patch.
Tobias
[-- Attachment #2: final-module-fix.diff --]
[-- Type: text/x-patch, Size: 2750 bytes --]
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a4ff199..3e636cd 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1840,17 +1840,18 @@ 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,
- 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),
@@ -1883,6 +1884,7 @@ static const mstring attr_bits[] =
minit ("VALUE", AB_VALUE),
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
+ minit ("FINAL_COMP", AB_FINAL_COMP),
minit ("LOCK_COMP", AB_LOCK_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
@@ -1975,6 +1977,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)
@@ -2057,6 +2061,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)
@@ -2090,6 +2096,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;
@@ -2198,6 +2207,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;
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-19 17:51 ` Tobias Burnus
2012-08-23 5:52 ` Tobias Burnus
2012-08-24 15:01 ` Alessandro Fanfarillo
@ 2012-08-25 13:48 ` Mikael Morin
2012-08-25 15:21 ` Tobias Burnus
2 siblings, 1 reply; 17+ messages in thread
From: Mikael Morin @ 2012-08-25 13:48 UTC (permalink / raw)
To: Tobias Burnus
Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
On 19/08/2012 19:50, Tobias Burnus wrote:
> 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
Hello,
some general comment:
the patch mixes deallocation and finalization, which are treated
separately in the standard. I don' know at this point whether it will
make our life really tougher or not, but I think it makes the code
slightly more difficult to read.
I have a mixed general feeling about the patch that
1. some weird cases are not correctly covered (polymorphic components,
multiple level of finalizable and/or non-finalizable components, of
inheritance, ...)
2. some of the above "incorrectnesses" may actually cancel each other;
the patch is implemented differently than how I thought it would be. I
may be missing the point after all.
I would like to point out that forcing the wrapper's array argument to
be contiguous will lead to poor code as repacking will be needed with
inherited types to call the parent's wrapper (and the parent's parent's,
etc...).
More specific comments below.
Mikael
> 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
> @@ -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 ();
You should walk to the end of the reference chain. Otherwise you are
overwriting it here. Unless you avoid recursing, in which case you can
assert it was NULL.
> + 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)
What about polymorphic components?
What if only comp's subcomponents are finalizable, the finalization
wrapper should still be called, shouldn't it?
> + {
> + /* 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);
> + }
This doesn't work, you use comp instead of c.
If there is a polymorphic component whose declared type is not
finalizable, but whose actual type is, the finalization wrapper should
still be called. So basically one can't just look at the components.
If comp has finalizable subcomponents, it has a finalization wrapper,
which is (or should be) caught above, so this branch is (or should be)
unreachable.
> +}
> +
> +
> +/* 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");
This is useless...
> + gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
... if followed by this. Or maybe you want to assert that symtree is
NULL in between?
[...]
> +
> +
> +/* 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;
This is misnamed, it should be final_comp or something.
> + 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')
I have no strong opinion about it, but slightly prefer strcmp (...,
"_final") with regard to readability, and solidity against future vtab
extensions with methods starting with "_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
shouldn't there be `&& !derived->attr.final_comp' also?
> + && (!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;
Shouldn't one assume without condition that there are allocatable or
finalizable subcomponents when there is a polymorphic component?
Same further below.
> + }
> +
> + /* 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);
I think a reference to the parent component is missing.
> + }
> +
> + 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
> 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->attr.final_comp is never set.
I would like to avoid if possible yet another symbol attribute set in
three different functions in three different files and used all over the
place. What about using a function "calculating" the predicate this time?
> + || (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
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-25 13:48 ` Mikael Morin
@ 2012-08-25 15:21 ` Tobias Burnus
2012-08-25 19:20 ` Mikael Morin
0 siblings, 1 reply; 17+ messages in thread
From: Tobias Burnus @ 2012-08-25 15:21 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
Dear Mikael, dear all,
Mikael Morin wrote:
> the patch mixes deallocation and finalization, which are treated
> separately in the standard.
First, I want to remark that the standard - in many cases - does not
require memory freeing ("deallocation"), it "merely" makes it possible
that one does not leak memory with allocatables. The actually freeing of
the memory is just a matter of the qualify of the implementation.
Secondly, for a polymorphic type, one does not know at compile time
whether it has allocatable components or not - nor whether it has a
finalizer or not. Hence, I do not see another possibility to have a
common _free/_final entry point in the vtable. As there has to be a
common entry point, I think it makes sense to have a single finalization
wrapper which handles both. (I had also initially thought, that one
could handle those two cases separately, but now I don't see it anymore.)
> 1. some weird cases are not correctly covered (polymorphic components,
> multiple level of finalizable and/or non-finalizable components, of
> inheritance, ...)
I do believe that polymorphic components are correctly handled: If they
are a POINTER, they are untouched but if they are ALLOCATABLE, one calls
DEALLOCATE for the component, which should handle the
finalization/deallocation correctly. (And nonallocatble, nonpointer
components do not exist.)
> I would like to point out that forcing the wrapper's array argument to
> be contiguous will lead to poor code as repacking will be needed with
> inherited types to call the parent's wrapper (and the parent's parent's,
> etc...).
I think that's unavoidable with the current array descriptor, which
assumes that the stride is always a multiple of the size of the type. I
concur that with the new array descriptor, one restrict the
copy-in/copy-out to calling explict-shape/assumed-size finalizers, which
probably do not occur in practice.
> >+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
> >+ e = gfc_copy_expr (expr);
> >+ e->ref = gfc_get_ref ();
> You should walk to the end of the reference chain. Otherwise you are
> overwriting it here.
I will do this.
>> >+ if (comp->attr.allocatable
>> >+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
>> >+ && CLASS_DATA (comp)->attr.allocatable))
>> >+ {
>>
>> >+ }
>> >+ else if (comp->ts.type == BT_DERIVED
>> >+ && comp->ts.u.derived->f2k_derived
>> >+ && comp->ts.u.derived->f2k_derived->finalizers)
> What about polymorphic components?
I have to admit that the code is a bit implicit: polymorphic components
are either ALLOCATABLE - and hence handled in the "if" block, or they
are pointers - in which case this function is not called at all.
> What if only comp's subcomponents are finalizable, the finalization
> wrapper should still be called, shouldn't it?
Well, that's handled in the "else" branch. There, I walk all
subcomponents. I do not need to walk them in case there is a finalizer
as the called finalization wrapper will handle them.
>> >+ 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);
>> >+ }
> This doesn't work, you use comp instead of c.
I hate copy-and-paste bugs. Thanks.
> If there is a polymorphic component whose declared type is not
> finalizable, but whose actual type is, the finalization wrapper should
> still be called.
But it will, as written above, polymorphic components are allocatable
(or they are pointers and won't get finalized).
> If comp has finalizable subcomponents, it has a finalization wrapper,
> which is (or should be) caught above, so this branch is (or should be)
> unreachable.
I probably miss something, but I don't see why this branch should be
unreachable. One has:
if (component is allocatable)
call DEALLOCATE(comp) ! which might invoke finalizers
else if (component itself has a finalizer)
call FINAL_WRAPPER
else
for all nonpointer subcomponents which are allocatables, have
finalizers or have allocatable/finalizable components, call
finalize_component.
end if
>> >+ block->symtree = gfc_find_symtree (sub_ns->sym_root, "c_f_pointer");
> This is useless...
I concur.
>> >+ bool alloc_comp = false;
> This is misnamed, it should be final_comp or something.
I concur, its use became extended during the development of the patch.
>
>> >+ for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
>> >+ if (comp->name[0] == '_' && comp->name[1] == 'f')
> I have no strong opinion about it, but slightly prefer strcmp (...,
> "_final") with regard to readability, and solidity against future vtab
> extensions with methods starting with "_f".
Maybe. "_" && "f" should be faster and I don't see us adding more vtable
functions. on the other hand, strcmp is safer and clearer. I also don't
have a strong opinion about that.
>
>> >+ {
>> >+ 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
> shouldn't there be `&& !derived->attr.final_comp' also?
I concur; I forgot that line when I retrofitted the case that there is a
finalizer but no allocatable componet.
>> >+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
>> >+ && CLASS_DATA (comp)->attr.allocatable)
>> >+ alloc_comp = true;
> Shouldn't one assume without condition that there are allocatable or
> finalizable subcomponents when there is a polymorphic component?
Well, we do not deallocate/finalize polymorphic POINTER components.
>> >+ 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);
> I think a reference to the parent component is missing.
Actually, for a scalar it does not matter and for nonscalars, I still
need to write the pack/unpack support. For the latter, I am not yet sure
how to handle it best. As the Fortran standard doesn't allow
"assumed_rank%comp", this case has to be handled in some special way.
>> >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->attr.final_comp is never set.
>
> I would like to avoid if possible yet another symbol attribute set in
> three different functions in three different files and used all over the
> place. What about using a function "calculating" the predicate this time?
Maybe, however, one has then to call the function a lot of times: In
generate_finalization_wrapper for the whole type, then for the new added
components, and then for each component in finalize_component. With the
current code, the latter has a complexity of approx. O(n lg n), but one
might be able to improve it a bit by restructuring the code. (On the
other hand, "n" is probably not excessively large.)
Tobias
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-25 15:21 ` Tobias Burnus
@ 2012-08-25 19:20 ` Mikael Morin
2012-08-25 20:07 ` Tobias Burnus
0 siblings, 1 reply; 17+ messages in thread
From: Mikael Morin @ 2012-08-25 19:20 UTC (permalink / raw)
To: Tobias Burnus
Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
On 25/08/2012 17:21, Tobias Burnus wrote:
> (And nonallocatble, nonpointer
> components do not exist.)
I missed that indeed.
>> What if only comp's subcomponents are finalizable, the finalization
>> wrapper should still be called, shouldn't it?
>
> Well, that's handled in the "else" branch. There, I walk all
> subcomponents. I do not need to walk them in case there is a finalizer
> as the called finalization wrapper will handle them.
Actually, I don't understand why you walk twice over the subcomponents:
in the else branch here and in the finalizer.
>> If comp has finalizable subcomponents, it has a finalization wrapper,
>> which is (or should be) caught above, so this branch is (or should be)
>> unreachable.
>
> I probably miss something, but I don't see why this branch should be
> unreachable. One has:
>
> if (component is allocatable)
> call DEALLOCATE(comp) ! which might invoke finalizers
> else if (component itself has a finalizer)
> call FINAL_WRAPPER
> else
> for all nonpointer subcomponents which are allocatables, have
> finalizers or have allocatable/finalizable components, call
> finalize_component.
> end if
I expected something like:
if (allocatable)
call deallocate (comp)
else if (finalizer or subcomponents have a finalizer)
call FINAL_WRAPPER
As said above, I don't understand why you would walk over the components
twice
>>> >+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
>>> >+ && CLASS_DATA (comp)->attr.allocatable)
>>> >+ alloc_comp = true;
>> Shouldn't one assume without condition that there are allocatable or
>> finalizable subcomponents when there is a polymorphic component?
>
> Well, we do not deallocate/finalize polymorphic POINTER components.
Indeed, then I prefer having !CLASS_DATA(comp)->attr.pointer.
>>> >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->attr.final_comp is never set.
>>
>> I would like to avoid if possible yet another symbol attribute set in
>> three different functions in three different files and used all over the
>> place. What about using a function "calculating" the predicate this
>> time?
>
> Maybe, however, one has then to call the function a lot of times: In
> generate_finalization_wrapper for the whole type, then for the new added
> components, and then for each component in finalize_component. With the
> current code, the latter has a complexity of approx. O(n lg n), but one
> might be able to improve it a bit by restructuring the code. (On the
> other hand, "n" is probably not excessively large.)
>
If performance is a problem, the function could use the flag as a
backend. As long as the field is used and set in a single place, I
don't mind. I don't have a strong opinion either, there is already a
full bag of flags; one more wouldn't make things dramatically worse.
Mikael
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-25 19:20 ` Mikael Morin
@ 2012-08-25 20:07 ` Tobias Burnus
2012-08-25 20:45 ` Mikael Morin
0 siblings, 1 reply; 17+ messages in thread
From: Tobias Burnus @ 2012-08-25 20:07 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
Mikael Morin wrote:
>>> What if only comp's subcomponents are finalizable, the finalization
>>> wrapper should still be called, shouldn't it?
>> Well, that's handled in the "else" branch. There, I walk all
>> subcomponents. I do not need to walk them in case there is a finalizer
>> as the called finalization wrapper will handle them.
> Actually, I don't understand why you walk twice over the subcomponents:
> in the else branch here and in the finalizer.
Well, I only walk once per component. However, I could unconditionally
call this function – and move some of the checks from the main program here.
>>> If comp has finalizable subcomponents, it has a finalization wrapper,
>>> which is (or should be) caught above, so this branch is (or should be)
>>> unreachable.
>> I probably miss something, but I don't see why this branch should be
>> unreachable. One has:
>>
>> if (component is allocatable)
>> call DEALLOCATE(comp) ! which might invoke finalizers
>> else if (component itself has a finalizer)
>> call FINAL_WRAPPER
>> else
>> for all nonpointer subcomponents which are allocatables, have
>> finalizers or have allocatable/finalizable components, call
>> finalize_component.
>> end if
> I expected something like:
> if (allocatable)
> call deallocate (comp)
> else if (finalizer or subcomponents have a finalizer)
> call FINAL_WRAPPER
Well, the question is whether one wants to call a finalize wrapper for a
simple "comp%alloctable_int(10)" or not. In the current scheme, I tried
to avoid calling a finalizer wrapper for simple allocatable components.
Thus, one has the choice:
a) Directly call DEALLOCATE for alloctable components of subcomponents
b) Always call the finalizer wrapper – also for nonalloctable TYPEs
(with finalizable/allocatable components)
(a) is more direct and possibly a bit faster while (b) makes the wrapper
function a tad smaller.
> As said above, I don't understand why you would walk over the components
> twice
I don't. I touch every ((sub)sub)component only once; I only do a deep
walk until there is either no component or a pointer or an allocatable
or a finalizable component. I do acknowledge that I repeat some of the
logic by handling the outer component in the wrapper and the inner
(sub)subcomponents in the final_components.
>>>>> + else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
>>>>> + && CLASS_DATA (comp)->attr.allocatable)
>>>>> + alloc_comp = true;
>>> Shouldn't one assume without condition that there are allocatable or
>>> finalizable subcomponents when there is a polymorphic component?
>> Well, we do not deallocate/finalize polymorphic POINTER components.
> Indeed, then I prefer having !CLASS_DATA(comp)->attr.pointer.
Okay, that's equivalent; though, I have to admit that I prefer the
current version, which I regard as cleaner.
* * *
Regarding the flag or nonflag final_comp, I have to admit that I still
do not completely understand how you would implement it.
One option would be something like the following
bool has_final_comp(derived) {
for (comp = derived->components; comp; comp = comp->next)
{
if (comp->attr.pointer)
continue;
if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
return true;
if (comp->ts.type == BT_DERIVED
&& has_final_comp(comp->ts.u.derived))
return true;
}
return false
}
in class.c
Another is the version which gets set in parse.c.
However, I do not understand what you mean by:
> If performance is a problem, the function could use the flag as a
> backend. As long as the field is used and set in a single place, I
> don't mind. I don't have a strong opinion either, there is already a
> full bag of flags; one more wouldn't make things dramatically worse.
Tobias
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-25 20:07 ` Tobias Burnus
@ 2012-08-25 20:45 ` Mikael Morin
2012-08-27 18:21 ` [EXTERNAL] " Rouson, Damian
0 siblings, 1 reply; 17+ messages in thread
From: Mikael Morin @ 2012-08-25 20:45 UTC (permalink / raw)
To: Tobias Burnus
Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
On 25/08/2012 22:06, Tobias Burnus wrote:
>>>> If comp has finalizable subcomponents, it has a finalization
>>>> wrapper, which is (or should be) caught above, so this branch
>>>> is (or should be) unreachable.
>>> I probably miss something, but I don't see why this branch should
>>> be unreachable. One has:
>>>
>>> if (component is allocatable) call DEALLOCATE(comp) ! which might
>>> invoke finalizers else if (component itself has a finalizer) call
>>> FINAL_WRAPPER else for all nonpointer subcomponents which are
>>> allocatables, have finalizers or have allocatable/finalizable
>>> components, call finalize_component. end if
>> I expected something like: if (allocatable) call deallocate (comp)
>> else if (finalizer or subcomponents have a finalizer) call
>> FINAL_WRAPPER
>
> Well, the question is whether one wants to call a finalize wrapper
> for a simple "comp%alloctable_int(10)" or not. In the current scheme,
> I tried to avoid calling a finalizer wrapper for simple allocatable
> components.
>
> Thus, one has the choice: a) Directly call DEALLOCATE for alloctable
> components of subcomponents b) Always call the finalizer wrapper –
> also for nonalloctable TYPEs (with finalizable/allocatable
> components)
>
> (a) is more direct and possibly a bit faster while (b) makes the
> wrapper function a tad smaller.
OK, this is a deliberate choice of implementation to avoid call
overhead. I slightly prefer (b), but we can keep (a).
I'm fine with (a) if the code walking the components is shared - which
avoids c vs. comp issues by the way ;-) .
> * * *
>
> Regarding the flag or nonflag final_comp, I have to admit that I
> still do not completely understand how you would implement it.
>
> One option would be something like the following
>
> bool has_final_comp(derived) { for (comp = derived->components; comp;
> comp = comp->next) { if (comp->attr.pointer) continue; if
> (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS) return
> true; if (comp->ts.type == BT_DERIVED &&
> has_final_comp(comp->ts.u.derived)) return true; } return false }
This was my initial proposition. The benefit is it is very clear how it
works compared to manual setting the flag here and there.
As you raised a performance issue, I proposed something like this:
bool has_final_comp(derived) {
bool retval = false;
if (derived->cache.final_comp_set)
return derived->cache.final_comp;
for (comp = derived->components; comp; comp = comp->next)
{
if (comp->attr.pointer)
continue;
if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
{
retval = true;
break;
}
if (comp->ts.type == BT_DERIVED
&& has_final_comp(comp->ts.u.derived))
{
retval = true;
break;
}
}
derived->cache.final_comp_set = 1;
derived->cache.final_comp = retval;
return retval;
}
It's no big deal anyway.
I dream of a compiler where all the non-standard symbol attribute flags,
expression rank and typespec, etc, would be implemented like this... No
need for resolution, etc; it would just work everywhere.
I know the story, patches welcome; they may come, one day...
Mikael
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [EXTERNAL] Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-25 20:45 ` Mikael Morin
@ 2012-08-27 18:21 ` Rouson, Damian
2012-08-27 18:51 ` Mikael Morin
0 siblings, 1 reply; 17+ messages in thread
From: Rouson, Damian @ 2012-08-27 18:21 UTC (permalink / raw)
To: Mikael Morin, Tobias Burnus; +Cc: gcc patches, gfortran, Alessandro Fanfarillo
Hi Mikael,
Is this patch approved? I realize it's not the final step (no pun
intended), but I will be very excited to see this hit the trunk.
Supporting FINAL will have broad impact on my work and the work of others
writing modern Fortran libraries and applications.
Damian
On 8/25/12 1:42 PM, "Mikael Morin" <mikael.morin@sfr.fr> wrote:
>On 25/08/2012 22:06, Tobias Burnus wrote:
>>>>> If comp has finalizable subcomponents, it has a finalization
>>>>> wrapper, which is (or should be) caught above, so this branch
>>>>> is (or should be) unreachable.
>>>> I probably miss something, but I don't see why this branch should
>>>> be unreachable. One has:
>>>>
>>>> if (component is allocatable) call DEALLOCATE(comp) ! which might
>>>> invoke finalizers else if (component itself has a finalizer) call
>>>> FINAL_WRAPPER else for all nonpointer subcomponents which are
>>>> allocatables, have finalizers or have allocatable/finalizable
>>>> components, call finalize_component. end if
>>> I expected something like: if (allocatable) call deallocate (comp)
>>> else if (finalizer or subcomponents have a finalizer) call
>>> FINAL_WRAPPER
>>
>> Well, the question is whether one wants to call a finalize wrapper
>> for a simple "comp%alloctable_int(10)" or not. In the current scheme,
>> I tried to avoid calling a finalizer wrapper for simple allocatable
>> components.
>>
>> Thus, one has the choice: a) Directly call DEALLOCATE for alloctable
>> components of subcomponents b) Always call the finalizer wrapper
>> also for nonalloctable TYPEs (with finalizable/allocatable
>> components)
>>
>> (a) is more direct and possibly a bit faster while (b) makes the
>> wrapper function a tad smaller.
>OK, this is a deliberate choice of implementation to avoid call
>overhead. I slightly prefer (b), but we can keep (a).
>I'm fine with (a) if the code walking the components is shared - which
>avoids c vs. comp issues by the way ;-) .
>
>> * * *
>>
>> Regarding the flag or nonflag final_comp, I have to admit that I
>> still do not completely understand how you would implement it.
>>
>> One option would be something like the following
>>
>> bool has_final_comp(derived) { for (comp = derived->components; comp;
>> comp = comp->next) { if (comp->attr.pointer) continue; if
>> (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS) return
>> true; if (comp->ts.type == BT_DERIVED &&
>> has_final_comp(comp->ts.u.derived)) return true; } return false }
>This was my initial proposition. The benefit is it is very clear how it
>works compared to manual setting the flag here and there.
>As you raised a performance issue, I proposed something like this:
>
>bool has_final_comp(derived) {
> bool retval = false;
>
> if (derived->cache.final_comp_set)
> return derived->cache.final_comp;
>
> for (comp = derived->components; comp; comp = comp->next)
> {
> if (comp->attr.pointer)
> continue;
> if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
> {
> retval = true;
> break;
> }
> if (comp->ts.type == BT_DERIVED
> && has_final_comp(comp->ts.u.derived))
> {
> retval = true;
> break;
> }
> }
> derived->cache.final_comp_set = 1;
> derived->cache.final_comp = retval;
> return retval;
>}
>
>It's no big deal anyway.
>I dream of a compiler where all the non-standard symbol attribute flags,
>expression rank and typespec, etc, would be implemented like this... No
>need for resolution, etc; it would just work everywhere.
>I know the story, patches welcome; they may come, one day...
>
>Mikael
>
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [EXTERNAL] Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-27 18:21 ` [EXTERNAL] " Rouson, Damian
@ 2012-08-27 18:51 ` Mikael Morin
0 siblings, 0 replies; 17+ messages in thread
From: Mikael Morin @ 2012-08-27 18:51 UTC (permalink / raw)
To: Rouson, Damian
Cc: Tobias Burnus, gcc patches, gfortran, Alessandro Fanfarillo
On 27/08/2012 20:20, Rouson, Damian wrote:
> Hi Mikael,
>
> Is this patch approved?
There are a few overlooks to be fixed and the components walking code
that I would like to see shared.
Then I think it can go in. But there is no big stopper.
Mikael
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-13 20:06 [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine Tobias Burnus
2012-08-14 1:12 ` [EXTERNAL] " Rouson, Damian
2012-08-19 17:51 ` Tobias Burnus
@ 2012-08-29 19:54 ` Tobias Burnus
2012-09-01 21:19 ` Mikael Morin
2 siblings, 1 reply; 17+ messages in thread
From: Tobias Burnus @ 2012-08-29 19:54 UTC (permalink / raw)
To: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian,
Mikael Morin
[-- Attachment #1: Type: text/plain, Size: 1666 bytes --]
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.
[-- Attachment #2: final-wrapper-v3-1.diff --]
[-- Type: text/x-patch, Size: 35009 bytes --]
2012-08-29 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@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 <burnus@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;
}
[-- Attachment #3: final-wrapper-v3-2.diff --]
[-- Type: text/x-patch, Size: 4233 bytes --]
2012-08-29 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* resolve.c (gfc_resolve_finalizers): Remove not-implemented
error.
2012-08-29 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@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" }
[-- Attachment #4: final-wrapper-v3-3ab.diff --]
[-- Type: text/x-patch, Size: 1727 bytes --]
-------------------------------------------------------
NOTE: Only one of the two patchlets should be committed
not both!
-------------------------------------------------------
2012-08-19 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Tobias Burnus <burnus@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. */
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-08-29 19:54 ` Tobias Burnus
@ 2012-09-01 21:19 ` Mikael Morin
2012-09-03 6:45 ` Tobias Burnus
0 siblings, 1 reply; 17+ messages in thread
From: Mikael Morin @ 2012-09-01 21:19 UTC (permalink / raw)
To: Tobias Burnus
Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
On 29/08/2012 21:53, Tobias Burnus wrote:
> 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.
A few more nitpicks below.
>
> b) A patch which removes the gfc_error "not yet implemented"
> I suggest to only remove the error after finalization calls have been
> added
Sensible. By the way some (testsuite) parts of b) should be part of a).
>
> 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).
I don't like bumping the module version, for something not
module-related (vtypes are output as normal types in the module files),
but I guess it is the most user-friendly thing to do.
>
> 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.
Let's keep things simple, let's not do that.
>
>
> 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.)
I am inclined to disable finalization completely (thus defer .mod bump),
because the new code is hardly tested and doesn't provide (yet) new
benefits such as reduced memory leaks as it is disabled.
We could do the bump now, but I'm afraid that we discover a bug when
finalization gets completely implemented, and we have to bump again to
fix it (though I don't see what kind of bug it could be).
I think Janus' patch is a much less serious problem in the sense that
people trying to link codes compiled with patched and non-patched
compiler will get a link error. I don't think it's worth a .mod bump.
Unless I miss something.
For (a), I noticed a few indenting issues (8+ spaces) and (mostly
wording) nits below to be fixed. Then OK.
> 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
> @@ -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)
Rename to has_finalizable_component ?
> +{
> + 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
s/finalizes/finalizable/ ?
> + them. Either of the is required; other nonallocatables and pointers aren't
s/the/them/ ?
> + handled gracefully.
> + Note: The DEALLOCATE handling takes care of finalizers, coarray
> + deregistering and allocatable components of the allocatable. */
"coarray deregistering and allocatable components" is confusing.
Note: If the component is allocatable, the DEALLOCATE handling takes
care of calling the appropriate finalizer(s), of coarray deregistering,
and of deallocating allocatable (sub)components.
> +
> +static void
> +finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
> + gfc_expr *stat, gfc_code **code)
[...]
> +
> +
> +/* Generate the wrapper finalization/polymorphic freeing subroutine for the
Difficult to read.
"Generate the finalization/polymorphic freeing wrapper subroutine..." or
something ?
> + 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
s/It calls/Call/ ? (to be in line with the other verbs).
> + 2. In a loop over all noninherited allocatable components and noninherited
s/In a loop/Loop/
> + 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. */
> +
Thanks.
Mikael
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine
2012-09-01 21:19 ` Mikael Morin
@ 2012-09-03 6:45 ` Tobias Burnus
0 siblings, 0 replies; 17+ messages in thread
From: Tobias Burnus @ 2012-09-03 6:45 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran, Alessandro Fanfarillo, Rouson, Damian
Mikael Morin wrote:
> On 29/08/2012 21:53, Tobias Burnus wrote:
>> a) The main patch, which implements the wrapper.
>> I am asking for approval for that patch.
> A few more nitpicks below.
>
>> 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).
> I don't like bumping the module version, for something not
> module-related (vtypes are output as normal types in the module files),
> but I guess it is the most user-friendly thing to do.
I also do not like it - but it might otherwise lead to segfaults at run
time (or the wrong procedure being called), which is even uglier.
>> 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.)
> I am inclined to disable finalization completely (thus defer .mod bump),
> because the new code is hardly tested and doesn't provide (yet) new
> benefits such as reduced memory leaks as it is disabled.
> We could do the bump now, but I'm afraid that we discover a bug when
> finalization gets completely implemented, and we have to bump again to
> fix it (though I don't see what kind of bug it could be).
I concur.
> I think Janus' patch is a much less serious problem in the sense that
> people trying to link codes compiled with patched and non-patched
> compiler will get a link error. I don't think it's worth a .mod bump.
Well, the idea was: If we do bump the .mod for this patch, having around
that time Janus' patch (which also breaks the ABI) makes sense. I concur
that his ABI breakage is less severe.
> For (a), I noticed a few indenting issues (8+ spaces) and (mostly
> wording) nits below to be fixed. Then OK.
Fixed.
>> +/* 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)
> Rename to has_finalizable_component ?
I prefer finalizer because also allocatable components are finalizable
but they are excluded by this check.
>> +/* 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
> s/finalizes/finalizable/ ?
Actually: with allocatable components or has finalizers.
>> + them. Either of the is required; other nonallocatables and pointers aren't
> s/the/them/ ?
done.
>> + handled gracefully.
>> + Note: The DEALLOCATE handling takes care of finalizers, coarray
>> + deregistering and allocatable components of the allocatable. */
> "coarray deregistering and allocatable components" is confusing.
>
> Note: If the component is allocatable, the DEALLOCATE handling takes
> care of calling the appropriate finalizer(s), of coarray deregistering,
> and of deallocating allocatable (sub)components.
Done.
>> +/* Generate the wrapper finalization/polymorphic freeing subroutine for the
> Difficult to read.
> "Generate the finalization/polymorphic freeing wrapper subroutine..." or
> something ?
Done.
>> + /* We now create a wrapper, which does the following:
>> + 1. It calls the suitable finalization subroutine for this type
> s/It calls/Call/ ? (to be in line with the other verbs).
>> + 2. In a loop over all noninherited allocatable components and noninherited
> s/In a loop/Loop/
Done.
Thanks for the review. I have no committed it as Rev. 190869
Tobias
^ permalink raw reply [flat|nested] 17+ messages in thread
end of thread, other threads:[~2012-09-03 6:45 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-08-13 20:06 [Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine Tobias Burnus
2012-08-14 1:12 ` [EXTERNAL] " Rouson, Damian
2012-08-14 5:55 ` Tobias Burnus
2012-08-19 17:51 ` Tobias Burnus
2012-08-23 5:52 ` Tobias Burnus
2012-08-24 15:01 ` Alessandro Fanfarillo
2012-08-24 19:03 ` Tobias Burnus
2012-08-25 13:48 ` Mikael Morin
2012-08-25 15:21 ` Tobias Burnus
2012-08-25 19:20 ` Mikael Morin
2012-08-25 20:07 ` Tobias Burnus
2012-08-25 20:45 ` Mikael Morin
2012-08-27 18:21 ` [EXTERNAL] " Rouson, Damian
2012-08-27 18:51 ` Mikael Morin
2012-08-29 19:54 ` Tobias Burnus
2012-09-01 21:19 ` Mikael Morin
2012-09-03 6:45 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).