This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Fri, 31 May 2013 13:02:30 +0200
- Subject: Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
- References: <51A5BC22 dot 3010600 at net-b dot de> <51A72907 dot 3030107 at net-b dot de>
Another re-diff.
Changes:
- Removed spurious bits of the now-committed patch,
http://gcc.gnu.org/ml/fortran/2013-05/msg00114.html
- Moved gfc_build_final_call up in the file and made it static.
- Removed it from trans.h. Instead, gfc_add_finalizer_call is now
nonstatic.
The reason for the latter change is that I want to use it for
INTENT(OUT) finalization for nonallocatables - and including the change
in this patch makes life easier for me.
OK for the trunk?
Tobias
Tobias Burnus wrote:
Small update of the patch. Changes:
* There was a problem finalizing "var(:)%comp", which lead to an ICE.
Thanks to Dominique pointed out. See "expr->rank =" code added in
gfc_add_finalizer_call. I added the full test case from PR37336 (dg-do
compile: finalize_14.f90) to test for this.
* I added a new test case, which ensures that the built-in scalarizer
and packer works correctly (it did), see finalize_13.f90.
[...]
Tobias Burnus wrote:
this patch enables finalization (and polymorphic deallocation) for
allocatables for: end of scope, DEALLOCATE and intent(out).
As a side effect, an allocatable is no longer deallocated at the end
of the main program. (Variables declared in the main program have
automatically SAVE attribute; before finalization, it made no
difference but with finalization it is detectable. And only
finalizing nonfinalizable allocatables seems to be too much effort
for too little gain.)
...
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
PS: Fortran requires additional cases where finalization has to
happen; those will be added in follow-up patches.
2013-05-31 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-05-31 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.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 8556278..89f26d7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -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);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index d00e156..8d9e461 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 100ec18..8b82b62 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3872,7 +3891,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)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 07b0fa6..9d07345 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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)
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 882927e..2765561 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -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
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 7759b86..e2d0110 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 8211573..0b031cb 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -838,6 +838,231 @@ 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);
+
+ 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)
+ {
+ 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;
+ if (TREE_CODE (array) == ADDR_EXPR
+ && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
+ tmp = TREE_OPERAND (array, 0);
+
+ if (!attr.allocatable || !gfc_is_coarray (var))
+ {
+ /* 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 (!attr.allocatable || !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 +1155,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 +1248,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 +1258,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 +1303,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,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 0c0fe5d..06cb63d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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,
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
index 9b08129..65724fe 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
index 969e703..8003c05 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
index 3488c0d..fd0b4db 100644
--- a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index d261973..f47ec87 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03
index 6dcd99c..428015c 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" 15 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 12 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
index c0d06a4..926d531 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
@@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf.
!
+ subroutine test()
integer(4), allocatable :: xx[:], yy(:)[:]
integer :: stat
character(len=200) :: errmsg
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
index 3aaff1e..472e0be 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
@@ -4,6 +4,7 @@
! Allocate/deallocate with libcaf.
!
+ subroutine test()
type t
end type t
class(t), allocatable :: xx[:], yy(:)[:]
diff --git a/gcc/testsuite/gfortran.dg/extends_14.f03 b/gcc/testsuite/gfortran.dg/extends_14.f03
index 876e8c7..15e38ff 100644
--- a/gcc/testsuite/gfortran.dg/extends_14.f03
+++ b/gcc/testsuite/gfortran.dg/extends_14.f03
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_4.f90 b/gcc/testsuite/gfortran.dg/move_alloc_4.f90
index 4dc493f..b23ef70 100644
--- a/gcc/testsuite/gfortran.dg/move_alloc_4.f90
+++ b/gcc/testsuite/gfortran.dg/move_alloc_4.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
index 28c44df..ce845a0 100644
--- a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
@@ -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
!
--- /dev/null 2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_12.f90 2013-05-30 12:09:03.928265984 +0200
@@ -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
--- /dev/null 2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_13.f90 2013-05-30 11:14:23.121847304 +0200
@@ -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
--- /dev/null 2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_14.f90 2013-05-30 11:40:24.611148683 +0200
@@ -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