* [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
@ 2013-05-29 8:28 Tobias Burnus
2013-05-30 10:25 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2013-05-29 8:28 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 893 bytes --]
Dear all,
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.)
Note: This patch requires the following patch, which is still pending
review:
* Enable wrapper generation,
http://gcc.gnu.org/ml/fortran/2013-05/msg00073.html
<http://gcc.gnu.org/ml/fortran/2013-05/msg00093.html>
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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: finalize-alloc.diff --]
[-- Type: text/x-patch; name="finalize-alloc.diff", Size: 27934 bytes --]
2013-05-29 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* 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.
2013-05-29 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 be3a5a0..8160fcd 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7243,7 +7243,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;
@@ -7259,7 +7259,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. */
@@ -7548,7 +7548,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)
@@ -7580,7 +7580,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,
@@ -8292,7 +8292,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)
@@ -8379,8 +8379,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;
@@ -8389,10 +8393,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 6f44d79..a7144e5 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..b0e3ffc 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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)
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 7812934..1ef423b 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..8b8fdaa 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -838,6 +838,112 @@ gfc_call_free (tree var)
}
+/* Add a call to the finalizer, using the passed *expr. Returns
+ true when a finalizer call has been inserted. */
+
+static 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);
+
+ 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 +1036,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,
@@ -1055,17 +1162,11 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
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 || attr.dimension)
{
- 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
{
@@ -1077,9 +1178,11 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
&& 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);
+ if (!attr.allocatable || !gfc_is_coarray (var))
+ {
+ gfc_init_se (&se, NULL);
+ array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+ }
gcc_assert (se.post.head == NULL_TREE);
}
}
@@ -1095,22 +1198,15 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
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))
+ if (array_expr->rank || attr.dimension)
{
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);
@@ -1119,16 +1215,22 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
&& 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);
+ 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,
@@ -1151,6 +1253,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 +1298,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/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-29 07:55:34.977108520 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_12.f90 2013-05-29 10:09:46.894675521 +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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-05-29 8:28 [Patch, Fortran] Enable FINALization/poly dealloc for allocatables Tobias Burnus
@ 2013-05-30 10:25 ` Tobias Burnus
2013-05-31 11:03 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2013-05-30 10:25 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1446 bytes --]
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.
The latter test case depends on the patch posted at:
http://gcc.gnu.org/ml/fortran/2013-05/msg00114.html
[As Domique has pointed out, I forgot to change the allocate back to "t2
::" in that test case. I will do so before committal (and change the
malloc check to "(40)".)]
OK for the trunk?
Tobias
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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: finalize-alloc-v2.diff --]
[-- Type: text/x-patch; name="finalize-alloc-v2.diff", Size: 39088 bytes --]
2013-05-30 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* 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.
2013-05-30 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 be3a5a0..89f26d7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4834,7 +4834,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+ gfc_typespec *ts)
{
tree type;
tree tmp;
@@ -5012,6 +5013,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = TYPE_SIZE_UNIT (tmp);
}
}
+ else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
+ /* FIXME: Properly handle characters. See PR 57456. */
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
else
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -5081,7 +5085,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
{
tree tmp;
tree pointer;
@@ -5166,7 +5170,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, ts);
if (dimension)
{
@@ -7243,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;
@@ -7259,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. */
@@ -7548,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)
@@ -7580,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,
@@ -8292,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)
@@ -8379,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;
@@ -8389,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 6f44d79..8d9e461 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, gfc_typespec *);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -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..b0e3ffc 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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)
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 7812934..e2d0110 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4925,7 +4925,7 @@ gfc_trans_allocate (gfc_code * code)
nelems = NULL_TREE;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
- memsz, &nelems, code->expr3))
+ memsz, &nelems, code->expr3, &code->ext.alloc.ts))
{
bool unlimited_char;
@@ -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..00deee3 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -838,6 +838,115 @@ gfc_call_free (tree var)
}
+/* Add a call to the finalizer, using the passed *expr. Returns
+ true when a finalizer call has been inserted. */
+
+static 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 +1039,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,
@@ -1055,17 +1165,11 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
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)
{
- 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
{
@@ -1077,9 +1181,11 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
&& 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);
+ if (!attr.allocatable || !gfc_is_coarray (var))
+ {
+ gfc_init_se (&se, NULL);
+ array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+ }
gcc_assert (se.post.head == NULL_TREE);
}
}
@@ -1095,22 +1201,15 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
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))
+ if (array_expr->rank)
{
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);
@@ -1119,16 +1218,22 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
&& 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);
+ 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,
@@ -1151,6 +1256,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 +1301,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/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/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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-05-30 10:25 ` Tobias Burnus
@ 2013-05-31 11:03 ` Tobias Burnus
2013-05-31 16:36 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2013-05-31 11:03 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1680 bytes --]
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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: finalize-alloc-v3.diff --]
[-- Type: text/x-patch; name="finalize-alloc-v3.diff", Size: 42243 bytes --]
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-05-31 11:03 ` Tobias Burnus
@ 2013-05-31 16:36 ` Tobias Burnus
2013-06-03 10:22 ` *ping* - " Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2013-05-31 16:36 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2177 bytes --]
And another one: I just realized that the following dead code can be
removed (twice):
+ if (TREE_CODE (array) == ADDR_EXPR
+ && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
+ tmp = TREE_OPERAND (array, 0);
As "tmp" is not used. That's part of gfc_build_final_call,thus, I cannot
easily do it as follow up patch.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
Tobias Burnus wrote:
> 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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: finalize-alloc-v4.diff --]
[-- Type: text/x-patch; name="finalize-alloc-v4.diff", Size: 33595 bytes --]
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..a1ea300 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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;
+ }
+
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* *ping* - Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-05-31 16:36 ` Tobias Burnus
@ 2013-06-03 10:22 ` Tobias Burnus
2013-06-04 8:57 ` Mikael Morin
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2013-06-03 10:22 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1549 bytes --]
* PING *
Attached is just a re-diff.
OK for the trunk?
Tobias
PS: This patch blocks the patch for finalization of nonallocatable
intent(out) at http://gcc.gnu.org/ml/fortran/2013-05/msg00135.html (with
additional test case at
http://gcc.gnu.org/ml/fortran/2013-05/msg00141.html). It additionally
blocks me from working on follow-up patches.
On May 31, 2013, Tobias Burnus wrote:
> And another one: I just realized that the following dead code can be
> removed (twice):
> + if (TREE_CODE (array) == ADDR_EXPR
> + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
> + tmp = TREE_OPERAND (array, 0);
> As "tmp" is not used. That's part of gfc_build_final_call,thus, I
> cannot easily do it as follow up patch.
[...]
>>> On Wed, May 29, 2013, 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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: finalize-alloc-v5.diff --]
[-- Type: text/x-patch; name="finalize-alloc-v5.diff", Size: 41967 bytes --]
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.
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..7521dee 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3872,7 +3892,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..a1ea300 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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,
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..04ee7f2 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: *ping* - Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-06-03 10:22 ` *ping* - " Tobias Burnus
@ 2013-06-04 8:57 ` Mikael Morin
2013-06-04 10:06 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Mikael Morin @ 2013-06-04 8:57 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Le 03/06/2013 12:22, Tobias Burnus a écrit :
> * PING *
>
> Attached is just a re-diff.
>
> OK for the trunk?
>
Hello, it looks good; one question below...
> diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
> index 100ec18..7521dee 100644
> --- a/gcc/fortran/trans-decl.c
> +++ b/gcc/fortran/trans-decl.c
> @@ -3872,7 +3892,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)
>
No check for !sym->attr.save here?
There are several places through the patch where we check whether a
variable needs end of scope automatic deallocation. Might be worth
factoring the checks to a common predicate.
The patch is OK in any case; thanks.
Mikael
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: *ping* - Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables
2013-06-04 8:57 ` Mikael Morin
@ 2013-06-04 10:06 ` Tobias Burnus
0 siblings, 0 replies; 7+ messages in thread
From: Tobias Burnus @ 2013-06-04 10:06 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Mikael Morin wrote:
>> +++ b/gcc/fortran/trans-decl.c
>> @@ -3872,7 +3892,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)
> No check for !sym->attr.save here?
The code is in a big if block which has:
if (!sym->attr.save && gfc_option.flag_max_stack_var_size != 0)
{
> There are several places through the patch where we check whether a
> variable needs end of scope automatic deallocation. Might be worth
> factoring the checks to a common predicate.
Probably yes. One other case which needs some refactoring* is allocate:
We currently immediately distinguish between arrays and scalars - and
only the scalar code handles "allocate(character(len=5) :: str)" - the
array code duplicates part of the code, but not fully.
> The patch is OK in any case; thanks.
Thanks for the review!
Tobias
* To my surprise, the word "refactor"/"refactoring" does not exist in
Marriam Webbster, nor in the Oxford Dictionary of English (or
oxfordreference.com). On the other hand, it has a wikipedia page,
thousands of book and article titles, dating back to the 60s and
seemingly it is more widely used since the 1990s/2000s.
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2013-06-04 10:06 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-05-29 8:28 [Patch, Fortran] Enable FINALization/poly dealloc for allocatables Tobias Burnus
2013-05-30 10:25 ` Tobias Burnus
2013-05-31 11:03 ` Tobias Burnus
2013-05-31 16:36 ` Tobias Burnus
2013-06-03 10:22 ` *ping* - " Tobias Burnus
2013-06-04 8:57 ` Mikael Morin
2013-06-04 10:06 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).