Commit ef292537 by Tobias Burnus

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

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
parent aadaf24e
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> 2013-06-01 Janus Weil <janus@gcc.gnu.org>
Mikael Morin <mikael@gcc.gnu.org> Mikael Morin <mikael@gcc.gnu.org>
......
...@@ -7247,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, ...@@ -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. */ /* Generate code to deallocate an array, if it is allocated. */
tree tree
gfc_trans_dealloc_allocated (tree descriptor, bool coarray) gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
{ {
tree tmp; tree tmp;
tree var; tree var;
...@@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray) ...@@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
are already deallocated are ignored. */ are already deallocated are ignored. */
tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE, true, NULL_TREE, NULL_TREE, NULL_TREE, true,
NULL, coarray); expr, coarray);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */ /* Zero the data pointer. */
...@@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{ {
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE); 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); gfc_add_expr_to_block (&tmpblock, tmp);
} }
else if (c->attr.allocatable) else if (c->attr.allocatable)
...@@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
tmp = gfc_trans_dealloc_allocated (comp, tmp = gfc_trans_dealloc_allocated (comp,
CLASS_DATA (c)->attr.codimension); CLASS_DATA (c)->attr.codimension, NULL);
else else
{ {
tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, 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) ...@@ -8296,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
stmtblock_t cleanup; stmtblock_t cleanup;
locus loc; locus loc;
int rank; int rank;
bool sym_has_alloc_comp; bool sym_has_alloc_comp, has_finalizer;
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS) || sym->ts.type == BT_CLASS)
...@@ -8383,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -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. /* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */ The allocatable components of pointers must not be touched. */
if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
&& !sym->attr.pointer && !sym->attr.save) ? 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; int rank;
rank = sym->as ? sym->as->rank : 0; rank = sym->as ? sym->as->rank : 0;
...@@ -8393,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -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) 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, 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); gfc_add_expr_to_block (&cleanup, tmp);
} }
......
...@@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); ...@@ -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. */ /* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */ /* 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); tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
......
...@@ -3872,7 +3872,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) ...@@ -3872,7 +3872,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* Deallocate when leaving the scope. Nullifying is not /* Deallocate when leaving the scope. Nullifying is not
needed. */ 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 if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.codimension) && CLASS_DATA (sym)->attr.codimension)
......
...@@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e->ts.type == BT_CLASS) if (e->ts.type == BT_CLASS)
ptr = gfc_class_data_get (ptr); ptr = gfc_class_data_get (ptr);
tmp = gfc_deallocate_with_status (ptr, NULL_TREE, tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
NULL_TREE, NULL_TREE, true, e, e->ts);
NULL_TREE, true, NULL,
false);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr, void_type_node, ptr,
...@@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else else
tmp = gfc_finish_block (&block); 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 /* The conversion does not repackage the reference to a class
array - _data descriptor. */ array - _data descriptor. */
...@@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{ {
tmp = build_fold_indirect_ref_loc (input_location, tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr); parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp, false); tmp = gfc_trans_dealloc_allocated (tmp, false, e);
if (fsym->attr.optional if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE && e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional) && e->symtree->n.sym->attr.optional)
......
...@@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) ...@@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
to be deallocated if they were allocated. */ 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) ...@@ -707,7 +707,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
gfc_start_block (&block); gfc_start_block (&block);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
true)); 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); stmt = gfc_finish_block (&block);
} }
else else
......
...@@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code) ...@@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code)
if (expr->rank || gfc_is_coarray (expr)) 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 *ref;
gfc_ref *last = NULL; gfc_ref *last = NULL;
......
...@@ -838,6 +838,223 @@ gfc_call_free (tree var) ...@@ -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 /* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function: logic is the same as the previous library function:
...@@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, ...@@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
/* When POINTER is not NULL, we free it. */ /* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null); gfc_start_block (&non_null);
gfc_add_finalizer_call (&non_null, expr);
if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
{ {
tmp = build_call_expr_loc (input_location, tmp = build_call_expr_loc (input_location,
...@@ -1022,125 +1240,6 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, ...@@ -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 /* Generate code for deallocation of allocatable scalars (variables or
components). Before the object itself is freed, any allocatable components). Before the object itself is freed, any allocatable
subcomponents are being deallocated. */ subcomponents are being deallocated. */
...@@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, ...@@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
{ {
stmtblock_t null, non_null; stmtblock_t null, non_null;
tree cond, tmp, error; tree cond, tmp, error;
bool finalizable;
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0)); build_int_cst (TREE_TYPE (pointer), 0));
...@@ -1195,20 +1295,13 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, ...@@ -1195,20 +1295,13 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_start_block (&non_null); gfc_start_block (&non_null);
/* Free allocatable components. */ /* 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 = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp); 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, tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1, builtin_decl_explicit (BUILT_IN_FREE), 1,
......
...@@ -352,8 +352,7 @@ tree gfc_vtable_final_get (tree); ...@@ -352,8 +352,7 @@ tree gfc_vtable_final_get (tree);
tree gfc_get_vptr_from_expr (tree); tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree); tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree); tree gfc_copy_class_to_class (tree, tree, tree);
tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *, bool, bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
gfc_expr *);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool, void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
bool); bool);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool, void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
......
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/bounds_check_7.f90: Remove "! {".
* gfortran.dg/coarray_poly_3.f90: Remove inactive, broken dg-*. * gfortran.dg/coarray_poly_3.f90: Remove inactive, broken dg-*.
......
...@@ -33,8 +33,10 @@ program alloc ...@@ -33,8 +33,10 @@ program alloc
integer, allocatable :: a2(:) integer, allocatable :: a2(:)
end type alloc2 end type alloc2
type(alloc2) :: b
integer :: i integer :: i
BLOCK ! To ensure that the allocatables are freed at the end of the scope
type(alloc2) :: b
type(alloc2), allocatable :: c(:) type(alloc2), allocatable :: c(:)
if (allocated(b%a2) .OR. allocated(b%a1)) then if (allocated(b%a2) .OR. allocated(b%a1)) then
...@@ -64,7 +66,7 @@ program alloc ...@@ -64,7 +66,7 @@ program alloc
deallocate(c) deallocate(c)
! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope) ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
END BLOCK
contains contains
subroutine allocate_alloc2(b) subroutine allocate_alloc2(b)
......
...@@ -19,9 +19,12 @@ Program test_constructor ...@@ -19,9 +19,12 @@ Program test_constructor
type(thytype), allocatable :: q(:) type(thytype), allocatable :: q(:)
end type mytype end type mytype
type (mytype) :: x
type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [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(:,:) integer, allocatable :: yy(:,:)
type (thytype), allocatable :: bar(:) type (thytype), allocatable :: bar(:)
integer :: i integer :: i
...@@ -70,7 +73,7 @@ Program test_constructor ...@@ -70,7 +73,7 @@ Program test_constructor
! Check that passing the constructor to a procedure works ! Check that passing the constructor to a procedure works
call check_mytype (mytype(y, [foo, foo])) call check_mytype (mytype(y, [foo, foo]))
END BLOCK
contains contains
subroutine check_mytype(x) subroutine check_mytype(x)
......
...@@ -28,10 +28,12 @@ end type t4 ...@@ -28,10 +28,12 @@ end type t4
end module m end module m
use m use m
block ! Start new scoping unit as otherwise the vars are implicitly SAVEd
type(t1) :: na1, a1, aa1(:) type(t1) :: na1, a1, aa1(:)
type(t2) :: na2, a2, aa2(:) type(t2) :: na2, a2, aa2(:)
type(t3) :: na3, a3, aa3(:) type(t3) :: na3, a3, aa3(:)
type(t4) :: na4, a4, aa4(:) type(t4) :: na4, a4, aa4(:)
allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4 allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4
if(allocated(a1)) call abort() if(allocated(a1)) call abort()
...@@ -47,6 +49,7 @@ if(allocated(na1%b1)) call abort() ...@@ -47,6 +49,7 @@ if(allocated(na1%b1)) call abort()
if(allocated(na2%b2)) call abort() if(allocated(na2%b2)) call abort()
if(allocated(na3%b3)) call abort() if(allocated(na3%b3)) call abort()
if(allocated(na4%b4)) call abort() if(allocated(na4%b4)) call abort()
end block
end end
! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
......
...@@ -11,11 +11,12 @@ type :: t ...@@ -11,11 +11,12 @@ type :: t
integer, allocatable :: i(:) integer, allocatable :: i(:)
end type end type
block ! New block as the main program implies SAVE
type(t) :: a type(t) :: a
call init(a) call init(a)
call init(a) call init(a)
end block
contains contains
subroutine init(x) subroutine init(x)
......
...@@ -39,5 +39,5 @@ program main ...@@ -39,5 +39,5 @@ program main
end 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" } } ! { dg-final { cleanup-tree-dump "original" } }
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf. ! Allocate/deallocate with libcaf.
! !
subroutine test()
integer(4), allocatable :: xx[:], yy(:)[:] integer(4), allocatable :: xx[:], yy(:)[:]
integer :: stat integer :: stat
character(len=200) :: errmsg character(len=200) :: errmsg
......
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf. ! Allocate/deallocate with libcaf.
! !
subroutine test()
type t type t
end type t end type t
class(t), allocatable :: xx[:], yy(:)[:] class(t), allocatable :: xx[:], yy(:)[:]
......
...@@ -16,12 +16,13 @@ program evolve_aflow ...@@ -16,12 +16,13 @@ program evolve_aflow
type, extends(state_t) :: astate_t type, extends(state_t) :: astate_t
end type end type
block ! New scoping unit as "a"/"b" are otherwise implicitly SAVEd
type(astate_t) :: a,b type(astate_t) :: a,b
allocate(a%U(1000)) allocate(a%U(1000))
a = b a = b
end block
end program end program
! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
......
! { 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
! { 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
! { 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
...@@ -10,13 +10,14 @@ program testmv3 ...@@ -10,13 +10,14 @@ program testmv3
integer, allocatable :: ia(:), ja(:) integer, allocatable :: ia(:), ja(:)
end type end type
block ! For auto-dealloc, as PROGRAM implies SAVE
type(bar), allocatable :: sm,sm2 type(bar), allocatable :: sm,sm2
allocate(sm) allocate(sm)
allocate(sm%ia(10),sm%ja(10)) allocate(sm%ia(10),sm%ja(10))
call move_alloc(sm2,sm) call move_alloc(sm2,sm)
end block
end program testmv3 end program testmv3
! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }
......
...@@ -33,6 +33,7 @@ program prog ...@@ -33,6 +33,7 @@ program prog
use m use m
block ! Start new scoping unit as PROGRAM implies SAVE
type(tx) :: this type(tx) :: this
type(tx), target :: that type(tx), target :: that
type(tx), pointer :: p type(tx), pointer :: p
...@@ -64,6 +65,7 @@ program prog ...@@ -64,6 +65,7 @@ program prog
!print *,this%i !print *,this%i
if(any (this%i /= [8, 9])) call abort() if(any (this%i /= [8, 9])) call abort()
end block
end program prog end program prog
! !
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment