OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/37336 ([F03] Finish derived-type finalization)

Browse Source 
2013-06-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/37336
        * trans.h (gfc_build_final_call): Remove prototype.
        (gfc_add_finalizer_call): Add prototype.
        * trans-array.c (gfc_trans_dealloc_allocated): Support
        * finalization.
        (structure_alloc_comps): Update caller.
        (gfc_trans_deferred_array): Call finalizer.
        * trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
        * trans-decl.c (gfc_trans_deferred_vars): Don't
        * deallocate/finalize
        variables of the main program.
        * trans-expr.c (gfc_conv_procedure_call): Support finalization.
        * trans-openmp.c (gfc_omp_clause_dtor,
        gfc_trans_omp_array_reduction): Update calls.
        * trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
        of alloc components.
        * trans.c (gfc_add_finalizer_call): New function.
        (gfc_deallocate_with_status,
        gfc_deallocate_scalar_with_status): Call it
        (gfc_build_final_call): Fix handling of scalar coarrays,
        move up in the file and make static.

2013-06-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/37336
        * gfortran.dg/finalize_12.f90: New.
        * gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for
        end of scope finalization.
        * gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
        * gfortran.dg/allocatable_scalar_9.f90: Ditto.
        * gfortran.dg/auto_dealloc_2.f90: Ditto.
        * gfortran.dg/class_19.f03: Ditto.
        * gfortran.dg/coarray_lib_alloc_1.f90: Ditto.
        * gfortran.dg/coarray_lib_alloc_2.f90: Ditto.
        * gfortran.dg/extends_14.f03: Ditto.
        * gfortran.dg/move_alloc_4.f90: Ditto.
        * gfortran.dg/typebound_proc_27.f03: Ditto.

From-SVN: r199643
This commit is contained in:
Tobias Burnus 2013-06-04 12:20:32 +02:00
parent aadaf24ef0
commit ef2925370e
23 changed files with 869 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/fortran/ChangeLog
View File

@ -1,3 +1,25 @@
2013-06-04 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans.h (gfc_build_final_call): Remove prototype.
(gfc_add_finalizer_call): Add prototype.
* trans-array.c (gfc_trans_dealloc_allocated): Support finalization.
(structure_alloc_comps): Update caller.
(gfc_trans_deferred_array): Call finalizer.
* trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
* trans-decl.c (gfc_trans_deferred_vars): Don't deallocate/finalize
variables of the main program.
* trans-expr.c (gfc_conv_procedure_call): Support finalization.
* trans-openmp.c (gfc_omp_clause_dtor,
gfc_trans_omp_array_reduction): Update calls.
* trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
of alloc components.
* trans.c (gfc_add_finalizer_call): New function.
(gfc_deallocate_with_status,
gfc_deallocate_scalar_with_status): Call it
(gfc_build_final_call): Fix handling of scalar coarrays,
move up in the file and make static.
2013-06-01 Janus Weil <janus@gcc.gnu.org>
Mikael Morin <mikael@gcc.gnu.org>

25
gcc/fortran/trans-array.c
View File

@ -7247,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Generate code to deallocate an array, if it is allocated. */
tree
gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
{
tree tmp;
tree var;
@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
are already deallocated are ignored. */
tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE, true,
NULL, coarray);
expr, coarray);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
gfc_add_expr_to_block (&tmpblock, tmp);
}
else if (c->attr.allocatable)
@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
tmp = gfc_trans_dealloc_allocated (comp,
CLASS_DATA (c)->attr.codimension);
CLASS_DATA (c)->attr.codimension, NULL);
else
{
tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
@ -8296,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
stmtblock_t cleanup;
locus loc;
int rank;
bool sym_has_alloc_comp;
bool sym_has_alloc_comp, has_finalizer;
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS)
@ -8383,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */
if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
&& !sym->attr.pointer && !sym->attr.save)
has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
if ((!sym->attr.allocatable || !has_finalizer)
&& sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
&& !sym->attr.pointer && !sym->attr.save
&& !sym->ns->proc_name->attr.is_main_program)
{
int rank;
rank = sym->as ? sym->as->rank : 0;
@ -8393,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
}
if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
&& !sym->attr.save && !sym->attr.result)
&& !sym->attr.save && !sym->attr.result
&& !sym->ns->proc_name->attr.is_main_program)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
sym->attr.codimension);
sym->attr.codimension,
has_finalizer
? gfc_lval_expr_from_sym (sym) : NULL);
gfc_add_expr_to_block (&cleanup, tmp);
}

2
gcc/fortran/trans-array.h
View File

@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree, bool);
tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);

3
gcc/fortran/trans-decl.c
View File

@ -3872,7 +3872,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* Deallocate when leaving the scope. Nullifying is not
needed. */
if (!sym->attr.result && !sym->attr.dummy)
if (!sym->attr.result && !sym->attr.dummy
&& !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.codimension)

12
gcc/fortran/trans-expr.c
View File

@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e->ts.type == BT_CLASS)
ptr = gfc_class_data_get (ptr);
tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
NULL_TREE, NULL_TREE,
NULL_TREE, true, NULL,
false);
tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
true, e, e->ts);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr,
@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&se->pre, tmp);
}
gfc_add_expr_to_block (&se->pre, tmp);
}
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp, false);
tmp = gfc_trans_dealloc_allocated (tmp, false, e);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)

5
gcc/fortran/trans-openmp.c
View File

@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
to be deallocated if they were allocated. */
return gfc_trans_dealloc_allocated (decl, false);
return gfc_trans_dealloc_allocated (decl, false, NULL);
}
@ -707,7 +707,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
gfc_start_block (&block);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
true));
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false));
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
NULL));
stmt = gfc_finish_block (&block);
}
else

3
gcc/fortran/trans-stmt.c
View File

@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code)
if (expr->rank || gfc_is_coarray (expr))
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
&& !gfc_is_finalizable (expr->ts.u.derived, NULL))
{
gfc_ref *ref;
gfc_ref *last = NULL;

349
gcc/fortran/trans.c
View File

@ -838,6 +838,223 @@ gfc_call_free (tree var)
}
/* Build a call to a FINAL procedure, which finalizes "var". */
static tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
bool fini_coarray, gfc_expr *class_size)
{
stmtblock_t block;
gfc_se se;
tree final_fndecl, array, size, tmp;
symbol_attribute attr;
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
final_fndecl = se.expr;
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
if (ts.type == BT_DERIVED)
{
tree elem_size;
gcc_assert (!class_size);
elem_size = gfc_typenode_for_spec (&ts);
elem_size = TYPE_SIZE_UNIT (elem_size);
size = fold_convert (gfc_array_index_type, elem_size);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (var->rank)
{
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, var);
array = se.expr;
}
else
{
gfc_conv_expr (&se, var);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
gcc_assert (se.post.head == NULL_TREE);
}
}
else
{
gfc_expr *array_expr;
gcc_assert (class_size);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, class_size);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
size = se.expr;
array_expr = gfc_copy_expr (var);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (array_expr->rank)
{
gfc_add_class_array_ref (array_expr);
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, array_expr);
array = se.expr;
}
else
{
gfc_add_data_component (array_expr);
gfc_conv_expr (&se, array_expr);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
if (!gfc_is_coarray (array_expr))
{
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
}
gcc_assert (se.post.head == NULL_TREE);
}
gfc_free_expr (array_expr);
}
if (!POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
gfc_start_block (&block);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_call_expr_loc (input_location,
final_fndecl, 3, array,
size, fini_coarray ? boolean_true_node
: boolean_false_node);
gfc_add_block_to_block (&block, &se.post);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Add a call to the finalizer, using the passed *expr. Returns
true when a finalizer call has been inserted. */
bool
gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
{
tree tmp;
gfc_ref *ref;
gfc_expr *expr;
gfc_expr *final_expr = NULL;
gfc_expr *elem_size = NULL;
bool has_finalizer = false;
if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
return false;
if (expr2->ts.type == BT_DERIVED)
{
gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
if (!final_expr)
return false;
}
/* If we have a class array, we need go back to the class
container. */
expr = gfc_copy_expr (expr2);
if (expr->ref && expr->ref->next && !expr->ref->next->next
&& expr->ref->next->type == REF_ARRAY
&& expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0)
{
gfc_free_ref_list (expr->ref);
expr->ref = NULL;
}
else
for (ref = expr->ref; ref; ref = ref->next)
if (ref->next && ref->next->next && !ref->next->next->next
&& ref->next->next->type == REF_ARRAY
&& ref->next->type == REF_COMPONENT
&& strcmp (ref->next->u.c.component->name, "_data") == 0)
{
gfc_free_ref_list (ref->next);
ref->next = NULL;
}
if (expr->ts.type == BT_CLASS)
{
has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
final_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (final_expr);
gfc_add_component_ref (final_expr, "_final");
elem_size = gfc_copy_expr (expr);
gfc_add_vptr_component (elem_size);
gfc_add_component_ref (elem_size, "_size");
}
gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
tmp = gfc_build_final_call (expr->ts, final_expr, expr,
false, elem_size);
if (expr->ts.type == BT_CLASS && !has_finalizer)
{
tree cond;
gfc_se se;
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, final_expr);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
/* For CLASS(*) not only sym->_vtab->_final can be NULL
but already sym->_vtab itself. */
if (UNLIMITED_POLY (expr))
{
tree cond2;
gfc_expr *vptr_expr;
vptr_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (vptr_expr);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, vptr_expr);
gfc_free_expr (vptr_expr);
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
se.expr,
build_int_cst (TREE_TYPE (se.expr), 0));
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_type_node, cond2, cond);
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (block, tmp);
return true;
}
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
gfc_add_finalizer_call (&non_null, expr);
if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
{
tmp = build_call_expr_loc (input_location,
@ -1022,125 +1240,6 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
}
/* Build a call to a FINAL procedure, which finalizes "var". */
tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
bool fini_coarray, gfc_expr *class_size)
{
stmtblock_t block;
gfc_se se;
tree final_fndecl, array, size, tmp;
symbol_attribute attr;
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
final_fndecl = se.expr;
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
attr = gfc_expr_attr (var);
if (ts.type == BT_DERIVED)
{
tree elem_size;
gcc_assert (!class_size);
elem_size = gfc_typenode_for_spec (&ts);
elem_size = TYPE_SIZE_UNIT (elem_size);
size = fold_convert (gfc_array_index_type, elem_size);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (var->rank || attr.dimension
|| (attr.codimension && attr.allocatable
&& gfc_option.coarray == GFC_FCOARRAY_LIB))
{
if (var->rank == 0)
se.want_coarray = 1;
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, var);
array = se.expr;
if (!POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
}
else
{
gfc_clear_attr (&attr);
gfc_conv_expr (&se, var);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
array = gfc_build_addr_expr (NULL, array);
gcc_assert (se.post.head == NULL_TREE);
}
}
else
{
gfc_expr *array_expr;
gcc_assert (class_size);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, class_size);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
size = se.expr;
array_expr = gfc_copy_expr (var);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (array_expr->rank || attr.dimension
|| (attr.codimension && attr.allocatable
&& gfc_option.coarray == GFC_FCOARRAY_LIB))
{
gfc_add_class_array_ref (array_expr);
if (array_expr->rank == 0)
se.want_coarray = 1;
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, array_expr);
array = se.expr;
if (! POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
}
else
{
gfc_clear_attr (&attr);
gfc_add_data_component (array_expr);
gfc_conv_expr (&se, array_expr);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
/* attr: Argument is neither a pointer/allocatable,
i.e. no copy back needed */
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
array = gfc_build_addr_expr (NULL, array);
gcc_assert (se.post.head == NULL_TREE);
}
gfc_free_expr (array_expr);
}
gfc_start_block (&block);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_call_expr_loc (input_location,
final_fndecl, 3, array,
size, fini_coarray ? boolean_true_node
: boolean_false_node);
gfc_add_block_to_block (&block, &se.post);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Generate code for deallocation of allocatable scalars (variables or
components). Before the object itself is freed, any allocatable
subcomponents are being deallocated. */
@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
{
stmtblock_t null, non_null;
tree cond, tmp, error;
bool finalizable;
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
@ -1195,20 +1295,13 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_start_block (&non_null);
/* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
finalizable = gfc_add_finalizer_call (&non_null, expr);
if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
else if (ts.type == BT_CLASS
&& ts.u.derived->components->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,

3
gcc/fortran/trans.h
View File

@ -352,8 +352,7 @@ tree gfc_vtable_final_get (tree);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree);
tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *, bool,
gfc_expr *);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
bool);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,

18
gcc/testsuite/ChangeLog
View File

@ -1,4 +1,20 @@
2013-06-03 Manfred Schwarb <manfred99@gmx.ch>
2013-06-04 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.dg/finalize_12.f90: New.
* gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for
end of scope finalization.
* gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
* gfortran.dg/allocatable_scalar_9.f90: Ditto.
* gfortran.dg/auto_dealloc_2.f90: Ditto.
* gfortran.dg/class_19.f03: Ditto.
* gfortran.dg/coarray_lib_alloc_1.f90: Ditto.
* gfortran.dg/coarray_lib_alloc_2.f90: Ditto.
* gfortran.dg/extends_14.f03: Ditto.
* gfortran.dg/move_alloc_4.f90: Ditto.
* gfortran.dg/typebound_proc_27.f03: Ditto.
2013-06-04 Manfred Schwarb <manfred99@gmx.ch>
* gfortran.dg/bounds_check_7.f90: Remove "! {".
* gfortran.dg/coarray_poly_3.f90: Remove inactive, broken dg-*.

6
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
View File

@ -33,8 +33,10 @@ program alloc
integer, allocatable :: a2(:)
end type alloc2
type(alloc2) :: b
integer :: i
BLOCK ! To ensure that the allocatables are freed at the end of the scope
type(alloc2) :: b
type(alloc2), allocatable :: c(:)
if (allocated(b%a2) .OR. allocated(b%a1)) then
@ -64,7 +66,7 @@ program alloc
deallocate(c)
! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
END BLOCK
contains
subroutine allocate_alloc2(b)

7
gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
View File

@ -19,9 +19,12 @@ Program test_constructor
type(thytype), allocatable :: q(:)
end type mytype
type (mytype) :: x
type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd
type (mytype) :: x
integer, allocatable :: yy(:,:)
type (thytype), allocatable :: bar(:)
integer :: i
@ -70,7 +73,7 @@ Program test_constructor
! Check that passing the constructor to a procedure works
call check_mytype (mytype(y, [foo, foo]))
END BLOCK
contains
subroutine check_mytype(x)

3
gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
View File

@ -28,10 +28,12 @@ end type t4
end module m
use m
block ! Start new scoping unit as otherwise the vars are implicitly SAVEd
type(t1) :: na1, a1, aa1(:)
type(t2) :: na2, a2, aa2(:)
type(t3) :: na3, a3, aa3(:)
type(t4) :: na4, a4, aa4(:)
allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4
if(allocated(a1)) call abort()
@ -47,6 +49,7 @@ if(allocated(na1%b1)) call abort()
if(allocated(na2%b2)) call abort()
if(allocated(na3%b3)) call abort()
if(allocated(na4%b4)) call abort()
end block
end
! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }

3
gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
View File

@ -11,11 +11,12 @@ type :: t
integer, allocatable :: i(:)
end type
block ! New block as the main program implies SAVE
type(t) :: a
call init(a)
call init(a)
end block
contains
subroutine init(x)

2
gcc/testsuite/gfortran.dg/class_19.f03
View File

@ -39,5 +39,5 @@ program main
end program main
! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 12 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

1
gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
View File

@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf.
!
subroutine test()
integer(4), allocatable :: xx[:], yy(:)[:]
integer :: stat
character(len=200) :: errmsg

1
gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
View File

@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf.
!
subroutine test()
type t
end type t
class(t), allocatable :: xx[:], yy(:)[:]

3
gcc/testsuite/gfortran.dg/extends_14.f03
View File

@ -16,12 +16,13 @@ program evolve_aflow
type, extends(state_t) :: astate_t
end type
block ! New scoping unit as "a"/"b" are otherwise implicitly SAVEd
type(astate_t) :: a,b
allocate(a%U(1000))
a = b
end block
end program
! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }

175
gcc/testsuite/gfortran.dg/finalize_12.f90 Normal file
View File

@ -0,0 +1,175 @@
! { dg-do run }
! { dg-options "-fcoarray=single" }
!
! PR fortran/37336
!
module m
implicit none
type t
integer :: i
contains
final :: fini, fini2
end type t
integer :: global_count1, global_count2
contains
subroutine fini(x)
type(t) :: x
!print *, 'fini:',x%i
if (global_count1 == -1) call abort ()
if (x%i /= 42) call abort()
x%i = 33
global_count1 = global_count1 + 1
end subroutine fini
subroutine fini2(x)
type(t) :: x(:)
!print *, 'fini2', x%i
if (global_count2 == -1) call abort ()
if (size(x) /= 5) call abort()
if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) call abort()
x%i = 33
global_count2 = global_count2 + 10
end subroutine fini2
end module m
program pp
use m
implicit none
type(t), allocatable :: ya
class(t), allocatable :: yc
type(t), allocatable :: yaa(:)
class(t), allocatable :: yca(:)
type(t), allocatable :: ca[:]
class(t), allocatable :: cc[:]
type(t), allocatable :: caa(:)[:]
class(t), allocatable :: cca(:)[:]
global_count1 = -1
global_count2 = -1
allocate (ya, yc, yaa(5), yca(5))
global_count1 = 0
global_count2 = 0
ya%i = 42
yc%i = 42
yaa%i = [1,2,3,4,5]
yca%i = [1,2,3,4,5]
call foo(ya, yc, yaa, yca)
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
! Coarray finalization
allocate (ca[*], cc[*], caa(5)[*], cca(5)[*])
global_count1 = 0
global_count2 = 0
ca%i = 42
cc%i = 42
caa%i = [1,2,3,4,5]
cca%i = [1,2,3,4,5]
deallocate (ca, cc, caa, cca)
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
global_count1 = -1
global_count2 = -1
block
type(t), allocatable :: za
class(t), allocatable :: zc
type(t), allocatable :: zaa(:)
class(t), allocatable :: zca(:)
! Test intent(out) finalization
allocate (za, zc, zaa(5), zca(5))
global_count1 = 0
global_count2 = 0
za%i = 42
zc%i = 42
zaa%i = [1,2,3,4,5]
zca%i = [1,2,3,4,5]
call foo(za, zc, zaa, zca)
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
! Test intent(out) finalization with optional
call foo_opt()
call opt()
! Test intent(out) finalization with optional
allocate (za, zc, zaa(5), zca(5))
global_count1 = 0
global_count2 = 0
za%i = 42
zc%i = 42
zaa%i = [1,2,3,4,5]
zca%i = [1,2,3,4,5]
call foo_opt(za, zc, zaa, zca)
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
! Test DEALLOCATE finalization
allocate (za, zc, zaa(5), zca(5))
global_count1 = 0
global_count2 = 0
za%i = 42
zc%i = 42
zaa%i = [1,2,3,4,5]
zca%i = [6,7,8,9,10]
deallocate (za, zc, zaa, zca)
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
! Test end-of-scope finalization
allocate (za, zc, zaa(5), zca(5))
global_count1 = 0
global_count2 = 0
za%i = 42
zc%i = 42
zaa%i = [1,2,3,4,5]
zca%i = [6,7,8,9,10]
end block
if (global_count1 /= 2) call abort ()
if (global_count2 /= 20) call abort ()
! Test that no end-of-scope finalization occurs
! for SAVED variable in main
allocate (ya, yc, yaa(5), yca(5))
global_count1 = -1
global_count2 = -1
contains
subroutine opt(xa, xc, xaa, xca)
type(t), allocatable, optional :: xa
class(t), allocatable, optional :: xc
type(t), allocatable, optional :: xaa(:)
class(t), allocatable, optional :: xca(:)
call foo_opt(xc, xc, xaa)
!call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445
end subroutine opt
subroutine foo_opt(xa, xc, xaa, xca)
type(t), allocatable, intent(out), optional :: xa
class(t), allocatable, intent(out), optional :: xc
type(t), allocatable, intent(out), optional :: xaa(:)
class(t), allocatable, intent(out), optional :: xca(:)
if (.not. present(xa)) &
return
if (allocated (xa)) call abort ()
if (allocated (xc)) call abort ()
if (allocated (xaa)) call abort ()
if (allocated (xca)) call abort ()
end subroutine foo_opt
subroutine foo(xa, xc, xaa, xca)
type(t), allocatable, intent(out) :: xa
class(t), allocatable, intent(out) :: xc
type(t), allocatable, intent(out) :: xaa(:)
class(t), allocatable, intent(out) :: xca(:)
if (allocated (xa)) call abort ()
if (allocated (xc)) call abort ()
if (allocated (xaa)) call abort ()
if (allocated (xca)) call abort ()
end subroutine foo
end program

161
gcc/testsuite/gfortran.dg/finalize_13.f90 Normal file
View File

@ -0,0 +1,161 @@
! { dg-do run }
!
! PR fortran/37336
!
module m
implicit none
type t
integer :: i
contains
final :: fini3, fini2, fini_elm
end type t
type, extends(t) :: t2
integer :: j
contains
final :: f2ini2, f2ini_elm
end type t2
logical :: elem_call
logical :: rank2_call
logical :: rank3_call
integer :: cnt, cnt2
integer :: fini_call
contains
subroutine fini2 (x)
type(t), intent(in), contiguous :: x(:,:)
if (.not. rank2_call) call abort ()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
!print *, 'fini2:', x%i
if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
fini_call = fini_call + 1
end subroutine
subroutine fini3 (x)
type(t), intent(in) :: x(2,2,*)
integer :: i,j,k
if (.not. elem_call) call abort ()
if (.not. rank3_call) call abort ()
if (cnt2 /= 9) call abort()
if (cnt /= 1) call abort()
do i = 1, 2
do j = 1, 2
do k = 1, 2
!print *, k,j,i,x(k,j,i)%i
if (x(k,j,i)%i /= k+10*j+100*i) call abort()
end do
end do
end do
fini_call = fini_call + 1
end subroutine
impure elemental subroutine fini_elm (x)
type(t), intent(in) :: x
if (.not. elem_call) call abort ()
if (rank3_call) call abort ()
if (cnt2 /= 6) call abort()
if (cnt /= x%i) call abort()
!print *, 'fini_elm:', cnt, x%i
fini_call = fini_call + 1
cnt = cnt + 1
end subroutine
subroutine f2ini2 (x)
type(t2), intent(in), target :: x(:,:)
if (.not. rank2_call) call abort ()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
!print *, 'f2ini2:', x%i
!print *, 'f2ini2:', x%j
if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
fini_call = fini_call + 1
end subroutine
impure elemental subroutine f2ini_elm (x)
type(t2), intent(in) :: x
integer, parameter :: exprected(*) &
= [111, 112, 121, 122, 211, 212, 221, 222]
if (.not. elem_call) call abort ()
!print *, 'f2ini_elm:', cnt2, x%i, x%j
if (rank3_call) then
if (x%i /= exprected(cnt2)) call abort ()
if (x%j /= 1000*exprected(cnt2)) call abort ()
else
if (cnt2 /= x%i .or. cnt2*10 /= x%j) call abort()
end if
cnt2 = cnt2 + 1
fini_call = fini_call + 1
end subroutine
end module m
program test
use m
implicit none
class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:)
target :: z, zz
integer :: i,j,k
elem_call = .false.
rank2_call = .false.
rank3_call = .false.
allocate (t2 :: y(5))
select type (y)
type is (t2)
do i = 1, 5
y(i)%i = i
y(i)%j = i*10
end do
end select
cnt = 1
cnt2 = 1
fini_call = 0
elem_call = .true.
deallocate (y)
if (fini_call /= 10) call abort ()
elem_call = .false.
rank2_call = .false.
rank3_call = .false.
allocate (t2 :: z(2,3))
select type (z)
type is (t2)
do i = 1, 3
do j = 1, 2
z(j,i)%i = j+10*i
z(j,i)%j = (j+10*i)*100
end do
end do
end select
cnt = 1
cnt2 = 1
fini_call = 0
rank2_call = .true.
deallocate (z)
if (fini_call /= 2) call abort ()
elem_call = .false.
rank2_call = .false.
rank3_call = .false.
allocate (t2 :: zz(2,2,2))
select type (zz)
type is (t2)
do i = 1, 2
do j = 1, 2
do k = 1, 2
zz(k,j,i)%i = k+10*j+100*i
zz(k,j,i)%j = (k+10*j+100*i)*1000
end do
end do
end do
end select
cnt = 1
cnt2 = 1
fini_call = 0
rank3_call = .true.
elem_call = .true.
deallocate (zz)
if (fini_call /= 2*2*2+1) call abort ()
end program test

220
gcc/testsuite/gfortran.dg/finalize_14.f90 Normal file
View File

@ -0,0 +1,220 @@
! { dg-do compile }
!
! PR fortran/37336
!
! Started to fail when finalization was added.
!
! Contributed by Ian Chivers in PR fortran/44465
!
module shape_module
type shape_type
integer :: x_=0
integer :: y_=0
contains
procedure , pass(this) :: getx
procedure , pass(this) :: gety
procedure , pass(this) :: setx
procedure , pass(this) :: sety
procedure , pass(this) :: moveto
procedure , pass(this) :: draw
end type shape_type
interface assignment(=)
module procedure generic_shape_assign
end interface
contains
integer function getx(this)
implicit none
class (shape_type) , intent(in) :: this
getx=this%x_
end function getx
integer function gety(this)
implicit none
class (shape_type) , intent(in) :: this
gety=this%y_
end function gety
subroutine setx(this,x)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: x
this%x_=x
end subroutine setx
subroutine sety(this,y)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: y
this%y_=y
end subroutine sety
subroutine moveto(this,newx,newy)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: newx
integer , intent(in) :: newy
this%x_=newx
this%y_=newy
end subroutine moveto
subroutine draw(this)
implicit none
class (shape_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
end subroutine draw
subroutine generic_shape_assign(lhs,rhs)
implicit none
class (shape_type) , intent(out) , allocatable :: lhs
class (shape_type) , intent(in) :: rhs
print *,' In generic_shape_assign'
if ( allocated(lhs) ) then
deallocate(lhs)
end if
allocate(lhs,source=rhs)
end subroutine generic_shape_assign
end module shape_module
! Circle_p.f90
module circle_module
use shape_module
type , extends(shape_type) :: circle_type
integer :: radius_
contains
procedure , pass(this) :: getradius
procedure , pass(this) :: setradius
procedure , pass(this) :: draw => draw_circle
end type circle_type
contains
integer function getradius(this)
implicit none
class (circle_type) , intent(in) :: this
getradius=this%radius_
end function getradius
subroutine setradius(this,radius)
implicit none
class (circle_type) , intent(inout) :: this
integer , intent(in) :: radius
this%radius_=radius
end subroutine setradius
subroutine draw_circle(this)
implicit none
class (circle_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
print *,' radius = ' , this%radius_
end subroutine draw_circle
end module circle_module
! Rectangle_p.f90
module rectangle_module
use shape_module
type , extends(shape_type) :: rectangle_type
integer :: width_
integer :: height_
contains
procedure , pass(this) :: getwidth
procedure , pass(this) :: setwidth
procedure , pass(this) :: getheight
procedure , pass(this) :: setheight
procedure , pass(this) :: draw => draw_rectangle
end type rectangle_type
contains
integer function getwidth(this)
implicit none
class (rectangle_type) , intent(in) :: this
getwidth=this%width_
end function getwidth
subroutine setwidth(this,width)
implicit none
class (rectangle_type) , intent(inout) :: this
integer , intent(in) :: width
this%width_=width
end subroutine setwidth
integer function getheight(this)
implicit none
class (rectangle_type) , intent(in) :: this
getheight=this%height_
end function getheight
subroutine setheight(this,height)
implicit none
class (rectangle_type) , intent(inout) :: this
integer , intent(in) :: height
this%height_=height
end subroutine setheight
subroutine draw_rectangle(this)
implicit none
class (rectangle_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
print *,' width = ' , this%width_
print *,' height = ' , this%height_
end subroutine draw_rectangle
end module rectangle_module
program polymorphic
use shape_module
use circle_module
use rectangle_module
implicit none
type shape_w
class (shape_type) , allocatable :: shape_v
end type shape_w
type (shape_w) , dimension(3) :: p
print *,' shape '
p(1)%shape_v=shape_type(10,20)
call p(1)%shape_v%draw()
print *,' circle '
p(2)%shape_v=circle_type(100,200,300)
call p(2)%shape_v%draw()
print *,' rectangle '
p(3)%shape_v=rectangle_type(1000,2000,3000,4000)
call p(3)%shape_v%draw()
end program polymorphic

3
gcc/testsuite/gfortran.dg/move_alloc_4.f90
View File

@ -10,13 +10,14 @@ program testmv3
integer, allocatable :: ia(:), ja(:)
end type
block ! For auto-dealloc, as PROGRAM implies SAVE
type(bar), allocatable :: sm,sm2
allocate(sm)
allocate(sm%ia(10),sm%ja(10))
call move_alloc(sm2,sm)
end block
end program testmv3
! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }

2
gcc/testsuite/gfortran.dg/typebound_proc_27.f03
View File

@ -33,6 +33,7 @@ program prog
use m
block ! Start new scoping unit as PROGRAM implies SAVE
type(tx) :: this
type(tx), target :: that
type(tx), pointer :: p
@ -64,6 +65,7 @@ program prog
!print *,this%i
if(any (this%i /= [8, 9])) call abort()
end block
end program prog
!