This patch has been an excessively long time in coming. Please accept my
apologies for that.
All but two of the PR37336 dependencies are fixed, The two exceptions are
PRs 59694 and 65347. The former involves lack of finalization of an
unreferenced entity declared in a block, which I am sure is trivial but I
cannot see where the missing trigger is, and the latter involves
finalization of function results within an array constructor, for which I
will submit an additional patch shortly. PR104272 also remains, in which
finalization is occurring during allocation. I fixed this in one place but
it seems to have crept out in another :-)
Beyond this patch and ones for the three lagging PRs above, a thorough tidy
up and unification of finalization is needed. However, I will concentrate
on functionality in the first instance.
I have tried to interpret F2018 7.5.6.2 and 7.5.6.3 as well as possible.
This is not always straightforward and has involved a lot of head
scratching! I have used the Intel compiler as a litmus test for the
outcomes. This was largely motivated by the observation that, in the user
survey conducted by Steve Lionel, gfortran and ifort are often used
together . Therefore, quite aside from wishing to comply with the standard
as far as possible, it is more than reasonable that the two compilers
comply. On application of this patch, only exception to this is the
treatment of finalization of arrays of extended types, where the Intel
takes "If the entity is of extended type and the parent type is
finalizable, the parent component is finalized" such that the parent
component is finalized one element at a time, whereas gfortran finalises
the parent components as an array. I strongly suspect that, from reading
7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However, this
is another issue to come back to in the future.
The work centred on three areas:
(i) Finalization on assignment:
This was required because finalization of the lhs was occurring at the
wrong time relative to evaluation of the rhs expression and was taking the
finalization of entities with finalizable components in the wrong order.
The changes in trans-array.cc (structure_alloc_comps) allow
gfc_deallocate_alloc_comp_no_caf to occur without finalization so that it
can be preceded by calls to the finalization wrapper. The other key change
in this area is the addition of trans-expr.cc
(gfc_assignment_finalizer_call), which manages the ordering of finalization
and deallocation.
(ii) Finalization of derived type function results.
Previously, finalization was not occuring at all for derived type results
but it did for class results. The former is now implemented in
trans-expr.cc (finalize_function_result), into which the treatment of class
finalization has been included. In order to handled complex expressions
correctly, an extra block has been included in gfc_se and is initialized in
gfc_init_se. This block accumulates the finalizations so that they can be
added at the right time. It is the way in which I will fix PR65347 (I have
already tested the principle).
(iii) Minor fixes
These include the changes in class.cc and the exclusion of artificial
entities from finalization.
There are some missing testcases (sorry Andrew and Sandro!), which might
not be necessary because the broken/missing features are already fixed. The
fact that the work correctly now is a strong indication that this is the
case.
Regtests OK on FC33/x86_64 - OK for mainline (and 11-branch)?
Best regards
Paul
Fortran:Implement missing finalization features [PR37336]
2022-02-02 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/103854
* class.cc (has_finalizer_component): Do not return true for
procedure pointer components.
PR fortran/96122
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.
PR fortran/37336
* class.cc (finalizer_insert_packed_call): Remove the redundant
argument in the call to the final subroutine.
* resolve.cc (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.cc (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. Add a second, additional boolean argument to nullify
pointer components and use it in gfc_copy_alloc_comp_del_ptrs.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_copy_alloc_comp_del_ptrs): New function.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
Add prototype for gfc_copy_alloc_comp_del_ptrs.
* trans-expr.cc (gfc_init_se): Initialize finalblock.
(finalize_function_result): New function that finalizes
function results in the correct order.
(gfc_conv_procedure_call): Use new function for finalizable
function results. Replace in-line block for class results with
call to new function.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf. Add the
finalization blocks to the main block.
(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.
* trans-io.cc (gfc_trans_transfer): Add the final block.
* trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise.
* trans.cc (gfc_add_finalizer_call): Exclude artificial
entities.
* trans.h: Add finalblock to gfc_se.
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.
PR fortran/67444
* gfortran.dg/finalize_39.f90 : New test.
PR fortran/67471
* gfortran.dg/finalize_40.f90 : New test.
PR fortran/69298
PR fortran/70863
* gfortran.dg/finalize_41.f90 : New test.
PR fortran/71798
* gfortran.dg/finalize_42.f90 : New test.
PR fortran/80524
* gfortran.dg/finalize_43.f90 : New test.
PR fortran/82996
* gfortran.dg/finalize_44.f90 : New test.
PR fortran/84472
* gfortran.dg/finalize_45.f90 : New test.
PR fortran/88735
PR fortran/93691
* gfortran.dg/finalize_46.f90 : New test.
PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 731e9b0fe6a..a249eea4a30 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -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;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->next->resolved_sym = fini->proc_tree->n.sym;
block->next->ext.actual = gfc_get_actual_arglist ();
block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
- block->next->ext.actual->next = gfc_get_actual_arglist ();
- block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
/* ELSE. */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 835a4783718..fe17df2f73d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -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:
@@ -11324,6 +11336,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
tmp->n.sym->attr.use_assoc = 0;
tmp->n.sym->attr.intent = INTENT_UNKNOWN;
+
if (as)
{
tmp->n.sym->as = gfc_copy_array_spec (as);
@@ -12069,6 +12082,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.cc b/gcc/fortran/trans-array.cc
index cfb6eac11c7..689628e1cb6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -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);
}
@@ -7478,7 +7478,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)
{
@@ -8910,7 +8910,8 @@ gfc_caf_is_dealloc_only (int caf_mode)
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
- function for the functions named in this enum. */
+ function for the functions named in this enum. When del_ptrs is set with
+ COPY_ALLOC_COMP, pointers are nullified. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
@@ -8920,9 +8921,11 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
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)
+structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
+ int rank, int purpose, int caf_mode,
+ gfc_co_subroutines_args *args,
+ bool no_finalization = false,
+ bool del_ptrs = false)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -9010,11 +9013,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 +9052,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);
}
@@ -9116,7 +9122,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
{
@@ -9124,7 +9130,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);
}
}
@@ -9240,8 +9247,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,
@@ -9269,7 +9276,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
{
@@ -9277,7 +9284,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);
}
}
@@ -9575,7 +9583,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;
@@ -9611,14 +9620,14 @@ 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);
}
}
break;
case COPY_ALLOC_COMP:
- if (c->attr.pointer || c->attr.proc_pointer)
+ if ((c->attr.pointer && !del_ptrs) || c->attr.proc_pointer)
continue;
/* We need source and destination components. */
@@ -9660,6 +9669,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
dst_data = gfc_conv_descriptor_data_get (dst_data);
}
+ if (CLASS_DATA (c)->attr.pointer)
+ {
+ gfc_add_modify (&fnblock, dst_data,
+ build_int_cst (TREE_TYPE (dst_data), 0));
+ continue;
+ }
+
gfc_init_block (&tmpblock);
gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
@@ -9706,6 +9722,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp, null_data));
continue;
}
+ else if (c->attr.pointer)
+ {
+ if (c->attr.dimension)
+ tmp = gfc_conv_descriptor_data_get (dcmp);
+ else
+ tmp = dcmp;
+ gfc_add_modify (&fnblock, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ continue;
+ }
+
/* To implement guarded deep copy, i.e., deep copy only allocatable
components that are really allocated, the deep copy code has to
@@ -9719,7 +9746,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;
@@ -10092,7 +10120,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);
}
@@ -10105,7 +10134,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);
}
tree
@@ -10143,7 +10173,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);
return tmp;
}
@@ -10153,10 +10184,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);
}
@@ -10164,7 +10197,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);
}
@@ -10180,6 +10214,20 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
}
+/* Recursively traverse an object of derived type, generating code to
+ copy it and its allocatable components, while deleting pointers and
+ suppressing any finalization that might occur. This is used in the
+ finaliztion of function results. */
+
+tree
+gfc_copy_alloc_comp_del_ptrs (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, true, true);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
copy only its allocatable components. */
@@ -10950,7 +10998,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..2743158cb11 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,11 +56,14 @@ 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);
+tree gfc_copy_alloc_comp_del_ptrs (gfc_symbol *, tree, tree, int, int);
+
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb6a78c3a62..34ad867e041 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1904,6 +1904,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
{
memset (se, 0, sizeof (gfc_se));
gfc_init_block (&se->pre);
+ gfc_init_block (&se->finalblock);
gfc_init_block (&se->post);
se->parent = parent;
@@ -5975,6 +5976,117 @@ post_call:
}
+/* Finalize a function result using the finalizer wrapper. The result is fixed
+ in order to prevent repeated calls. */
+
+static void
+finalize_function_result (gfc_se *se, gfc_symbol *derived,
+ symbol_attribute attr, int rank)
+{
+ tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr;
+ gfc_symbol *vtab;
+ gfc_se post_se;
+ bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+ if (attr.pointer)
+ return;
+
+ if (is_class)
+ {
+ if (!VAR_P (se->expr))
+ {
+ desc = gfc_evaluate_now (se->expr, &se->pre);
+ se->expr = desc;
+ }
+ desc = gfc_class_data_get (se->expr);
+ vptr = gfc_class_vptr_get (se->expr);
+ }
+ else
+ {
+ desc = gfc_evaluate_now (se->expr, &se->pre);
+ se->expr = gfc_evaluate_now (desc, &se->pre);
+ /* Need to copy allocated components and delete pointer components. */
+ gfc_add_expr_to_block (&se->pre,
+ gfc_copy_alloc_comp_del_ptrs (derived, desc,
+ se->expr, rank, 0));
+ vtab = gfc_find_derived_vtab (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);
+ }
+
+ size = gfc_vptr_size_get (vptr);
+ final_fndecl = gfc_vptr_final_get (vptr);
+ is_final = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ final_fndecl,
+ fold_convert (TREE_TYPE (final_fndecl),
+ null_pointer_node));
+
+ final_fndecl = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ if (is_class)
+ desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+ else
+ {
+ gfc_init_se (&post_se, NULL);
+ desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+ gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+ }
+ }
+
+ tmp = gfc_create_var (TREE_TYPE (desc), "res");
+ gfc_add_modify (&se->pre, tmp, desc);
+ desc = tmp;
+
+ tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ size, boolean_false_node);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, is_final, tmp,
+ build_empty_stmt (input_location));
+
+ if (is_class && se->ss && se->ss->loop)
+ {
+ data_ptr = gfc_conv_descriptor_data_get (desc);
+
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ data_ptr,
+ fold_convert (TREE_TYPE (data_ptr),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ }
+ else
+ {
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ if (is_class)
+ {
+ data_ptr = gfc_conv_descriptor_data_get (desc);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ data_ptr,
+ fold_convert (TREE_TYPE (data_ptr),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ }
+ }
+}
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
@@ -7011,6 +7123,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
+ gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
/* Allocated allocatable components of derived types must be
deallocated for non-variable scalars, array arguments to elemental
@@ -7675,9 +7788,17 @@ 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. */
+ symbol_attribute attr = comp ? comp->attr : sym->attr;
+ bool allocatable = attr.allocatable && !attr.dimension;
+ gfc_symbol *der = comp && comp->ts.type == BT_DERIVED ? comp->ts.u.derived
+ : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL);
+ bool finalizable = der != NULL && gfc_is_finalizable (der, NULL);
+
+ if (!byref && finalizable)
+ finalize_function_result (se, der, attr, expr->rank);
+
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);
@@ -7737,6 +7858,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
se->expr = info->descriptor;
/* Bundle in the string length. */
se->string_length = len;
+
+ if (finalizable)
+ finalize_function_result (se, der, attr, expr->rank);
}
else if (ts.type == BT_CHARACTER)
{
@@ -7829,8 +7953,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
{
- tree final_fndecl;
- tree is_final;
int n;
if (se->ss && se->ss->loop)
{
@@ -7852,66 +7974,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* TODO Eliminate the doubling of temporaries. This
one is necessary to ensure no memory leakage. */
se->expr = gfc_evaluate_now (se->expr, &se->pre);
- tmp = gfc_class_data_get (se->expr);
- tmp = gfc_conv_scalar_to_descriptor (se, tmp,
- CLASS_DATA (expr->value.function.esym->result)->attr);
}
- if ((gfc_is_class_array_function (expr)
- || gfc_is_alloc_class_scalar_function (expr))
- && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
- goto no_finalization;
-
- final_fndecl = gfc_class_vtab_final_get (se->expr);
- is_final = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- final_fndecl,
- fold_convert (TREE_TYPE (final_fndecl),
- null_pointer_node));
- final_fndecl = build_fold_indirect_ref_loc (input_location,
- final_fndecl);
- tmp = build_call_expr_loc (input_location,
- final_fndecl, 3,
- gfc_build_addr_expr (NULL, tmp),
- gfc_class_vtab_size_get (se->expr),
- boolean_false_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, is_final, tmp,
- build_empty_stmt (input_location));
-
- if (se->ss && se->ss->loop)
- {
- gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- info->data,
- fold_convert (TREE_TYPE (info->data),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (info->data),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->ss->loop->post, tmp);
- }
- else
- {
- tree classdata;
- gfc_prepend_expr_to_block (&se->post, tmp);
- classdata = gfc_class_data_get (se->expr);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- classdata,
- fold_convert (TREE_TYPE (classdata),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (classdata),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->post, tmp);
- }
+ /* Finalize the result, if necessary. */
+ attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+ if (!((gfc_is_class_array_function (expr)
+ || gfc_is_alloc_class_scalar_function (expr))
+ && attr.pointer))
+ finalize_function_result (se, NULL, attr, expr->rank);
}
-
-no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
@@ -10430,7 +10501,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);
@@ -10438,6 +10510,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_modify (&block, lse->expr,
@@ -10469,6 +10542,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
@@ -10478,6 +10552,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
if (!trans_scalar_class_assign (&block, lse, rse))
{
@@ -10872,6 +10947,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
+ gfc_add_block_to_block (&se.pre, &se.finalblock);
if (ss)
gfc_cleanup_loop (&loop);
@@ -11387,6 +11463,96 @@ 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;
+ gfc_symbol *sym = expr1->symtree->n.sym;
+ gfc_ref *ref = expr1->ref;
+
+ /* 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
+ || sym->attr.artificial
+ || sym->ns->proc_name->attr.artificial
+ || init_flag)
+ return NULL_TREE;
+
+ /* F2018 7.5.6.2: Only finalizable entities are finalized. */
+ for (; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ return NULL_TREE;
+
+ if (!(sym->ts.type == BT_CLASS
+ || (sym->ts.type == BT_DERIVED
+ && gfc_is_finalizable (sym->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 (sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (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 +11560,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. */
@@ -11419,8 +11595,12 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (vptr);
- class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- ? gfc_class_data_get (lse->expr) : lse->expr;
+ if (TREE_CODE (lse->expr) == INDIRECT_REF)
+ tmp = TREE_OPERAND (lse->expr, 0);
+ else
+ tmp = lse->expr;
+ class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ ? gfc_class_data_get (tmp) : tmp;
/* Allocate block. */
gfc_init_block (&alloc);
@@ -11519,6 +11699,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 +11723,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 +11764,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 +12038,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
@@ -11900,6 +12085,32 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
}
+ /* 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
+ && !(expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.artificial))
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ if (tmp != NULL_TREE && final_expr != NULL_TREE)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_expr_to_block (&block, final_expr);
+ }
+ else
+ gfc_add_expr_to_block (&lse.finalblock, 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);
+
/* If nothing else works, do it the old fashioned way! */
if (tmp == NULL_TREE)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
@@ -11909,12 +12120,18 @@ 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);
+
+ /* 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. */
- gfc_add_block_to_block (&body, &rse.post);
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&rse.finalblock, &rse.post);
+ gfc_add_block_to_block (&body, &rse.finalblock);
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.post);
gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
@@ -11979,6 +12196,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Wrap the whole thing up. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
+ gfc_add_block_to_block (&block, &rse.finalblock);
gfc_cleanup_loop (&loop);
}
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 732221f848b..bf4f0671585 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2664,6 +2664,7 @@ scalarize:
gfc_add_block_to_block (&body, &se.pre);
gfc_add_block_to_block (&body, &se.post);
+ gfc_add_block_to_block (&body, &se.finalblock);
if (se.ss == NULL)
tmp = gfc_finish_block (&body);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 04f8147d23b..e0f513f8941 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -443,7 +443,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
else
gfc_add_expr_to_block (&se.pre, se.expr);
- gfc_add_block_to_block (&se.pre, &se.post);
+ gfc_add_block_to_block (&se.finalblock, &se.post);
+ gfc_add_block_to_block (&se.pre, &se.finalblock);
}
else
@@ -542,6 +543,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
+ gfc_add_block_to_block (&se.pre, &loopse.finalblock);
gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
@@ -6337,7 +6339,10 @@ gfc_trans_allocate (gfc_code * code)
}
gfc_add_block_to_block (&block, &se.pre);
if (code->expr3->must_finalize)
- gfc_add_block_to_block (&final_block, &se.post);
+ {
+ gfc_add_block_to_block (&final_block, &se.finalblock);
+ gfc_add_block_to_block (&final_block, &se.post);
+ }
else
gfc_add_block_to_block (&post, &se.post);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 333dfa69642..fabdcde7267 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1242,6 +1242,9 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
return false;
+ if (gfc_expr_attr (expr2).artificial)
+ return false;
+
if (expr2->ts.type == BT_DERIVED)
{
gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 738c7487a56..72af54c4d29 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -43,6 +43,10 @@ typedef struct gfc_se
stmtblock_t pre;
stmtblock_t post;
+ /* Carries finalization code that is required to be executed execution of the
+ innermost executable construct. */
+ stmtblock_t finalblock;
+
/* the result of the expression */
tree expr;
@@ -55,7 +59,7 @@ typedef struct gfc_se
/* Whether expr is a reference to an unlimited polymorphic object. */
unsigned unlimited_polymorphic:1;
-
+
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
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 the fix for PR71798 in which the result of 'create_mytype'
! was not being finalized after the completion of the assignment
! statement.
!
! Contributed by Jonathan Hogg <jhog...@gmail.com>
!
module mymod
implicit none
integer :: next = 0
type :: mytype
integer :: idx = -1
contains
procedure :: mytype_assign
generic :: assignment(=) => mytype_assign
final :: mytype_final
end type mytype
contains
subroutine mytype_assign(this, other)
class(mytype), intent(inout) :: this
class(mytype), intent(in) :: other
this%idx = next
next = next + 1
if (next /= 2) stop 2
end subroutine mytype_assign
subroutine mytype_final(this)
type(mytype) :: this
next = next + 1
if (next /= 3) stop 3
end subroutine mytype_final
type(mytype) function create_mytype()
create_mytype%idx = next
next = next + 1
if (next /= 1) stop 1
end function create_mytype
end module mymod
program test
use mymod
implicit none
type(mytype) :: x
x = create_mytype()
end program test
! { dg-do run }
!
! Test that PR67471 is fixed. Used not to call the finalizer.
!
! Contributed by Ian Harvey <ian_har...@bigpond.com>
!
module test_final_mod
implicit none
type :: my_final
integer :: n = 1
contains
final :: destroy_rank1_array
end type my_final
integer :: final_calls = 0
contains
subroutine destroy_rank1_array(self)
type(my_final), intent(inout) :: self(:)
if (size(self) /= 0) then
if (size(self) /= 2) stop 1
if (any (self%n /= [3,4])) stop 2
else
stop 3
end if
final_calls = final_calls + 1
end subroutine destroy_rank1_array
end module test_final_mod
program test_finalizer
use test_final_mod
implicit none
type(my_final) :: b(4), c(2)
b%n = [2, 3, 4, 5]
c%n = [6, 7]
b(2:3) = c
if (final_calls /= 1) stop 4
end program test_finalizer
! { 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
! ************************
! The original PR - one finalization of 'var' before (re)allocation.
MyType = ThyType
call test(1, 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(2, 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(3, 0, [42,43], 20)
! This should result in a final call with self = initialization = simple(22).
ThyType2 = simple(99)
call test(4, 22, [0,0], 30)
! This should result in a final call with self = simple(22).
ThyType = ThyType2
call test(5, 21, [0,0], 40)
! This should result in two final calls; the last is for self2 = simple(2).
deallocate (MyType, MyType2)
call test(7, 2, [0,0], 50)
! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
deallocate (MyTypeArray)
call test(8, 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(10, 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 value before the assignment.
call test(2, 4, [0,0], 130)
! This should result in a final call with the assigned value.
deallocate (MyClassArray)
call test(3, 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)
! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
! finalizable, the parent component is finalized.
call test(5, 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(9, 0, [10,20], 160, rarray = [10.0,20.0])
deallocate (MyClassArray)
call test(11, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final
! { dg-do run }
!
! Test that PR69298 is fixed. Used to segfault on finalization in
! subroutine 'in_type'.
!
! Contributed by Neil Carlson <neil.n.carl...@gmail.com>
!
module stuff_mod
implicit none
private
public :: stuff_type, final_calls
type stuff_type
private
integer :: junk
contains
procedure get_junk
procedure stuff_copy_initialiser
generic :: assignment(=) => stuff_copy_initialiser
final :: stuff_scalar_finaliser, &
stuff_1d_finaliser
end type stuff_type
integer :: final_calls = 0
interface stuff_type
procedure stuff_initialiser
end interface stuff_type
contains
function stuff_initialiser( junk ) result(new_stuff)
implicit none
type(stuff_type) :: new_stuff
integer :: junk
new_stuff%junk = junk
end function stuff_initialiser
subroutine stuff_copy_initialiser( destination, source )
implicit none
class(stuff_type), intent(out) :: destination
class(stuff_type), intent(in) :: source
destination%junk = source%junk
end subroutine stuff_copy_initialiser
subroutine stuff_scalar_finaliser( this )
implicit none
type(stuff_type), intent(inout) :: this
final_calls = final_calls + 1
end subroutine stuff_scalar_finaliser
subroutine stuff_1d_finaliser( this )
implicit none
type(stuff_type), intent(inout) :: this(:)
integer :: i
final_calls = final_calls + 100
end subroutine stuff_1d_finaliser
function get_junk( this ) result(junk)
implicit none
class(stuff_type), intent(in) :: this
integer :: junk
junk = this%junk
end function get_junk
end module stuff_mod
module test_mod
use stuff_mod, only : stuff_type, final_calls
implicit none
private
public :: test_type
type test_type
private
type(stuff_type) :: thing
type(stuff_type) :: things(3)
contains
procedure get_value
end type test_type
interface test_type
procedure test_type_initialiser
end interface test_type
contains
function test_type_initialiser() result(new_test)
implicit none
type(test_type) :: new_test
integer :: i
new_test%thing = stuff_type( 4 )
do i = 1, 3
new_test%things(i) = stuff_type( i )
end do
end function test_type_initialiser
function get_value( this ) result(value)
implicit none
class(test_type) :: this
integer :: value
integer :: i
value = this%thing%get_junk()
do i = 1, 3
value = value + this%things(i)%get_junk()
end do
end function get_value
end module test_mod
program test
use stuff_mod, only : stuff_type, final_calls
use test_mod, only : test_type
implicit none
call here()
call in_type()
! 21 calls to scalar finalizer and 4 to the vector version
if (final_calls .ne. 421) stop 1
contains
subroutine here()
implicit none
type(stuff_type) :: thing
type(stuff_type) :: bits(3)
integer :: i
integer :: tally
thing = stuff_type(4)
do i = 1, 3
bits(i) = stuff_type(i)
end do
tally = thing%get_junk()
do i = 1, 3
tally = tally + bits(i)%get_junk()
end do
if (tally .ne. 10) stop 2
end subroutine here
subroutine in_type()
implicit none
type(test_type) :: thing
thing = test_type()
if (thing%get_value() .ne. 10) stop 2
end subroutine in_type
end program test
! { dg-do run }
!
! Test the fix for PR67444 in which the finalization of a polymorphic 'var'
! was not being finalized before assignment. (STOP 3)
!
! Contributed by Balint Aradi <bal...@gmail.com>
!
module classes
implicit none
integer :: ivalue = 0
integer :: icall = 0
integer :: fvalue = 0
type :: Basic
integer :: ii = -1
contains
procedure :: assignBasic
generic :: assignment(=) => assignBasic
final :: destructBasic
end type Basic
interface Basic
module procedure initBasic
end interface Basic
contains
function initBasic(initValue) result(this)
integer, intent(in) :: initValue
type(Basic) :: this
this%ii = initValue
icall = icall + 1
end function initBasic
subroutine assignBasic(this, other)
class(Basic), intent(out) :: this
type(Basic), intent(in) :: other
this%ii = other%ii + 1
icall = other%ii
end subroutine assignBasic
subroutine destructBasic(this)
type(Basic), intent(inout) :: this
fvalue = fvalue + 1
select case (fvalue)
case (1)
if (this%ii /= -1) stop 1 ! First finalization before assignment to 'var'
if (icall /= 1) stop 2 ! and before evaluation of 'expr'.
case(2)
if (this%ii /= ivalue) stop 3 ! Finalization of intent(out) in 'assignBasic'
if (icall /= 42) stop 4 ! and after evaluation of 'expr'.
case(3)
if (this%ii /= ivalue + 1) stop 5 ! Finalization of 'expr' (function!) after assignment.
case default
stop 6 ! Too many or no finalizations
end select
end subroutine destructBasic
end module classes
module usage
use classes
implicit none
contains
subroutine useBasic()
type(Basic) :: bas
ivalue = 42
bas = Basic(ivalue)
end subroutine useBasic
end module usage
program test
use usage
implicit none
call useBasic()
if (fvalue /= 3) stop 7 ! 3 finalizations mandated.
end program test
! { dg-do run }
!
! Test the fix for PR80524, where gfortran on issued one final call
! For 'u' going out of scope. Two further call should be emitted; one
! for the lhs of the assignment in 's' and the other for the function
! result, which occurs after assignment.
!
! Contributed by Andrew Wood <and...@fluidgravity.co.uk>
!
MODULE m1
IMPLICIT NONE
integer :: counter = 0
integer :: fval = 0
TYPE t
INTEGER :: i
CONTAINS
FINAL :: t_final
END TYPE t
CONTAINS
SUBROUTINE t_final(this)
TYPE(t) :: this
counter = counter + 1
END SUBROUTINE
FUNCTION new_t()
TYPE(t) :: new_t
new_t%i = 1
fval = new_t%i
if (counter /= 0) stop 1 ! Finalization of 'var' after evaluation of 'expr'
END FUNCTION new_t
SUBROUTINE s
TYPE(t) :: u
u = new_t()
if (counter /= 2) stop 2 ! Finalization of 'var' and 'expr'
END SUBROUTINE s
END MODULE m1
PROGRAM prog
USE m1
IMPLICIT NONE
CALL s
if (counter /= 3) stop 3 ! Finalization of 'u' in 's'
END PROGRAM prog
! { dg-do run }
!
! Test the fix for pr88735 in which non-finalizable entities were being
! finalized because they had finalizable components and 'var' in defined
! assignments was being finalized.
!
! Contributed by Martin Stein <ms...@gmx.net>
!
module mod
implicit none
type, public :: t
integer, allocatable :: i
contains
procedure, public :: set
generic, public :: assignment(=) => set
final :: finalise
end type t
integer, public :: final_count = 0
contains
subroutine set(self, x)
class(t), intent(inout) :: self
class(t), intent(in) :: x
if (allocated(x%i)) then
self%i = x%i
self%i = self%i + 1
end if
end subroutine set
subroutine finalise(self)
type(t), intent(inout) :: self
if (allocated(self%i)) then
final_count = final_count + 1
deallocate(self%i)
end if
end subroutine finalise
end module mod
program finalise_assign
use mod
implicit none
type :: s
type(t) :: x
end type s
type(s) :: a, b
type(t) :: c
a%x%i = 123
! Produces no final calls because 'b' is not a 'finalizable entity'.
b = a
if (final_count /= 0) stop 1
! Produces no final calls because this is a defined assignment.
c = a%x
if (final_count /= 0) stop 2
end program finalise_assign
! { dg-do run }
!
! Test the fix for all three variants of PR82996, which used to
! segfault in the original testcase and ICE in the testcases of
! comments 1 and 2.
!
! Contributed by Neil Carlson <neil.n.carl...@gmail.com>
!
module mod0
integer :: final_count_foo = 0
integer :: final_count_bar = 0
end module mod0
!
! This is the original testcase, with a final routine 'foo' but
! but not in the container type 'bar1'.
!
module mod1
use mod0
private foo, foo_destroy
type foo
integer, pointer :: f(:) => null()
contains
final :: foo_destroy
end type
type bar1
type(foo) :: b(2)
end type
contains
impure elemental subroutine foo_destroy(this)
type(foo), intent(inout) :: this
final_count_foo = final_count_foo + 1
if (associated(this%f)) deallocate(this%f)
end subroutine
end module mod1
!
! Comment 1 was the same as original, except that the
! 'foo' finalizer is elemental and a 'bar' finalizer is added..
!
module mod2
use mod0
private foo, foo_destroy, bar_destroy
type foo
integer, pointer :: f(:) => null()
contains
final :: foo_destroy
end type
type bar2
type(foo) :: b(2)
contains
final :: bar_destroy
end type
contains
impure elemental subroutine foo_destroy(this)
type(foo), intent(inout) :: this
final_count_foo = final_count_foo + 1
if (associated(this%f)) deallocate(this%f)
end subroutine
subroutine bar_destroy(this)
type(bar2), intent(inout) :: this
final_count_bar = final_count_bar + 1
call foo_destroy(this%b)
end subroutine
end module mod2
!
! Comment 2 was the same as comment 1, except that the 'foo'
! finalizer is no longer elemental.
!
module mod3
use mod0
private foo, foo_destroy, bar_destroy
type foo
integer, pointer :: f(:) => null()
contains
final :: foo_destroy
end type
type bar3
type(foo) :: b(2)
contains
final :: bar_destroy
end type
contains
subroutine foo_destroy(this)
type(foo), intent(inout) :: this
final_count_foo = final_count_foo + 1
if (associated(this%f)) deallocate(this%f)
end subroutine
subroutine bar_destroy(this)
type(bar3), intent(inout) :: this
final_count_bar = final_count_bar + 1
do j = 1, size(this%b)
call foo_destroy(this%b(j))
end do
end subroutine
end module mod3
program main
use mod0
use mod1
use mod2
use mod3
type(bar1) :: x
type(bar2) :: y
type(bar3) :: z
call sub1(x)
if (final_count_foo /= 2) stop 1
if (final_count_bar /= 0) stop 2
call sub2(y)
if (final_count_foo /= 6) stop 3
if (final_count_bar /= 1) stop 4
call sub3(z)
if (final_count_foo /= 8) stop 5
if (final_count_bar /= 2) stop 6
contains
subroutine sub1(x)
type(bar1), intent(out) :: x
end subroutine
subroutine sub2(x)
type(bar2), intent(out) :: x
end subroutine
subroutine sub3(x)
type(bar3), intent(out) :: x
end subroutine
end program
! { dg-do run }
!
! Test the fix for pr91396 in which some of the expected finalizations
! did not occur; within s3 and s4 scopes.
!
! Contributed by Jose Rui Faustine de Sousa <jrfso...@gcc.gnu.org>
!
module final_m
implicit none
private
public :: &
assignment(=)
public :: &
final_t
integer, public :: final_count
public :: &
final_init, &
final_set, &
final_get, &
final_end
type :: final_t
private
integer :: n = -1
contains
final :: final_end
end type final_t
interface assignment(=)
module procedure final_init
end interface assignment(=)
contains
elemental subroutine final_init(this, n)
type(final_t), intent(out) :: this
integer, intent(in) :: n
this%n = n
return
end subroutine final_init
elemental function final_set(n) result(this)
integer, intent(in) :: n
type(final_t) :: this
this%n = n
return
end function final_set
elemental function final_get(this) result(n)
type(final_t), intent(in) :: this
integer :: n
n = this%n
return
end function final_get
subroutine final_end(this)
type(final_t), intent(inout) :: this
final_count = final_count + 1
this%n = -1
return
end subroutine final_end
end module final_m
program final_p
use final_m
implicit none
type(final_t) :: f0
! print *, "enter main"
call final_init(f0, 0)
! print *, "enter final_s1"
call final_s1()
! print *, "exit final_s1"
! print *, "enter final_s2"
call final_s2()
! print *, "exit final_s2"
! print *, "enter final_s3"
call final_s3()
! print *, "exit final_s3"
! print *, "enter final_s4"
call final_s4()
! print *, "exit final_s4"
! print *, "f0: ", final_get(f0)
! this should be automatic...
call final_end(f0)
if (final_count /= 10) stop 1
stop
contains
subroutine final_s1()
type(final_t) :: f
call final_init(f, 1)
print *, "f1: ", final_get(f)
! Two finalizations for INTENT(OUT) in final_init this scope and main program.
if (final_count /= 2) stop 2
return
end subroutine final_s1
subroutine final_s2()
type(final_t) :: f
f = 2
! One finalization for INTENT(OUT) in final_init, used in the defined assignment
! and one for leaving 's1' scope.
if (final_count /= 4) stop 3
print *, "f2: ", final_get(f)
return
end subroutine final_s2
subroutine final_s3()
type(final_t) :: f
f = final_set(3)
print *, "f3: ", final_get(f)
! One finalization for 'var, in the assignment, one for the result of final_set
! and one for leaving 's2' scope.
if (final_count /= 7) stop 4
return
end subroutine final_s3
subroutine final_s4()
print *, "f4: ", final_get(final_set(4)), " ", final_count
! One finalization for the result of final_set and one for leaving 's3' scope.
return
end subroutine final_s4
end program final_p
! { dg-do run }
!
! Test the fix for PR84472 in which the finalizations around the
! assignment in 'mymain' were not happening.
!
! Contributed by Vipul Parekh <fortran...@outlook.com>
!
module m
use, intrinsic :: iso_fortran_env, only : output_unit
implicit none
private
integer, public :: final_counts = 0
integer, public :: assoc_counts = 0
type :: t
private
character(len=:), pointer :: m_s => null()
contains
private
final :: final_t
procedure, pass(this), public :: clean => clean_t
procedure, pass(this), public :: init => init_t
end type
interface t
module procedure :: construct_t
end interface
public :: t
contains
function construct_t( name ) result(new_t)
! argument list
character(len=*), intent(in), optional :: name
! function result
type(t) :: new_t
if ( present(name) ) then
call new_t%init( name )
end if
end function
subroutine final_t( this )
! argument list
type(t), intent(inout) :: this
final_counts = final_counts + 1
if ( associated(this%m_s) ) then
assoc_counts = assoc_counts + 1
endif
call clean_t( this )
end subroutine
subroutine clean_t( this )
! argument list
class(t), intent(inout) :: this
if ( associated(this%m_s) ) then
deallocate( this%m_s )
end if
this%m_s => null()
end subroutine
subroutine init_t( this, mname )
! argument list
class(t), intent(inout) :: this
character(len=*), intent(in) :: mname
call this%clean()
allocate(character(len(mname)) :: this%m_s)
this%m_s = mname
end subroutine
end module
use m, only : final_counts, assoc_counts
call mymain
if (final_counts /= 3) stop 1
if (assoc_counts /= 2) stop 2
contains
subroutine mymain
use m, only : t
implicit none
character(3), allocatable, target :: myname
type(t) :: foo
call foo%init( mname="123" )
myname = "foo"
foo = t( myname )
call foo%clean()
if (final_counts /= 2) stop 3
if (assoc_counts /= 2) stop 4
end
end
