From: Paul Richard Thomas <paul.richard.thomas@gmail.com>
To: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>,
gcc-patches <gcc-patches@gcc.gnu.org>
Subject: [Patch, fortran] PR64290 - [F03] No finalization at deallocation of LHS
Date: Mon, 17 Jan 2022 11:57:38 +0000 [thread overview]
Message-ID: <CAGkQGi+r=sshyVV5BiR9qTd1EKOcadHydS3Vc_ZHc3VDg2p5aQ@mail.gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 3432 bytes --]
Hi All,
Strictly speaking, the attached patch is branching out into a more
generalised attack on PR37336(Finalization) - [F03] Finish derived-type
finalization but most of it fixes PR64290.
I started work on this patch almost a year ago but had to drop it due
daytime work pressure and only picked it up again a couple of weeks back.
It is not, as yet, complete but I thought to post it in its present form
because stage 3 ended yesterday.
The main thrusts of the patch are:
(i) To correct the order taken by finalization and deallocation of
components for the lhs of assignments. This is done instead by a call to
Tobias' finalization wrapper, rather than performing finalization component
by component in structure_alloc_comps;
(ii) To add finalization of scalar derived type function results, again by
use of the finalization wrapper. This points to a problem that I haven't
yet managed to fix, F2018(7.5.6.3 para 5) "If an executable construct
references a nonpointer function, the result is finalized after execution
of the innermost executable construct containing the reference." I have
been struggling to avoid implementing this by introducing a finalization
block into gfc_se but have run out of ideas as to how to do it otherwise.
(eg. Try using a finalizable function as the actual argument of another
procedure.); and
(iii) Once (ii) is added, a segfault occurs if the derived type has
allocatable, finalizable components. (PR96122) This occurred because the
call to the component finalization wrapper was missing two arguments in the
call; most particularly 'byte_stride'.
There is still quite a lot to do to bring together common code chunks, fix
the ordering requirement of F2018 (7.5.6.3 para 5), add more testcases.
It's certainly not ready to be committed yet :-(
Regards
Paul
Fortran:Implement missing finalization features [PR64290]
2022-01-17 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/103854
* class.c (has_finalizer_component): Do not return true for
procedure pointer components.
PR fortran/96087
* class.c (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.
PR fortran/64290
* resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
* trans-array.c (structure_alloc_comps): Add boolean argument
to suppress finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
* trans-expr.c (gfc_conv_procedure_call): Call finalizer for
finalizable scalar function results.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(trans_class_assignment, gfc_trans_assignment_1): Call it and
add the block between the rhs evaluation and any reallocation
on assignment that there might be.
gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 24141 bytes --]
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2cb0c6572bd..18289eaffe8 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
gfc_component *c;
for (c = derived->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+ if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+ && c->attr.flavor != FL_PROCEDURE)
{
if (c->ts.u.derived->f2k_derived
&& c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
{
/* Call FINAL_WRAPPER (comp); */
gfc_code *final_wrap;
- gfc_symbol *vtab;
+ gfc_symbol *vtab, *byte_stride;
+ gfc_expr *scalar, *size_expr, *fini_coarray_expr;
gfc_component *c;
vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
break;
gcc_assert (c);
+
+ /* Set scalar argument for storage_size. */
+ gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts = e->ts;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
+ gfc_commit_symbol (byte_stride);
+ scalar = gfc_lval_expr_from_sym (byte_stride);
+
final_wrap = gfc_get_code (EXEC_CALL);
final_wrap->symtree = c->initializer->symtree;
final_wrap->resolved_sym = c->initializer->symtree->n.sym;
final_wrap->ext.actual = gfc_get_actual_arglist ();
final_wrap->ext.actual->expr = e;
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ scalar,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* Which provides the argument 'byte_stride'..... */
+ final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->expr = size_expr;
+
+ /* ...and last of all the 'fini_coarray' argument. */
+ fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+ final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
if (*code)
{
(*code)->next = final_wrap;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 43eeefee07f..e4b60a44a59 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10512,6 +10512,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;
@@ -10599,6 +10603,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 */
@@ -10645,6 +10653,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:
@@ -12069,6 +12081,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 a77f3318846..e06b8ba4eb2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
{
gcc_assert (expr->ts.type == BT_CHARACTER);
-
+
tmp = gfc_get_character_len_in_bytes (tmp);
-
+
if (tmp == NULL_TREE || integer_zerop (tmp))
{
tree bs;
@@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, bs);
}
-
+
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
}
@@ -5657,7 +5657,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;
@@ -7478,7 +7483,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (!se->direct_byref)
se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -8922,7 +8927,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;
@@ -9010,11 +9015,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);
@@ -9048,13 +9054,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);
}
@@ -9112,7 +9120,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
{
@@ -9120,7 +9128,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);
}
}
@@ -9216,8 +9225,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,
@@ -9245,7 +9254,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
{
@@ -9253,7 +9262,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);
}
}
@@ -9551,7 +9561,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;
@@ -9587,7 +9598,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);
}
}
@@ -9695,7 +9706,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;
@@ -10068,7 +10080,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);
}
@@ -10081,7 +10094,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
@@ -10119,7 +10133,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;
}
@@ -10129,10 +10144,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);
}
@@ -10140,7 +10157,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);
}
@@ -10152,7 +10170,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);
}
@@ -10163,7 +10181,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);
}
@@ -10178,7 +10196,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;
}
@@ -10190,7 +10208,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);
}
@@ -10205,7 +10223,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;
}
@@ -10926,7 +10944,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 04fee617590..3aae4d2c4eb 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 2e15a7e874c..e666c41517b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7675,9 +7675,58 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Allocatable scalar function results must be freed and nullified
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
+ bool allocatable = comp ? comp->attr.allocatable
+ && !comp->attr.dimension
+ : sym->attr.allocatable
+ && !sym->attr.dimension;
+ bool finalizable = comp ? comp->ts.type == BT_DERIVED
+ && gfc_is_finalizable (comp->ts.u.derived, NULL)
+ : sym->ts.type == BT_DERIVED
+ && gfc_is_finalizable (sym->ts.u.derived, NULL);
+ if (!byref && finalizable)
+ {
+ tree vptr, final_fndecl, desc;
+ gfc_symbol *vtab;
+ gfc_se post_se;
+ tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify (&se->pre, tmp, se->expr);
+ se->expr = tmp;
+ tmp = gfc_evaluate_now (se->expr, &se->pre);
+ gfc_add_expr_to_block (&se->pre,
+ gfc_copy_alloc_comp (comp ? comp->ts.u.derived
+ : sym->ts.u.derived,
+ se->expr, tmp, 0, 0));
+ vtab = comp ? gfc_find_derived_vtab (comp->ts.u.derived)
+ : gfc_find_derived_vtab (sym->ts.u.derived);
+ if (vtab->backend_decl == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ else
+ vptr = vtab->backend_decl;
+ vptr = gfc_build_addr_expr (NULL, vptr);
+
+ final_fndecl = gfc_vptr_final_get (vptr);
+ final_fndecl = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ gfc_init_se (&post_se, NULL);
+ desc = gfc_conv_scalar_to_descriptor (&post_se, tmp,
+ comp ? comp->attr
+ : sym->attr);
+ gfc_add_expr_to_block (&post, gfc_finish_block (&post_se.pre));
+ desc = build_call_expr_loc (input_location,
+ final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ gfc_vptr_size_get (vptr),
+ boolean_false_node);
+ gfc_add_expr_to_block (&post, desc);
+ if (allocatable)
+ {
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&post, tmp);
+ }
+ }
+
if (!byref && sym->ts.type != BT_CHARACTER
- && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
- || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+ && allocatable && !finalizable)
{
tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, tmp, se->expr);
@@ -10430,7 +10479,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);
@@ -11387,6 +11437,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,
@@ -11394,6 +11527,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. */
@@ -11519,6 +11662,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
@@ -11542,6 +11686,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;
@@ -11582,6 +11727,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
@@ -11855,6 +12001,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
@@ -11909,8 +12057,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_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" } }
[-- Attachment #3: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 5940 bytes --]
! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
implicit none
type :: simple
integer :: ind
contains
final :: destructor1, destructor2
end type simple
type, extends(simple) :: complicated
real :: rind
contains
final :: destructor3, destructor4
end type complicated
integer :: check_scalar
integer :: check_array(4)
real :: check_real
real :: check_rarray(4)
integer :: final_count = 0
contains
subroutine destructor1(self)
type(simple), intent(inout) :: self
check_scalar = self%ind
check_array = 0
final_count = final_count + 1
end subroutine destructor1
subroutine destructor2(self)
type(simple), intent(inout) :: self(:)
check_scalar = 0
check_array(1:size(self, 1)) = self%ind
final_count = final_count + 1
end subroutine destructor2
subroutine destructor3(self)
type(complicated), intent(inout) :: self
check_real = self%rind
check_array = 0.0
final_count = final_count + 1
end subroutine destructor3
subroutine destructor4(self)
type(complicated), intent(inout) :: self(:)
check_real = 0.0
check_rarray(1:size(self, 1)) = self%rind
final_count = final_count + 1
end subroutine destructor4
function constructor1(ind) result(res)
type(simple), allocatable :: res
integer, intent(in) :: ind
allocate (res, source = simple (ind))
end function constructor1
function constructor2(ind, rind) result(res)
class(simple), allocatable :: res(:)
integer, intent(in) :: ind(:)
real, intent(in), optional :: rind(:)
type(complicated), allocatable :: src(:)
integer :: sz
integer :: i
if (present (rind)) then
sz = min (size (ind, 1), size (rind, 1))
src = [(complicated (ind(i), rind(i)), i = 1, sz)]
allocate (res, source = src)
else
sz = size (ind, 1)
allocate (res, source = [(simple (ind(i)), i = 1, sz)])
end if
end function constructor2
subroutine test (cnt, scalar, array, off, rind, rarray)
integer :: cnt
integer :: scalar
integer :: array(:)
integer :: off
real, optional :: rind
real, optional :: rarray(:)
if (final_count .ne. cnt) stop 1 + off
if (check_scalar .ne. scalar) stop 2 + off
if (any (check_array(1:size (array, 1)) .ne. array)) stop 3 + off
if (present (rind)) then
if (check_real .ne. rind) stop 4 + off
end if
if (present (rarray)) then
if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) stop 5 + off
end if
end subroutine test
end module testmode
program test_final
use testmode
implicit none
type(simple), allocatable :: MyType, MyType2
type(simple), allocatable :: MyTypeArray(:)
type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
class(simple), allocatable :: MyClass
class(simple), allocatable :: MyClassArray(:)
! ************************
! Derived type assignments
! ************************
! Since MyType is not allocated there should be no final call because
! there is nothing to finalize; ie. MyType is nullified on entry to scope.
MyType = ThyType
! ifort triggers this with final_count = 1 and ind = 0.
call test(0, 0, [0,0], 0)
if (.not. allocated(MyType)) allocate(MyType)
allocate(MyType2)
MyType%ind = 1
MyType2%ind = 2
! This should result in a final call with self = simple(1).
MyType = MyType2
call test(1, 1, [0,0], 10)
allocate(MyTypeArray(2))
MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
MyTypeArray = [ThyType, ThyType2]
call test(2, 0, [42,43], 20)
! This should result in a final call with self = initialization = simple(22).
ThyType2 = simple(99)
call test(3, 22, [0,0], 30)
! This should result in a final call with self = simple(22).
ThyType = ThyType2
call test(4, 21, [0,0], 40)
! This should result in two final calls; the last is for self2 = simple(2).
deallocate (MyType, MyType2)
call test(6, 2, [0,0], 50)
! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
deallocate (MyTypeArray)
call test(7, 0, [21,22], 60)
! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
allocate (MyType, source = simple (11))
MyType = constructor1 (99)
call test(9, 99, [0,0], 70)
deallocate (MyType)
! *****************
! Class assignments
! *****************
final_count = 0
allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
MyClass = simple (4)
call test(1, 3, [0,0], 100)
! This should result in a final call with the assigned value.
deallocate (MyClass)
call test(2, 4, [0,0], 110)
allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call.
call test(2, 4, [0,0], 120)
MyClassArray = [simple (7), simple (8)]
! The final call should return the allocated value.
call test(3, 0, [5,6], 130)
! This should result in a final call with the assigned value.
deallocate (MyClassArray)
call test(4, 0, [7,8], 140)
! This should produce no final calls.
allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
! This should produce calls to destructor4 then destructor2.
deallocate (MyClassArray)
! ifort correctly calls the rank 1 finalizer for the extended type
! but then calls the parent type finalizer for each element.
call test(6, 0, [1, 3], 150, rarray = [2.0, 4.0])
! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
MyClassArray = constructor2 ([10,20], [10.0,20.0])
call test(10, 0, [10,20], 160, rarray = [10.0,20.0])
deallocate (MyClassArray)
call test(12, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final
next reply other threads:[~2022-01-17 11:57 UTC|newest]
Thread overview: 2+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-01-17 11:57 Paul Richard Thomas [this message]
-- strict thread matches above, loose matches on Subject: below --
2021-01-14 16:20 Paul Richard Thomas
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CAGkQGi+r=sshyVV5BiR9qTd1EKOcadHydS3Vc_ZHc3VDg2p5aQ@mail.gmail.com' \
--to=paul.richard.thomas@gmail.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).