Hi Sandra,
Some weeks ago Andrew Benson triggered me to recover a patch for
finalization in ordinary assignment. I have attached the patch and the
testcase for early review. The main change that the patch makes is to call
Tobias's finalization wrapper rather than the direct finalizer calls from
structure_alloc_comps. This ensures that finalization and deallocation
occur in the correct order for finalizable extended types with finalizable
components. I think that the chunks in resolve.c for WHERE assignment are
possibly incorrect. I will be checking the standards before submission.
We have been checking out a standards issue with the reduced testcase
'clf_demo.f90', which is also attached. A certain other brand finalizes
SOURCE in ALLOCATE (res, SOURCE = src) in the function 'constructor'. I can
find no mention of this being required in either the F2008 or F2018
standards.
Regards
Paul
On Mon, 1 Nov 2021 at 21:13, Sandra Loosemore <[email protected]>
wrote:
> With my documentation maintainer hat on, I've been working on updating
> the standards compliance and TS29113-related material in the GNU Fortran
> manual (patches will be posted soon). I also spent some time going
> through the related wiki pages a few days ago to get them updated as well.
>
> For F2003
>
> https://gcc.gnu.org/wiki/Fortran2003Status
>
> the only thing missing before we can claim full support is some cases of
> finalization -- see comment #27 in PR37336.
>
> For F2008
>
> https://gcc.gnu.org/wiki/Fortran2008Status
>
> we are missing only PR78219 (affecting DO CONCURRENT and FORALL) and the
> "Data statement restrictions lifted" item.
>
> I think it would be a Good Thing to be able to claim full implementation
> of these standards, so is anybody interested in tackling these issues in
> the time left for GCC 12? I wouldn't mind working on one or more of
> these myself, but it looks like my management has different plans for my
> time now that the TS29113-related work is winding down. :-S
>
> -Sandra
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index af71b132dec..f8b17e29a8d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10490,6 +10490,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
if (e && !resolve_where_shape (cnext->expr1, e))
gfc_error ("WHERE assignment target at %L has "
"inconsistent shape", &cnext->expr1->where);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
@@ -10577,6 +10581,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
/* WHERE assignment statement */
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
/* WHERE operator assignment statement */
@@ -10623,6 +10631,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+ if (c->op == EXEC_ASSIGN)
+ c->expr1->must_finalize = 1;
+
break;
case EXEC_ASSIGN_CALL:
@@ -12052,6 +12064,9 @@ start:
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
+ if (code->op == EXEC_ASSIGN)
+ code->expr1->must_finalize = 1;
+
break;
case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5ceb261b698..d67b2b82ec2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5656,7 +5656,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_se se;
int n;
- type = TREE_TYPE (descriptor);
+ if (expr->ts.type == BT_CLASS
+ && expr3_desc != NULL_TREE
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+ type = TREE_TYPE (expr3_desc);
+ else
+ type = TREE_TYPE (descriptor);
stride = gfc_index_one_node;
offset = gfc_index_zero_node;
@@ -8921,7 +8926,7 @@ static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree dest, int rank, int purpose, int caf_mode,
- gfc_co_subroutines_args *args)
+ gfc_co_subroutines_args *args, bool no_finalization)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -9009,11 +9014,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP, caf_mode, args);
+ COPY_ALLOC_COMP, caf_mode, args,
+ no_finalization);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
gfc_add_expr_to_block (&loopbody, tmp);
@@ -9047,13 +9053,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, args);
+ DEALLOCATE_PDT_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- NULLIFY_ALLOC_COMP, 0, args);
+ NULLIFY_ALLOC_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -9111,7 +9119,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9119,7 +9127,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9215,8 +9224,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
continue;
}
- if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
/* Call the finalizer, which will free the memory and nullify the
pointer of an array. */
deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -9244,7 +9253,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9252,7 +9261,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9550,7 +9560,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode, args);
+ rank, purpose, caf_mode, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@@ -9586,7 +9597,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose, caf_mode
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
- args);
+ args, no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
@@ -9694,7 +9705,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
else
add_when_allocated = NULL_TREE;
@@ -10067,7 +10079,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
@@ -10080,7 +10093,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
tree
@@ -10118,7 +10132,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
BCAST_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ &args, false);
return tmp;
}
@@ -10128,10 +10143,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
status of coarrays. */
tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+ bool no_finalization)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP, 0, NULL);
+ DEALLOCATE_ALLOC_COMP, 0, NULL,
+ no_finalization);
}
@@ -10139,7 +10156,8 @@ tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ NULL, false);
}
@@ -10151,7 +10169,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
int caf_mode)
{
return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
- caf_mode, NULL);
+ caf_mode, NULL, false);
}
@@ -10162,7 +10180,7 @@ tree
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
{
return structure_alloc_comps (der_type, decl, dest, rank,
- COPY_ONLY_ALLOC_COMP, 0, NULL);
+ COPY_ONLY_ALLOC_COMP, 0, NULL, false);
}
@@ -10177,7 +10195,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- ALLOCATE_PDT_COMP, 0, NULL);
+ ALLOCATE_PDT_COMP, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -10189,7 +10207,7 @@ tree
gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, NULL);
+ DEALLOCATE_PDT_COMP, 0, NULL, false);
}
@@ -10204,7 +10222,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- CHECK_PDT_DUMMY, 0, NULL);
+ CHECK_PDT_DUMMY, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -10925,7 +10943,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
&& expr1->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
- expr1->rank);
+ expr1->rank, true);
gfc_add_expr_to_block (&realloc_block, tmp);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 12068c742a5..0bacf657a3c 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,7 +56,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+ bool no_finalization = false);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e7aec3845d3..0771920009e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -49,10 +49,10 @@ static tree
gfc_get_character_len (tree type)
{
tree len;
-
+
gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_STRING_FLAG (type));
-
+
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
len = (len) ? (len) : (integer_zero_node);
return fold_convert (gfc_charlen_type_node, len);
@@ -66,10 +66,10 @@ tree
gfc_get_character_len_in_bytes (tree type)
{
tree tmp, len;
-
+
gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_STRING_FLAG (type));
-
+
tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
@@ -10421,7 +10421,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (dealloc)
{
tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+ 0, true);
if (deep_copy)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
@@ -11383,6 +11384,89 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
}
+ /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+ (10.2.1.3), if the variable is not an unallocated allocatable variable,
+ it is finalized after evaluation of expr and before the definition of
+ the variable. If the variable is an allocated allocatable variable, or
+ has an allocated allocatable subobject, that would be deallocated by
+ intrinsic assignment, the finalization occurs before the deallocation */
+
+static tree
+gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag)
+{
+ stmtblock_t final_block;
+ gfc_init_block (&final_block);
+ symbol_attribute lhs_attr;
+ tree final_expr;
+ tree ptr;
+ tree cond;
+ gfc_se se;
+
+ /* We have to exclude vtable procedures (_copy and _final especially), uses
+ of gfc_trans_assignment_1 in initialization and allocation before trying
+ to build a final call. */
+ if (!expr1->must_finalize
+ || expr1->symtree->n.sym->attr.artificial
+ || expr1->symtree->n.sym->ns->proc_name->attr.artificial
+ || init_flag)
+ return NULL_TREE;
+
+ if (!(expr1->ts.type == BT_CLASS
+ || (expr1->ts.type == BT_DERIVED
+ && gfc_is_finalizable (expr1->ts.u.derived, NULL)))
+ || !gfc_add_finalizer_call (&final_block, expr1))
+ return NULL_TREE;
+
+ lhs_attr = gfc_expr_attr (expr1);
+
+ /* Check allocatable/pointer is allocated/associated. */
+ if (lhs_attr.allocatable || lhs_attr.pointer)
+ {
+ if (expr1->ts.type == BT_CLASS)
+ {
+ ptr = gfc_get_class_from_gfc_expr (expr1);
+ gcc_assert (ptr != NULL_TREE);
+ ptr = gfc_class_data_get (ptr);
+ if (lhs_attr.dimension)
+ ptr = gfc_conv_descriptor_data_get (ptr);
+ }
+ else
+ {
+ gfc_init_se (&se, NULL);
+ if (expr1->rank)
+ {
+ gfc_conv_expr_descriptor (&se, expr1);
+ ptr = gfc_conv_descriptor_data_get (se.expr);
+ }
+ else
+ {
+ gfc_conv_expr (&se, expr1);
+ ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+ }
+
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ ptr, build_zero_cst (TREE_TYPE (ptr)));
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, gfc_finish_block (&final_block),
+ build_empty_stmt (input_location));
+ }
+ else
+ final_expr = gfc_finish_block (&final_block);
+
+ /* Check optional present. */
+ if (expr1->symtree->n.sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (expr1->symtree->n.sym);
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, final_expr,
+ build_empty_stmt (input_location));
+ }
+
+ return final_expr;
+}
+
+
static tree
trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
@@ -11390,6 +11474,16 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
{
tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ tree final_expr;
+
+ final_expr = gfc_assignment_finalizer_call (lhs, false);
+ if (final_expr != NULL_TREE)
+ {
+ if (rse->loop)
+ gfc_prepend_expr_to_block (&rse->loop->pre, final_expr);
+ else
+ gfc_add_expr_to_block (block, final_expr);
+ }
/* Store the old vptr so that dynamic types can be compared for
reallocation to occur or not. */
@@ -11515,6 +11609,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
@@ -11538,6 +11633,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ tree final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
@@ -11578,6 +11674,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
needed at two locations, so do it once only before the information is
needed. */
lhs_attr = gfc_expr_attr (expr1);
+
is_poly_assign = (use_vptr_copy || lhs_attr.pointer
|| (lhs_attr.allocatable && !lhs_attr.dimension))
&& (expr1->ts.type == BT_CLASS
@@ -11851,6 +11948,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
else
gfc_add_expr_to_block (&loop.post, tmp2);
}
+
+ expr1->must_finalize = 0;
}
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11905,8 +12004,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
- /* Add the pre blocks to the body. */
- gfc_add_block_to_block (&body, &rse.pre);
+ /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+ after evaluation of the rhs and before reallocation. */
+ final_expr = gfc_assignment_finalizer_call (expr1, init_flag);
+ if (final_expr)
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_expr_to_block (&block, final_expr);
+ }
+ else
+ {
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr);
+ }
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.pre);
+
+ /* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Add the post blocks to the body. */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
index 0f1e9b67287..60f35836cdb 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
@@ -5,7 +5,7 @@
! Contributed by Thomas Koenig <[email protected]>
! Andre Vehreschild <[email protected]>
!
-
+
module m1
implicit none
private
@@ -35,7 +35,7 @@ type, extends(basetype) :: exttype
endtype exttype
type :: factory
- integer(I_P) :: steps=-1
+ integer(I_P) :: steps=-1
contains
procedure, pass(self), public :: construct
endtype factory
@@ -68,7 +68,7 @@ endmodule m2
if (d%i2 /= 5) STOP 2
class default
STOP 3
- end select
+ end select
if (d%i /= 2) STOP 4
deallocate(c1)
deallocate(prev)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
end function func_foo_a
end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }
! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
implicit none
type :: simple
integer :: ind
contains
final :: destruct1, destruct2
end type simple
integer :: check_scalar
integer :: check_array(2)
integer :: final_count = 0
contains
subroutine destruct1(self)
type(simple), intent(inout) :: self
! print *, "DESTRUCTING SCALAR", self%ind
check_scalar = self%ind
check_array = 0
final_count = final_count + 1
end subroutine destruct1
subroutine destruct2(self)
type(simple), intent(inout) :: self(:)
! print *, "DESTRUCTING ARRAY", self%ind
check_scalar = 0
check_array = self%ind
final_count = final_count + 1
end subroutine destruct2
subroutine test (cnt, scalar, array, off)
integer :: cnt
integer :: scalar
integer :: array(:)
integer :: off
if (final_count .ne. cnt) stop 1 + off
if (check_scalar .ne. scalar) stop 2 + off
if (any (check_array .ne. array)) stop 3 + off
end subroutine test
end module testmode
program test_final
use testmode
implicit none
type(simple), allocatable :: myres, myres2
type(simple), allocatable :: myarray(:)
type(simple) :: thyres = simple(21), thyres2 = simple(22)
class(*), allocatable :: mystar
class(*), allocatable :: mystararray(:)
! Since myres is not allocated there should be no final call.
myres = thyres
if (final_count .ne. 0) stop 1
if (.not. allocated(myres)) allocate(myres)
allocate(myres2)
myres%ind = 1
myres2%ind = 2
myres = myres2
call test(1, 1, [0,0], 10)
allocate(myarray(2))
myarray%ind = [42, 43]
myarray = [thyres, thyres2]
call test(2, 0, [42,43], 20)
thyres2 = simple(99)
call test(3, 22, [0,0], 30)
thyres = thyres2
call test(4, 21, [0,0], 40)
deallocate (myres, myres2)
call test(6, 2, [0,0], 100)
deallocate (myarray)
call test(7, 0, [21,22], 200)
allocate (mystar, source = simple (3))
mystar = simple (4)
call test(8, 3, [0,0], 50)
deallocate (mystar)
call test(9, 4, [0,0], 60)
allocate (mystararray, source = [simple (5), simple (6)])
mystararray = [simple (7), simple (8)]
call test(10, 0, [5,6], 70)
deallocate (mystararray)
call test(11, 0, [7,8], 80)
end program test_final
! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
implicit none
character(4) :: scope = "MAIN"
type :: simple
character(4) :: scope
integer :: ind
contains
final :: simple_destructor
end type simple
type, extends(simple) :: complicated
real :: rind
contains
final :: complicated_destructor
end type complicated
contains
subroutine simple_destructor(self)
type(simple), intent(inout) :: self(:)
print *, " simple_destructor(", self(1)%scope, ") ", self%ind
end subroutine simple_destructor
subroutine complicated_destructor(self)
type(complicated), intent(inout) :: self(:)
print *, "complicated_destructor(", self(1)%scope, ") ", size(self%rind), self%rind
end subroutine complicated_destructor
function constructor(ind, rind) result(res)
class(simple), allocatable :: res(:)
integer, intent(in) :: ind(:)
real, intent(in) :: rind(:)
type(complicated), allocatable :: src(:)
integer :: i
scope = "CTR2"
src = [(complicated ("ACTR", ind(i), rind(i)), i = 1, 2)]
allocate (res, source = src)
src%scope = "SRC "
res%scope=scope
end function constructor
end module testmode
program test_final
use testmode
implicit none
class(simple), allocatable :: MyClassArray(:)
MyClassArray = constructor ([10,20], [10.0,20.0])
print *, MyClassArray%scope
end program test_final
