public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-6747] Fortran: Fix bugs and missing features in finalization [PR37336]
@ 2023-03-18 7:56 Paul Thomas
0 siblings, 0 replies; only message in thread
From: Paul Thomas @ 2023-03-18 7:56 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:d7caf313525a46f200d7f5db1ba893f853774aee
commit r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Sat Mar 18 07:56:23 2023 +0000
Fortran: Fix bugs and missing features in finalization [PR37336]
2023-03-18 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/103854
PR fortran/96122
PR fortran/37336
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.
(has_finalizer_component): Do not return true for procedure
pointer components.
(finalizer_insert_packed_call): Remove the redundant argument
in the call to the final subroutine.
(generate_finalization_wrapper): Add support for assumed rank
finalizers.
(gfc_may_be_finalized): New helper function.
* dump-parse-tree.cc (write_proc): Whitespace.
* gfortran.h : Add prototype for gfc_may_be_finalized.
* resolve.cc (resolve_function): Correct derived types that
have an incomplete namespace.
(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.
(is_finalizable_type): New function.
(generate_component_assignments): Set must_finalize if needed.
(gfc_resolve_finalizers): Error if assumed rank finalizer is
not the only one. Warning on lack of scalar finalizer modified
to account for assumed rank finalizers.
(generate_final_call): New function.
(generate_component_assignments): Enclose the outermost call in
a block to capture automatic deallocation and final calls.
Set must_finalize as required to satisfy the standards. Use an
explicit pointer assignment for pointer components to capture
finalization of the target. Likewise use explicit assignment
for allocatable components. Do not use the temporary copy of
the lhs in defined assignment if the component is allocatable.
Put the temporary in the same namespace as the lhs symbol if
the component may be finalized. Remove the leading assignment
from the expansion of assignment of components that have their
own defined assignment components. Suppress finalization of
assignment of temporary components to the lhs. Make an explicit
final call for the rhs function temporary if it exists.
(gfc_resolve_code): Set must_finalize for assignments with an
array constructor on the rhs.
(gfc_resolve_finalizers): Ensure that an assumed rank finalizer
is the only finalizer for that type and correct the surprising
warning for the lack of a scalar finalizer.
(check_defined_assignments): Handle allocatable components.
(resolve_fl_derived): Set referenced the vtab for use
associated symbols.
(resolve_symbol): Set referenced an unreferenced symbol that
will be finalized.
* trans-array.cc (gfc_trans_array_constructor_value): Add code
to finalize the constructor result. Warn that this feature was
removed in F2018 and that it is suppressed by -std=2018.
(trans_array_constructor): Add finalblock, pass to previous
and apply to loop->post if filled.
(gfc_add_loop_ss_code): Add se finalblock to outer loop post.
(gfc_trans_array_cobounds, gfc_trans_array_bounds): Add any
generated finalization code to the main block.
(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_copy_alloc_comp_no_fini): New wrapper for
structure_alloc_comps.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_trans_deferred_array): Use gfc_may_be_finalized and do not
deallocate the components of entities with a leading '_' in the
name that are also marked as artificial.
* 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_no_fini.
* trans-decl.cc(init_intent_out_dt): Tidy up the code.
* trans-expr.cc (gfc_init_se): Initialize finalblock.
(gfc_conv_procedure_call): Use gfc_finalize_tree_expr to
finalize function results. Replace in-line block for class
results with call to new function.
(gfc_conv_expr): Finalize structure constructors for F2003 and
F2008. Warn that this feature was deleted in F2018 and, unlike
array constructors, is not default. Add array constructor
finalblock to the post block.
(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_trans_arrayfunc_assign): Use gfc_assignment_finalizer_call
and ensure that finalization occurs after the evaluation of the
rhs but using the initial value for the lhs. Finalize rhs
function results using gfc_finalize_tree_expr.
(trans_class_assignment, gfc_trans_assignment_1): As previous
function, taking care to order evaluation, assignment and
finalization correctly.
* trans-io.cc (gfc_trans_transfer): Add the final block.
* trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise.
(trans_associate_var): Nullify derived allocatable components
and finalize function targets with defined assignment
components on leaving the block scope.
(trans_allocate): Finalize source expressions, if required,
and set init_expr artificial temporarily to suppress the
finalization in gfc_trans_assignment.
* trans.cc (gfc_add_finalizer_call): Do not finalize the
temporaries generated in type assignment with defined
assignment components.
(gfc_assignment_finalizer_call): New function.
(gfc_finalize_tree_expr): New function.
* trans.h: Add finalblock to gfc_se. Add the prototypes for
gfc_finalize_tree_expr and gfc_assignment_finalizer_call.
gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/finalize_38a.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.
* gfortran.dg/associate_25.f90 : Remove the incorrect comment.
* gfortran.dg/auto_dealloc_2.f90 : Change the tree dump expr
but the final count remains the same.
* gfortran.dg/unlimited_polymorphic_8.f90 : Tree dump reveals
foo.1.x rather than foo.0.x
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.
PR fortran/106576
* gfortran.dg/finalize_48.f90 : New test.
PR fortran/37336
* gfortran.dg/finalize_49.f90 : New test.
* gfortran.dg/finalize_50.f90 : New test.
* gfortran.dg/finalize_51.f90 : New test.
Diff:
---
gcc/fortran/class.cc | 81 ++++-
gcc/fortran/dump-parse-tree.cc | 2 +-
gcc/fortran/gfortran.h | 1 +
gcc/fortran/resolve.cc | 355 +++++++++++++++++----
gcc/fortran/trans-array.cc | 234 +++++++++-----
gcc/fortran/trans-array.h | 5 +-
gcc/fortran/trans-decl.cc | 42 ++-
gcc/fortran/trans-expr.cc | 259 ++++++++++-----
gcc/fortran/trans-io.cc | 1 +
gcc/fortran/trans-stmt.cc | 50 ++-
gcc/fortran/trans.cc | 281 +++++++++++++++-
gcc/fortran/trans.h | 8 +-
.../gfortran.dg/allocate_with_source_25.f90 | 2 +-
gcc/testsuite/gfortran.dg/associate_25.f90 | 4 +-
gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 | 4 +-
gcc/testsuite/gfortran.dg/finalize_38.f90 | 222 +++++++++++++
gcc/testsuite/gfortran.dg/finalize_38a.f90 | 240 ++++++++++++++
gcc/testsuite/gfortran.dg/finalize_39.f90 | 71 +++++
gcc/testsuite/gfortran.dg/finalize_40.f90 | 44 +++
gcc/testsuite/gfortran.dg/finalize_41.f90 | 139 ++++++++
gcc/testsuite/gfortran.dg/finalize_42.f90 | 53 +++
gcc/testsuite/gfortran.dg/finalize_43.f90 | 41 +++
gcc/testsuite/gfortran.dg/finalize_44.f90 | 123 +++++++
gcc/testsuite/gfortran.dg/finalize_45.f90 | 132 ++++++++
gcc/testsuite/gfortran.dg/finalize_46.f90 | 92 ++++++
gcc/testsuite/gfortran.dg/finalize_47.f90 | 105 ++++++
gcc/testsuite/gfortran.dg/finalize_48.f90 | 59 ++++
gcc/testsuite/gfortran.dg/finalize_49.f90 | 67 ++++
gcc/testsuite/gfortran.dg/finalize_50.f90 | 254 +++++++++++++++
gcc/testsuite/gfortran.dg/finalize_51.f90 | 70 ++++
.../gfortran.dg/unlimited_polymorphic_8.f90 | 4 +-
31 files changed, 2801 insertions(+), 244 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 52235ab83e3..bffc0ffff3a 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -909,7 +909,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)
@@ -1072,7 +1073,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);
@@ -1081,12 +1083,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;
@@ -1443,8 +1487,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. */
@@ -2060,13 +2102,32 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_set_sym_referenced (ptr);
gfc_commit_symbol (ptr);
+ fini = derived->f2k_derived->finalizers;
+
+ /* Assumed rank finalizers can be called directly. The call takes care
+ of setting up the descriptor. resolve_finalizers has already checked
+ that this is the only finalizer for this kind/type (F2018: C790). */
+ if (fini->proc_tree && fini->proc_tree->n.sym->formal->sym->as
+ && fini->proc_tree->n.sym->formal->sym->as->type == AS_ASSUMED_RANK)
+ {
+ last_code->next = gfc_get_code (EXEC_CALL);
+ last_code->next->symtree = fini->proc_tree;
+ last_code->next->resolved_sym = fini->proc_tree->n.sym;
+ last_code->next->ext.actual = gfc_get_actual_arglist ();
+ last_code->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+
+ last_code = last_code->next;
+ goto finish_assumed_rank;
+ }
+
/* SELECT CASE (RANK (array)). */
last_code->next = gfc_get_code (EXEC_SELECT);
last_code = last_code->next;
last_code->expr1 = gfc_copy_expr (rank);
block = NULL;
- for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+
+ for (; fini; fini = fini->next)
{
gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
if (fini->proc_tree->n.sym->attr.elemental)
@@ -2165,6 +2226,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
}
}
+finish_assumed_rank:
+
/* Finalize and deallocate allocatable components. The same manual
scalarization is used as above. */
@@ -2699,6 +2762,14 @@ yes:
}
+bool
+gfc_may_be_finalized (gfc_typespec ts)
+{
+ return (ts.type == BT_CLASS || (ts.type == BT_DERIVED
+ && ts.u.derived && gfc_is_finalizable (ts.u.derived, NULL)));
+}
+
+
/* Find (or generate) the symbol for an intrinsic type's vtab. This is
needed to support unlimited polymorphism. */
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 164710fe98a..3b24bdc1a6c 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -3909,7 +3909,7 @@ write_proc (gfc_symbol *sym, bool bind_c)
if (sym->formal)
fputs (", ", dumpfile);
}
-
+
for (f = sym->formal; f; f = f->next)
{
gfc_symbol *s;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fea25312cf4..9bab2c40ead 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3931,6 +3931,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, bool*,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
+bool gfc_may_be_finalized (gfc_typespec);
#define CLASS_DATA(sym) sym->ts.u.derived->components
#define UNLIMITED_POLY(sym) \
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 46585879ddc..ba603b4c407 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3478,6 +3478,24 @@ resolve_function (gfc_expr *expr)
expr->ts = expr->symtree->n.sym->result->ts;
}
+ /* These derived types with an incomplete namespace, arising from use
+ association, cause gfc_get_derived_vtab to segfault. If the function
+ namespace does not suffice, something is badly wrong. */
+ if (expr->ts.type == BT_DERIVED
+ && !expr->ts.u.derived->ns->proc_name)
+ {
+ gfc_symbol *der;
+ gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
+ if (der)
+ {
+ expr->ts.u.derived->refs--;
+ expr->ts.u.derived = der;
+ der->refs++;
+ }
+ else
+ expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
+ }
+
if (!expr->ref && !expr->value.function.isym)
{
if (expr->value.function.esym)
@@ -10556,6 +10574,11 @@ 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
+ && gfc_may_be_finalized (cnext->expr1->ts))
+ cnext->expr1->must_finalize = 1;
+
break;
@@ -10643,6 +10666,11 @@ 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
+ && gfc_may_be_finalized (cnext->expr1->ts))
+ cnext->expr1->must_finalize = 1;
+
break;
/* WHERE operator assignment statement */
@@ -10689,6 +10717,11 @@ 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
+ && gfc_may_be_finalized (c->expr1->ts))
+ c->expr1->must_finalize = 1;
+
break;
case EXEC_ASSIGN_CALL:
@@ -10828,15 +10861,20 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
/* Resolve a BLOCK construct statement. */
+static gfc_expr*
+get_temp_from_expr (gfc_expr *, gfc_namespace *);
+static gfc_code *
+build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *,
+ gfc_component *, gfc_component *, locus);
static void
resolve_block_construct (gfc_code* code)
{
- /* Resolve the BLOCK's namespace. */
- gfc_resolve (code->ext.block.ns);
+ gfc_namespace *ns = code->ext.block.ns;
/* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during resolve_symbol. */
+ resolved during resolve_symbol. Resolve the BLOCK's namespace. */
+ gfc_resolve (ns);
}
@@ -11369,6 +11407,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);
@@ -11420,9 +11459,62 @@ add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
}
+/* Generate a final call from a variable expression */
+
+static void
+generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
+{
+ gfc_code *this_code;
+ gfc_expr *final_expr = NULL;
+ gfc_expr *size_expr;
+ gfc_expr *fini_coarray;
+
+ gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
+ if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
+ return;
+
+ /* Now generate the finalizer call. */
+ this_code = gfc_get_code (EXEC_CALL);
+ this_code->symtree = final_expr->symtree;
+ this_code->resolved_sym = final_expr->symtree->n.sym;
+
+ //* Expression to be finalized */
+ this_code->ext.actual = gfc_get_actual_arglist ();
+ this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
+
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ this_code->ext.actual->next = gfc_get_actual_arglist ();
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+ 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;
+ this_code->ext.actual->next->expr = size_expr;
+
+ /* fini_coarray */
+ this_code->ext.actual->next->next = gfc_get_actual_arglist ();
+ fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &tmp_expr->where);
+ fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
+ this_code->ext.actual->next->next->expr = fini_coarray;
+
+ add_code_to_chain (&this_code, head, tail);
+
+}
+
/* Counts the potential number of part array references that would
result from resolution of typebound defined assignments. */
+
static int
nonscalar_typebound_assign (gfc_symbol *derived, int depth)
{
@@ -11455,62 +11547,111 @@ nonscalar_typebound_assign (gfc_symbol *derived, int depth)
}
-/* Implement 7.2.1.3 of the F08 standard:
- "An intrinsic assignment where the variable is of derived type is
- performed as if each component of the variable were assigned from the
- corresponding component of expr using pointer assignment (7.2.2) for
- each pointer component, defined assignment for each nonpointer
- nonallocatable component of a type that has a type-bound defined
- assignment consistent with the component, intrinsic assignment for
- each other nonpointer nonallocatable component, ..."
+/* Implement 10.2.1.3 paragraph 13 of the F18 standard:
+ "An intrinsic assignment where the variable is of derived type is performed
+ as if each component of the variable were assigned from the corresponding
+ component of expr using pointer assignment (10.2.2) for each pointer
+ component, defined assignment for each nonpointer nonallocatable component
+ of a type that has a type-bound defined assignment consistent with the
+ component, intrinsic assignment for each other nonpointer nonallocatable
+ component, and intrinsic assignment for each allocated coarray component.
+ For unallocated coarray components, the corresponding component of the
+ variable shall be unallocated. For a noncoarray allocatable component the
+ following sequence of operations is applied.
+ (1) If the component of the variable is allocated, it is deallocated.
+ (2) If the component of the value of expr is allocated, the
+ corresponding component of the variable is allocated with the same
+ dynamic type and type parameters as the component of the value of
+ expr. If it is an array, it is allocated with the same bounds. The
+ value of the component of the value of expr is then assigned to the
+ corresponding component of the variable using defined assignment if
+ the declared type of the component has a type-bound defined
+ assignment consistent with the component, and intrinsic assignment
+ for the dynamic type of that component otherwise."
+
+ The pointer assignments are taken care of by the intrinsic assignment of the
+ structure itself. This function recursively adds defined assignments where
+ required. The recursion is accomplished by calling gfc_resolve_code.
+
+ When the lhs in a defined assignment has intent INOUT or is intent OUT
+ and the component of 'var' is finalizable, we need a temporary for the
+ lhs. In pseudo-code for an assignment var = expr:
+
+ ! Confine finalization of temporaries, as far as possible.
+ Enclose the code for the assignment in a block
+ ! Only call function 'expr' once.
+ #if ('expr is not a constant or an variable)
+ temp_expr = expr
+ expr = temp_x
+ ! Do the intrinsic assignment
+ #if typeof ('var') has a typebound final subroutine
+ finalize (var)
+ var = expr
+ ! Now do the component assignments
+ #do over derived type components [%cmp]
+ #if (cmp is a pointer of any kind)
+ continue
+ build the assignment
+ resolve the code
+ #if the code is a typebound assignment
+ #if (arg1 is INOUT or finalizable OUT && !t1)
+ t1 = var
+ arg1 = t1
+ deal with allocatation or not of var and this component
+ #elseif the code is an assignment by itself
+ #if this component does not need finalization
+ delete code and continue
+ #else
+ remove the leading assignment
+ #endif
+ commit the code
+ #if (t1 and (arg1 is INOUT or finalizable OUT))
+ var%cmp = t1%cmp
+ #enddo
+ put all code chunks involving t1 to the top of the generated code
+ insert the generated block in place of the original code
+*/
- The pointer assignments are taken care of by the intrinsic
- assignment of the structure itself. This function recursively adds
- defined assignments where required. The recursion is accomplished
- by calling gfc_resolve_code.
+static bool
+is_finalizable_type (gfc_typespec ts)
+{
+ gfc_component *c;
- When the lhs in a defined assignment has intent INOUT, we need a
- temporary for the lhs. In pseudo-code:
+ if (ts.type != BT_DERIVED)
+ return false;
- ! Only call function lhs once.
- if (lhs is not a constant or an variable)
- temp_x = expr2
- expr2 => temp_x
- ! Do the intrinsic assignment
- expr1 = expr2
- ! Now do the defined assignments
- do over components with typebound defined assignment [%cmp]
- #if one component's assignment procedure is INOUT
- t1 = expr1
- #if expr2 non-variable
- temp_x = expr2
- expr2 => temp_x
- # endif
- expr1 = expr2
- # for each cmp
- t1%cmp {defined=} expr2%cmp
- expr1%cmp = t1%cmp
- #else
- expr1 = expr2
+ /* (1) Check for FINAL subroutines. */
+ if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
+ return true;
- # for each cmp
- expr1%cmp {defined=} expr2%cmp
- #endif
- */
+ /* (2) Check for components of finalizable type. */
+ for (c = ts.u.derived->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED
+ && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+ && c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->finalizers)
+ return true;
+
+ return false;
+}
/* The temporary assignments have to be put on top of the additional
code to avoid the result being changed by the intrinsic assignment.
*/
static int component_assignment_level = 0;
static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
+static bool finalizable_comp;
static void
generate_component_assignments (gfc_code **code, gfc_namespace *ns)
{
gfc_component *comp1, *comp2;
gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
- gfc_expr *t1;
+ gfc_code *tmp_code = NULL;
+ gfc_expr *t1 = NULL;
+ gfc_expr *tmp_expr = NULL;
int error_count, depth;
+ bool finalizable_lhs;
gfc_get_errors (NULL, &error_count);
@@ -11531,19 +11672,39 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
return;
}
+ if (!component_assignment_level)
+ finalizable_comp = true;
+
+ /* Build a block so that function result temporaries are finalized
+ locally on exiting the rather than enclosing scope. */
+ if (!component_assignment_level)
+ {
+ ns = gfc_build_block_ns (ns);
+ tmp_code = gfc_get_code (EXEC_NOP);
+ *tmp_code = **code;
+ tmp_code->next = NULL;
+ (*code)->op = EXEC_BLOCK;
+ (*code)->ext.block.ns = ns;
+ (*code)->ext.block.assoc = NULL;
+ (*code)->expr1 = (*code)->expr2 = NULL;
+ ns->code = tmp_code;
+ code = &ns->code;
+ }
+
component_assignment_level++;
+ finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
+
/* Create a temporary so that functions get called only once. */
if ((*code)->expr2->expr_type != EXPR_VARIABLE
&& (*code)->expr2->expr_type != EXPR_CONSTANT)
{
- gfc_expr *tmp_expr;
-
/* Assign the rhs to the temporary. */
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
this_code = build_assignment (EXEC_ASSIGN,
tmp_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
+ this_code->expr2->must_finalize = 1;
/* Add the code and substitute the rhs expression. */
add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
gfc_free_expr ((*code)->expr2);
@@ -11553,8 +11714,10 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
/* Do the intrinsic assignment. This is not needed if the lhs is one
of the temporaries generated here, since the intrinsic assignment
to the final result already does this. */
- if ((*code)->expr1->symtree->n.sym->name[2] != '@')
+ if ((*code)->expr1->symtree->n.sym->name[2] != '.')
{
+ if (finalizable_lhs)
+ (*code)->expr1->must_finalize = 1;
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
NULL, NULL, (*code)->loc);
@@ -11564,21 +11727,23 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
comp1 = (*code)->expr1->ts.u.derived->components;
comp2 = (*code)->expr2->ts.u.derived->components;
- t1 = NULL;
for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
{
bool inout = false;
+ bool finalizable_out = false;
/* The intrinsic assignment does the right thing for pointers
of all kinds and allocatable components. */
if (!gfc_bt_struct (comp1->ts.type)
|| comp1->attr.pointer
- || comp1->attr.allocatable
|| comp1->attr.proc_pointer_comp
|| comp1->attr.class_pointer
|| comp1->attr.proc_pointer)
continue;
+ finalizable_comp = is_finalizable_type (comp1->ts)
+ && !finalizable_lhs;
+
/* Make an assignment for this component. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
@@ -11611,8 +11776,13 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
a temporary must be generated and used instead. */
rsym = this_code->resolved_sym;
dummy_args = gfc_sym_get_dummy_args (rsym);
- if (dummy_args
- && dummy_args->sym->attr.intent == INTENT_INOUT)
+ finalizable_out = gfc_may_be_finalized (comp1->ts)
+ && dummy_args
+ && dummy_args->sym->attr.intent == INTENT_OUT;
+ inout = dummy_args
+ && dummy_args->sym->attr.intent == INTENT_INOUT;
+ if ((inout || finalizable_out)
+ && !comp1->attr.allocatable)
{
gfc_code *temp_code;
inout = true;
@@ -11621,7 +11791,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
it at the head of the generated code. */
if (!t1)
{
- t1 = get_temp_from_expr ((*code)->expr1, ns);
+ gfc_namespace *tmp_ns = ns;
+ if (ns->parent && gfc_may_be_finalized (comp1->ts))
+ tmp_ns = (*code)->expr1->symtree->n.sym->ns;
+ t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
+ t1->symtree->n.sym->attr.artificial = 1;
temp_code = build_assignment (EXEC_ASSIGN,
t1, (*code)->expr1,
NULL, NULL, (*code)->loc);
@@ -11683,20 +11857,38 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
else if (this_code->op == EXEC_ASSIGN && !this_code->next)
{
/* Don't add intrinsic assignments since they are already
- effected by the intrinsic assignment of the structure. */
- gfc_free_statements (this_code);
- this_code = NULL;
- continue;
+ effected by the intrinsic assignment of the structure, unless
+ finalization is required. */
+ if (finalizable_comp)
+ this_code->expr1->must_finalize = 1;
+ else
+ {
+ gfc_free_statements (this_code);
+ this_code = NULL;
+ continue;
+ }
+ }
+ else
+ {
+ /* Resolution has expanded an assignment of a derived type with
+ defined assigned components. Remove the redundant, leading
+ assignment. */
+ gcc_assert (this_code->op == EXEC_ASSIGN);
+ gfc_code *tmp = this_code;
+ this_code = this_code->next;
+ tmp->next = NULL;
+ gfc_free_statements (tmp);
}
add_code_to_chain (&this_code, &head, &tail);
- if (t1 && inout)
+ if (t1 && (inout || finalizable_out))
{
/* Transfer the value to the final result. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, t1,
comp1, comp2, (*code)->loc);
+ this_code->expr1->must_finalize = 0;
add_code_to_chain (&this_code, &head, &tail);
}
}
@@ -11709,8 +11901,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
tmp_head = tmp_tail = NULL;
}
- // If we did a pointer assignment - thus, we need to ensure that the LHS is
- // not accidentally deallocated. Hence, nullify t1.
+ /* If we did a pointer assignment - thus, we need to ensure that the LHS is
+ not accidentally deallocated. Hence, nullify t1. */
if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
&& gfc_expr_attr ((*code)->expr1).allocatable)
{
@@ -11731,6 +11923,18 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
tail = block;
}
+ component_assignment_level--;
+
+ /* Make an explicit final call for the function result. */
+ if (tmp_expr)
+ generate_final_call (tmp_expr, &head, &tail);
+
+ if (tmp_code)
+ {
+ ns->code = head;
+ return;
+ }
+
/* Now attach the remaining code chain to the input code. Step on
to the end of the new code since resolution is complete. */
gcc_assert ((*code)->op == EXEC_ASSIGN);
@@ -11743,8 +11947,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
if (head != tail)
free (head);
*code = tail;
-
- component_assignment_level--;
}
@@ -12164,6 +12366,14 @@ start:
&& code->expr1->ts.u.derived
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
+ else if (code->op == EXEC_ASSIGN)
+ {
+ if (gfc_may_be_finalized (code->expr1->ts))
+ code->expr1->must_finalize = 1;
+ if (code->expr2->expr_type == EXPR_ARRAY
+ && gfc_may_be_finalized (code->expr2->ts))
+ code->expr2->must_finalize = 1;
+ }
break;
@@ -13741,6 +13951,15 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
}
arg = dummy_args->sym;
+ if (arg->as && arg->as->type == AS_ASSUMED_RANK
+ && ((list != derived->f2k_derived->finalizers) || list->next))
+ {
+ gfc_error ("FINAL procedure at %L with assumed rank argument must "
+ "be the only finalizer with the same kind/type "
+ "(F2018: C790)", &list->where);
+ goto error;
+ }
+
/* This argument must be of our type. */
if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
{
@@ -13841,7 +14060,8 @@ error:
if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
gfc_warning (OPT_Wsurprising,
"Only array FINAL procedures declared for derived type %qs"
- " defined at %L, suggest also scalar one",
+ " defined at %L, suggest also scalar one unless an assumed"
+ " rank finalizer has been declared",
derived->name, &derived->declared_at);
vtab = gfc_find_derived_vtab (derived);
@@ -14573,7 +14793,6 @@ check_defined_assignments (gfc_symbol *derived)
{
if (!gfc_bt_struct (c->ts.type)
|| c->attr.pointer
- || c->attr.allocatable
|| c->attr.proc_pointer_comp
|| c->attr.class_pointer
|| c->attr.proc_pointer)
@@ -14587,6 +14806,9 @@ check_defined_assignments (gfc_symbol *derived)
return;
}
+ if (c->attr.allocatable)
+ continue;
+
check_defined_assignments (c->ts.u.derived);
if (c->ts.u.derived->attr.defined_assign_comp)
{
@@ -15261,7 +15483,7 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.access != ACCESS_PRIVATE
- && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template))
+ && !(sym->attr.vtype || sym->attr.pdt_template))
{
gfc_symbol *vtab = gfc_find_derived_vtab (sym);
gfc_set_sym_referenced (vtab);
@@ -16357,6 +16579,15 @@ resolve_symbol (gfc_symbol *sym)
if (sym->param_list)
resolve_pdt (sym);
+
+ if (!sym->attr.referenced
+ && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+ {
+ gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
+ if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
+ gfc_set_sym_referenced (sym);
+ gfc_free_expr (final_expr);
+ }
}
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 63bd1ac573a..7bc0e03dd0d 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);
}
@@ -2026,10 +2026,11 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
for the dynamic parts must be allocated using realloc. */
static void
-gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor_base base,
- tree * poffset, tree * offsetvar,
- bool dynamic)
+gfc_trans_array_constructor_value (stmtblock_t * pblock,
+ stmtblock_t * finalblock,
+ tree type, tree desc,
+ gfc_constructor_base base, tree * poffset,
+ tree * offsetvar, bool dynamic)
{
tree tmp;
tree start = NULL_TREE;
@@ -2039,6 +2040,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_se se;
mpz_t size;
gfc_constructor *c;
+ gfc_typespec ts;
+ int ctr = 0;
tree shadow_loopvar = NULL_TREE;
gfc_saved_var saved_loopvar;
@@ -2046,6 +2049,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
mpz_init (size);
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
+ ctr++;
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
gfc_put_offset_into_var (pblock, poffset, offsetvar);
@@ -2091,8 +2095,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
- gfc_trans_array_constructor_value (&body, type, desc,
- c->expr->value.constructor,
+ gfc_trans_array_constructor_value (&body, finalblock, type,
+ desc, c->expr->value.constructor,
poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
@@ -2200,6 +2204,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
+ ts = c->expr->ts;
}
/* The frontend should already have done any expansions
@@ -2292,6 +2297,34 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
}
}
+
+ /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+ constructor or array constructor, the entity created by the constructor is
+ finalized after execution of the innermost executable construct containing
+ the reference. This, in fact, was later deleted by the Combined Techical
+ Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
+
+ Transmit finalization of this constructor through 'finalblock'. */
+ if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL
+ && gfc_may_be_finalized (ts)
+ && ctr > 0 && desc != NULL_TREE
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ symbol_attribute attr;
+ gfc_se fse;
+ gfc_warning (0, "The structure constructor at %C has been"
+ " finalized. This feature was removed by f08/0011."
+ " Use -std=f2018 or -std=gnu to eliminate the"
+ " finalization.");
+ attr.pointer = attr.allocatable = 0;
+ gfc_init_se (&fse, NULL);
+ fse.expr = desc;
+ gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
+ gfc_add_block_to_block (finalblock, &fse.pre);
+ gfc_add_block_to_block (finalblock, &fse.finalblock);
+ gfc_add_block_to_block (finalblock, &fse.post);
+ }
+
mpz_clear (size);
}
@@ -2738,6 +2771,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
gfc_ss *s;
tree neg_len;
char *msg;
+ stmtblock_t finalblock;
/* Save the old values for nested checking. */
old_first_len = first_len;
@@ -2897,8 +2931,12 @@ trans_array_constructor (gfc_ss * ss, locus * where)
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
suppress_warning (offsetvar);
TREE_USED (offsetvar) = 0;
- gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
- &offset, &offsetvar, dynamic);
+
+ gfc_init_block (&finalblock);
+ gfc_trans_array_constructor_value (&outer_loop->pre,
+ expr->must_finalize ? &finalblock : NULL,
+ type, desc, c, &offset, &offsetvar,
+ dynamic);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
@@ -2933,6 +2971,15 @@ finish:
first_len = old_first_len;
first_len_val = old_first_len_val;
typespec_chararray_ctor = old_typespec_chararray_ctor;
+
+ /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+ constructor or array constructor, the entity created by the constructor is
+ finalized after execution of the innermost executable construct containing
+ the reference. */
+ if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+ && finalblock.head != NULL_TREE)
+ gfc_add_block_to_block (&loop->post, &finalblock);
+
}
@@ -3161,6 +3208,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
+ gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
ss_info->string_length = se.string_length;
break;
@@ -6454,23 +6502,29 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
for (dim = as->rank; dim < as->rank + as->corank; dim++)
{
- /* Evaluate non-constant array bound expressions. */
+ /* Evaluate non-constant array bound expressions.
+ F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
+ references a function, the result is finalized before execution of the
+ executable constructs in the scoping unit.
+ Adding the finalblocks enables this. */
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (as->lower[dim] && !INTEGER_CST_P (lbound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, lbound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, lbound, se.expr);
+ }
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, ubound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, ubound, se.expr);
+ }
}
}
@@ -6499,23 +6553,29 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
offset = gfc_index_zero_node;
for (dim = 0; dim < as->rank; dim++)
{
- /* Evaluate non-constant array bound expressions. */
+ /* Evaluate non-constant array bound expressions.
+ F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
+ references a function, the result is finalized before execution of the
+ executable constructs in the scoping unit.
+ Adding the finalblocks enables this. */
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (as->lower[dim] && !INTEGER_CST_P (lbound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, lbound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, lbound, se.expr);
+ }
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, ubound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, ubound, se.expr);
+ }
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
lbound, size);
@@ -6529,19 +6589,19 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
stride = GFC_TYPE_ARRAY_SIZE (type);
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
- {
- /* Calculate stride = size * (ubound + 1 - lbound). */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ {
+ /* Calculate stride = size * (ubound + 1 - lbound). */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfc_index_one_node, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, ubound, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
- if (stride)
- gfc_add_modify (pblock, stride, tmp);
- else
- stride = gfc_evaluate_now (tmp, pblock);
+ if (stride)
+ gfc_add_modify (pblock, stride, tmp);
+ else
+ stride = gfc_evaluate_now (tmp, pblock);
/* Make sure that negative size arrays are translated
to being zero size. */
@@ -6551,7 +6611,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
gfc_array_index_type, tmp,
stride, gfc_index_zero_node);
gfc_add_modify (pblock, stride, tmp);
- }
+ }
size = stride;
}
@@ -7531,7 +7591,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)
{
@@ -8973,9 +9033,10 @@ 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)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -9063,11 +9124,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);
@@ -9101,13 +9163,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);
}
@@ -9169,7 +9233,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
{
@@ -9177,7 +9241,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);
}
}
@@ -9293,8 +9358,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,
@@ -9322,7 +9387,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
{
@@ -9330,7 +9395,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);
}
}
@@ -9628,7 +9694,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;
@@ -9664,7 +9731,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);
}
}
@@ -9772,7 +9839,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;
@@ -10145,7 +10213,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);
}
@@ -10158,7 +10227,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
@@ -10196,7 +10266,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;
}
@@ -10206,10 +10277,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);
}
@@ -10217,7 +10290,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);
}
@@ -10233,6 +10307,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 suppressing any
+ finalization that might occur. This is used in the finalization of
+ function results. */
+
+tree
+gfc_copy_alloc_comp_no_fini (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);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
copy only its allocatable components. */
@@ -10972,7 +11060,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);
}
@@ -11145,8 +11233,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS)
&& sym->ts.u.derived->attr.alloc_comp;
- has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
- ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+ has_finalizer = gfc_may_be_finalized (sym->ts);
/* Make sure the frontend gets these right. */
gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
@@ -11269,6 +11356,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
else if ((!sym->attr.allocatable || !has_finalizer)
&& sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
&& !sym->attr.pointer && !sym->attr.save
+ && !(sym->attr.artificial && sym->name[0] == '_')
&& !sym->ns->proc_name->attr.is_main_program)
{
int rank;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 9296fa63250..5408755138e 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_no_fini (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-decl.cc b/gcc/fortran/trans-decl.cc
index 474920966ec..77610df340b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4345,6 +4345,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_formal_arglist *f;
tree tmp;
tree present;
+ gfc_symbol *s;
+ bool dealloc_with_value = false;
gfc_init_block (&init);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
@@ -4352,42 +4354,52 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
+ s = f->sym;
tmp = NULL_TREE;
/* Note: Allocatables are excluded as they are already handled
by the caller. */
if (!f->sym->attr.allocatable
- && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
+ && gfc_is_finalizable (s->ts.u.derived, NULL))
{
stmtblock_t block;
gfc_expr *e;
gfc_init_block (&block);
- f->sym->attr.referenced = 1;
- e = gfc_lval_expr_from_sym (f->sym);
+ s->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (s);
gfc_add_finalizer_call (&block, e);
gfc_free_expr (e);
tmp = gfc_finish_block (&block);
}
- if (tmp == NULL_TREE && !f->sym->attr.allocatable
- && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (tmp == NULL_TREE && !s->attr.allocatable
+ && s->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
+ s->backend_decl,
+ s->as ? s->as->rank : 0);
+ dealloc_with_value = s->value;
+ }
- if (tmp != NULL_TREE && (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master))
+ if (tmp != NULL_TREE && (s->attr.optional
+ || s->ns->proc_name->attr.entry_master))
{
- present = gfc_conv_expr_present (f->sym);
+ present = gfc_conv_expr_present (s);
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
present, tmp, build_empty_stmt (input_location));
}
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE && !dealloc_with_value)
gfc_add_expr_to_block (&init, tmp);
- else if (f->sym->value && !f->sym->attr.allocatable)
- gfc_init_default_dt (f->sym, &init, true);
+ else if (s->value && !s->attr.allocatable)
+ {
+ gfc_add_expr_to_block (&init, tmp);
+ gfc_init_default_dt (s, &init, false);
+ dealloc_with_value = false;
+ }
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
@@ -4411,10 +4423,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
present, tmp,
build_empty_stmt (input_location));
}
-
gfc_add_expr_to_block (&init, tmp);
}
-
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index dcd39f46776..d996d295bd2 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1911,6 +1911,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;
@@ -7074,6 +7075,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
@@ -7440,6 +7442,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
vec_safe_push (arglist, parmse.expr);
}
+
gfc_add_block_to_block (&se->pre, &clobbers);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
@@ -7738,9 +7741,20 @@ 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 : NULL
+ :
+ sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
+ bool finalizable = der != NULL && der->ns->proc_name
+ && gfc_is_finalizable (der, NULL);
+
+ if (!byref && finalizable)
+ gfc_finalize_tree_expr (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);
@@ -7800,6 +7814,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)
+ gfc_finalize_tree_expr (se, der, attr, expr->rank);
}
else if (ts.type == BT_CHARACTER)
{
@@ -7892,8 +7909,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)
{
@@ -7915,66 +7930,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))
+ gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
}
-
-no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
@@ -9486,10 +9450,29 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
case EXPR_STRUCTURE:
gfc_conv_structure (se, expr, 0);
+ /* F2008 4.5.6.3 para 5: If an executable construct references a
+ structure constructor or array constructor, the entity created by
+ the constructor is finalized after execution of the innermost
+ executable construct containing the reference. This, in fact,
+ was later deleted by the Combined Techical Corrigenda 1 TO 4 for
+ fortran 2008 (f08/0011). */
+ if (!gfc_notification_std (GFC_STD_F2018_DEL) && expr->must_finalize
+ && gfc_may_be_finalized (expr->ts))
+ {
+ gfc_warning (0, "The structure constructor at %C has been"
+ " finalized. This feature was removed by f08/0011."
+ " Use -std=f2018 or -std=gnu to eliminate the"
+ " finalization.");
+ symbol_attribute attr;
+ attr.allocatable = attr.pointer = 0;
+ gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
+ gfc_add_block_to_block (&se->post, &se->finalblock);
+ }
break;
case EXPR_ARRAY:
gfc_conv_array_constructor_expr (se, expr);
+ gfc_add_block_to_block (&se->post, &se->finalblock);
break;
default:
@@ -10490,7 +10473,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);
@@ -10498,6 +10482,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,
@@ -10527,8 +10512,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
else if (gfc_bt_struct (ts.type))
{
- gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
+ gfc_add_block_to_block (&block, &lse->pre);
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
@@ -10538,6 +10524,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))
{
@@ -10868,6 +10855,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_ss *ss = NULL;
gfc_component *comp = NULL;
gfc_loopinfo loop;
+ tree tmp;
+ tree lhs;
+ gfc_se final_se;
+ gfc_symbol *sym = expr1->symtree->n.sym;
+ bool finalizable = gfc_may_be_finalized (expr1->ts);
if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
@@ -10886,12 +10878,44 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre);
se.want_pointer = 1;
+ /* First the lhs must be finalized, if necessary. We use a copy of the symbol
+ backend decl, stash the original away for the finalization so that the
+ value used is that before the assignment. This is necessary because
+ evaluation of the rhs expression using direct by reference can change
+ the value. However, the standard mandates that the finalization must occur
+ after evaluation of the rhs. */
+ gfc_init_se (&final_se, NULL);
+
+ if (finalizable)
+ {
+ tmp = sym->backend_decl;
+ lhs = sym->backend_decl;
+ if (TREE_CODE (tmp) == INDIRECT_REF)
+ tmp = TREE_OPERAND (tmp, 0);
+ sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
+ gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
+ expr1->rank, 0);
+ gfc_add_expr_to_block (&final_se.pre, tmp);
+ }
+ }
+
+ if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
+ {
+ gfc_add_block_to_block (&se.pre, &final_se.pre);
+ gfc_add_block_to_block (&se.post, &final_se.finalblock);
+ }
+
+ if (finalizable)
+ sym->backend_decl = lhs;
+
gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
if (expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived->attr.alloc_comp)
{
- tree tmp;
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
expr1->rank);
gfc_add_expr_to_block (&se.pre, tmp);
@@ -10901,6 +10925,18 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);
+ /* Since this is a direct by reference call, references to the lhs can be
+ used for finalization of the function result just as long as the blocks
+ from final_se are added at the right time. */
+ gfc_init_se (&final_se, NULL);
+ if (finalizable && expr2->value.function.esym)
+ {
+ final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
+ expr2->value.function.esym->attr,
+ expr2->rank);
+ }
+
/* Reallocate on assignment needs the loopinfo for extrinsic functions.
This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
Clearly, this cannot be done for an allocatable function result, since
@@ -10931,7 +10967,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
}
gfc_conv_function_expr (&se, expr2);
+
+ /* Fix the result. */
gfc_add_block_to_block (&se.pre, &se.post);
+ if (finalizable)
+ gfc_add_block_to_block (&se.pre, &final_se.pre);
+
+ /* Do the finalization, including final calls from function arguments. */
+ if (finalizable)
+ {
+ gfc_add_block_to_block (&se.pre, &final_se.post);
+ gfc_add_block_to_block (&se.pre, &se.finalblock);
+ gfc_add_block_to_block (&se.pre, &final_se.finalblock);
+ }
if (ss)
gfc_cleanup_loop (&loop);
@@ -11454,6 +11502,17 @@ 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;
+ bool final_expr;
+
+ final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
+ if (final_expr)
+ {
+ if (rse->loop)
+ gfc_prepend_expr_to_block (&rse->loop->pre,
+ gfc_finish_block (&lse->finalblock));
+ else
+ gfc_add_block_to_block (block, &lse->finalblock);
+ }
/* Store the old vptr so that dynamic types can be compared for
reallocation to occur or not. */
@@ -11479,8 +11538,9 @@ 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;
+ tmp = lse->expr;
+ class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ ? gfc_class_data_get (tmp) : tmp;
if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
class_han = gfc_build_addr_expr (NULL_TREE, class_han);
@@ -11501,6 +11561,10 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
tmp, re, build_empty_stmt (input_location));
gfc_add_expr_to_block (&re_alloc, re);
+ tree realloc_expr = lhs->ts.type == BT_CLASS ?
+ gfc_finish_block (&re_alloc) :
+ build_empty_stmt (input_location);
+
/* Allocate if _data is NULL, reallocate otherwise. */
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
@@ -11509,7 +11573,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_unlikely (tmp,
PRED_FORTRAN_FAIL_ALLOC),
gfc_finish_block (&alloc),
- gfc_finish_block (&re_alloc));
+ realloc_expr);
gfc_add_expr_to_block (&lse->pre, tmp);
}
@@ -11582,6 +11646,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
@@ -11605,6 +11670,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ bool final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
@@ -11636,15 +11702,29 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
rss = NULL;
- if ((expr1->ts.type == BT_DERIVED)
- && (gfc_is_class_array_function (expr2)
- || gfc_is_alloc_class_scalar_function (expr2)))
- expr2->must_finalize = 1;
+ if (expr2->expr_type != EXPR_VARIABLE
+ && expr2->expr_type != EXPR_CONSTANT
+ && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
+ {
+ expr2->must_finalize = 1;
+ /* F2008 4.5.6.3 para 5: If an executable construct references a
+ structure constructor or array constructor, the entity created by
+ the constructor is finalized after execution of the innermost
+ executable construct containing the reference.
+ These finalizations were later deleted by the Combined Techical
+ Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
+ if (gfc_notification_std (GFC_STD_F2018_DEL)
+ && (expr2->expr_type == EXPR_STRUCTURE
+ || expr2->expr_type == EXPR_ARRAY))
+ expr2->must_finalize = 0;
+ }
+
/* Checking whether a class assignment is desired is quite complicated and
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
@@ -11918,6 +11998,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
@@ -11963,6 +12045,27 @@ 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 (&lse, expr1, init_flag);
+ if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.artificial))
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_block_to_block (&block, &lse.finalblock);
+ }
+ else
+ {
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_block_to_block (&loop.code[expr1->rank - 1],
+ &lse.finalblock);
+ }
+ }
+ 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,
@@ -11972,12 +12075,20 @@ 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 (!l_is_temp)
+ {
+ 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)
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index cc69045dd4f..baeea955d35 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2690,6 +2690,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 2b4278be748..f78875455a5 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -444,7 +444,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
@@ -543,6 +544,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);
}
@@ -2189,6 +2191,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_expr *lhs;
tree res;
gfc_se se;
+ stmtblock_t final_block;
gfc_init_se (&se, NULL);
@@ -2196,6 +2199,15 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
allocation can take place automatically in gfc_trans_assignment.
The frontend prevents them from being either allocated,
deallocated or reallocated. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = sym->backend_decl;
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp,
+ sym->attr.dimension ? sym->as->rank : 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
@@ -2206,9 +2218,33 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
}
lhs = gfc_lval_expr_from_sym (sym);
+ lhs->must_finalize = 0;
res = gfc_trans_assignment (lhs, e, false, true);
gfc_add_expr_to_block (&se.pre, res);
+ gfc_init_block (&final_block);
+
+ if (sym->attr.associate_var
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.defined_assign_comp
+ && gfc_may_be_finalized (sym->ts)
+ && e->expr_type == EXPR_FUNCTION)
+ {
+ gfc_expr *ef;
+ ef = gfc_lval_expr_from_sym (sym);
+ gfc_add_finalizer_call (&final_block, ef);
+ gfc_free_expr (ef);
+ }
+
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = sym->backend_decl;
+ tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived,
+ tmp, 0);
+ gfc_add_expr_to_block (&final_block, tmp);
+ }
+
tmp = sym->backend_decl;
if (e->expr_type == EXPR_FUNCTION
&& sym->ts.type == BT_DERIVED
@@ -2243,6 +2279,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
else
tmp = NULL_TREE;
+ gfc_add_expr_to_block (&final_block, tmp);
+ tmp = gfc_finish_block (&final_block);
res = gfc_finish_block (&se.pre);
gfc_add_init_cleanup (block, res, tmp);
gfc_free_expr (lhs);
@@ -6347,7 +6385,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);
@@ -7007,8 +7048,13 @@ gfc_trans_allocate (gfc_code * code)
gfc_expr *init_expr = gfc_expr_to_initialize (expr);
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
flag_realloc_lhs = 0;
+
+ /* Set the symbol to be artificial so that the result is not finalized. */
+ init_expr->symtree->n.sym->attr.artificial = 1;
tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
false);
+ init_expr->symtree->n.sym->attr.artificial = 0;
+
flag_realloc_lhs = realloc_lhs;
/* Free the expression allocated for init_expr. */
gfc_free_expr (init_expr);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 4c2193bad36..f7745add045 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1098,7 +1098,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
else
{
gfc_conv_expr (&se, var);
- gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+// gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
@@ -1276,6 +1276,14 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
return false;
+ /* Finalization of these temporaries is made by explicit calls in
+ resolve.cc(generate_component_assignments). */
+ if (expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->name[0] == '_'
+ && expr2->ts.type == BT_DERIVED
+ && expr2->ts.u.derived->attr.defined_assign_comp)
+ return false;
+
if (expr2->ts.type == BT_DERIVED)
{
gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
@@ -1370,6 +1378,277 @@ gfc_add_finalizer_call (stmtblock_t *block, 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 */
+
+bool
+gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
+{
+ 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;
+ stmtblock_t final_block;
+ gfc_init_block (&final_block);
+ gfc_expr *finalize_expr;
+ bool class_array_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 false;
+
+ class_array_ref = ref && ref->type == REF_COMPONENT
+ && !strcmp (ref->u.c.component->name, "_data")
+ && ref->next && ref->next->type == REF_ARRAY
+ && !ref->next->next;
+
+ if (class_array_ref)
+ {
+ finalize_expr = gfc_lval_expr_from_sym (sym);
+ finalize_expr->must_finalize = 1;
+ ref = NULL;
+ }
+ else
+ finalize_expr = gfc_copy_expr (expr1);
+
+ /* F2018 7.5.6.2: Only finalizable entities are finalized. */
+ if (!(expr1->ts.type == BT_DERIVED
+ && gfc_is_finalizable (expr1->ts.u.derived, NULL))
+ && expr1->ts.type != BT_CLASS)
+ return false;
+
+ if (!gfc_may_be_finalized (sym->ts))
+ return false;
+
+ gfc_init_block (&final_block);
+ bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
+ gfc_free_expr (finalize_expr);
+
+ if (!finalizable)
+ return false;
+
+ 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));
+ }
+
+ gfc_add_expr_to_block (&lse->finalblock, final_expr);
+
+ return true;
+}
+
+
+/* Finalize a TREE expression using the finalizer wrapper. The result is
+ fixed in order to prevent repeated calls. */
+
+void
+gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
+ symbol_attribute attr, int rank)
+{
+ tree vptr, final_fndecl, desc, tmp, size, is_final;
+ tree data_ptr, data_null, cond;
+ gfc_symbol *vtab;
+ gfc_se post_se;
+ bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+ if (attr.pointer)
+ return;
+
+ /* Derived type function results with components that have defined
+ assignements are handled in resolve.cc(generate_component_assignments) */
+ if (derived && (derived->attr.is_c_interop
+ || derived->attr.is_iso_c
+ || derived->attr.is_bind_c
+ || derived->attr.defined_assign_comp))
+ 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 if (derived && gfc_is_finalizable (derived, NULL))
+ {
+ if (derived->attr.zero_comp && !rank)
+ {
+ /* Any attempt to assign zero length entities, causes the gimplifier
+ all manner of problems. Instead, a variable is created to act as
+ as the argument for the final call. */
+ desc = gfc_create_var (TREE_TYPE (se->expr), "zero");
+ }
+ else if (se->direct_byref)
+ {
+ desc = gfc_evaluate_now (se->expr, &se->finalblock);
+ if (derived->attr.alloc_comp)
+ {
+ /* Need to copy allocated components and not finalize. */
+ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ }
+ }
+ else
+ {
+ desc = gfc_evaluate_now (se->expr, &se->pre);
+ se->expr = gfc_evaluate_now (desc, &se->pre);
+ if (derived->attr.alloc_comp)
+ {
+ /* Need to copy allocated components and not finalize. */
+ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
+
+ 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);
+ }
+ else
+ return;
+
+ 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));
+ }
+ }
+
+ if (derived && derived->attr.zero_comp)
+ {
+ /* All the conditions below break down for zero length derived types. */
+ tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ size, boolean_false_node);
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ return;
+ }
+
+ if (!VAR_P (desc))
+ {
+ tmp = gfc_create_var (TREE_TYPE (desc), "res");
+ if (se->direct_byref)
+ gfc_add_modify (&se->finalblock, tmp, desc);
+ else
+ gfc_add_modify (&se->pre, tmp, desc);
+ desc = tmp;
+ }
+
+ data_ptr = gfc_conv_descriptor_data_get (desc);
+ data_null = fold_convert (TREE_TYPE (data_ptr), null_pointer_node);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, data_ptr, data_null);
+ is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ logical_type_node, is_final, cond);
+ 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)
+ {
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ gfc_add_modify (&se->loop->post, data_ptr, data_null);
+ }
+ else
+ {
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+
+ /* Let the scalarizer take care of freeing of temporary arrays. */
+ if (attr.allocatable && !(se->loop && se->loop->temp_dim))
+ {
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ gfc_add_modify (&se->finalblock, data_ptr, data_null);
+ }
+ }
+}
+
+
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9c6a1c06bf6..1ad6d944fcf 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. */
@@ -450,6 +454,8 @@ tree gfc_get_vptr_from_expr (tree);
tree gfc_copy_class_to_class (tree, tree, tree, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
+void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
+bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
bool, tree *derived_array = NULL);
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" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_25.f90 b/gcc/testsuite/gfortran.dg/associate_25.f90
index d3137300282..97b53f64ded 100644
--- a/gcc/testsuite/gfortran.dg/associate_25.f90
+++ b/gcc/testsuite/gfortran.dg/associate_25.f90
@@ -21,9 +21,7 @@ contains
associate(X => T()) ! This was failing: Symbol 'x' at (1) has no IMPLICIT type
final_flag = X%val
end associate
-! This should now be 4 but the finalization is not happening.
-! TODO put it right!
- if (final_flag .ne. 2) STOP 1
+ if (final_flag .ne. 2) stop 1
end subroutine Testf
end module
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index 4ee7121cc27..93d4f95ddf6 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -24,7 +24,7 @@ contains
allocate(x%i(1000))
end subroutine
-end program
+end program
! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
-! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_vptr->_final \\(&desc" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/finalize_38.f90 b/gcc/testsuite/gfortran.dg/finalize_38.f90
new file mode 100644
index 00000000000..f4b00a16a54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_38.f90
@@ -0,0 +1,222 @@
+! { dg-do run }
+!
+! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
+! With -std=gnu, no finalization of array or structure constructors should occur.
+! See finalize_38a.f90 for the result with f2008.
+! Tests fix for PR64290 as well.
+!
+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)
+ class(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) then
+ stop 1 + off
+ endif
+ if (check_scalar .ne. scalar) then
+ stop 2 + off
+ endif
+ if (any (check_array(1:size (array, 1)) .ne. array)) then
+ stop 3 + off
+ endif
+ if (present (rind)) then
+ stop 4 + off
+ end if
+ if (present (rarray)) then
+ if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
+ stop 5 + off
+ endif
+ end if
+ final_count = 0
+ 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 - no finalization of 'var' before (re)allocation
+! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
+ MyType = ThyType
+ 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) (para 1 of F2018 7.5.6.3.).
+ MyType = MyType2
+ call test(1, 1, [0,0], 10)
+
+ allocate(MyTypeArray(2))
+ MyTypeArray%ind = [42, 43]
+! This should result no calls.
+ call test(0, 1, [0,0], 20)
+
+! This should result in a final call 'var' = initialization = simple(22).
+ ThyType2 = simple(99)
+ call test(1, 22, [0,0], 30)
+
+! This should result in a final call for 'var' with self = simple(21).
+ ThyType = ThyType2
+ call test(1, 21, [0,0], 40)
+
+! This should result in two final calls; the last is for Mytype2 = simple(2).
+ deallocate (MyType, MyType2)
+ call test(2, 2, [0,0], 50)
+
+! This should result in one final call; MyTypeArray = [simple(42),simple(43)].
+ deallocate (MyTypeArray)
+ call test(1, 0, [42,43], 60)
+
+! The lhs is finalized before assignment.
+! The function result is finalized after the assignment.
+! NAGFOR doesn't finalize the function result.
+ allocate (MyType, source = simple (11))
+ MyType = constructor1 (99)
+ call test(2, 99, [0,0], 70)
+ deallocate (MyType)
+! *****************
+! Class assignments
+! *****************
+
+ final_count = 0
+
+! This should result in a final call for MyClass, which is simple(3).
+ allocate (MyClass, source = simple (3))
+ MyClass = simple (4)
+ call test(1, 3, [0,0], 100)
+
+! This should result in a final call with the assigned value of simple(4).
+ deallocate (MyClass)
+ call test(1, 4, [0,0], 110)
+
+
+ allocate (MyClassArray, source = [simple (5), simple (6)])
+! Make sure that there is no final call since MyClassArray is not allocated.
+ call test(0, 4, [0,0], 120)
+
+ MyClassArray = [simple (7), simple (8)]
+! The only final call should finalize 'var'.
+! NAGFOR does something strange here: makes a scalar final call with value
+! simple(5).
+ call test(1, 0, [5,6], 130)
+
+! This should result in a final call with the assigned value.
+ deallocate (MyClassArray)
+ call test(1, 0, [7,8], 140)
+
+! This should produce no final calls since MyClassArray was deallocated.
+ allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
+
+! This should produce calls to destructor4 then destructor2.
+ if (allocated (MyClassArray)) 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(2, 0, [1, 3], 150, rarray = [2.0, 4.0])
+
+! This produces 2 final calls in turn for 'src' as it goes out of scope, for
+! MyClassArray before it is assigned to and the result of 'constructor2' after
+! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
+ MyClassArray = constructor2 ([10,20], [10.0,20.0])
+ call test(4, 0, [10,20], 160, rarray = [10.0,20.0])
+
+! This produces two final calls with the contents of 'MyClassArray. and its
+! parent component.
+ deallocate (MyClassArray)
+ call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])
+
+! Clean up for valgrind testing
+ if (allocated (MyType)) deallocate (MyType)
+ if (allocated (MyType2)) deallocate (MyType2)
+ if (allocated (MyTypeArray)) deallocate (MyTypeArray)
+ if (allocated (MyClass)) deallocate (MyClass)
+end program test_final
diff --git a/gcc/testsuite/gfortran.dg/finalize_38a.f90 b/gcc/testsuite/gfortran.dg/finalize_38a.f90
new file mode 100644
index 00000000000..26041a0aa97
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_38a.f90
@@ -0,0 +1,240 @@
+! { dg-do run }
+! { dg-options "-std=f2008" }
+!
+! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
+! With -std=f2008, structure and array constructors are finalized.
+! See finalize_38.f90 for the result with -std=gnu.
+! Tests fix for PR64290 as well.
+!
+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
+ integer :: fails = 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)
+ class(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)] ! { dg-warning "has been finalized" }
+ 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) then
+ print *, 1 + off, final_count, '(', cnt, ')'
+ fails = fails + 1
+ endif
+ if (check_scalar .ne. scalar) then
+ print *, 2 + off, check_scalar, '(', scalar, ')'
+ fails = fails + 1
+ endif
+ if (any (check_array(1:size (array, 1)) .ne. array)) then
+ print *, 3 + off, check_array(1:size (array, 1)) , '(', array, ')'
+ fails = fails + 1
+ endif
+ if (present (rind)) then
+ if (check_real .ne. rind) then
+ print *, 4 + off, check_real,'(', rind, ')'
+ fails = fails + 1
+ endif
+ end if
+ if (present (rarray)) then
+ if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
+ print *, 5 + off, check_rarray(1:size (rarray, 1)), '(', rarray, ')'
+ fails = fails + 1
+ endif
+ end if
+ final_count = 0
+ 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 - no finalization of 'var' before (re)allocation
+! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
+ MyType = ThyType
+ 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) (para 1 of F2018 7.5.6.3.).
+ 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)],
+! followed by the finalization of the array constructor = self = [simple(21),simple(22)].
+ MyTypeArray = [ThyType, ThyType2] ! { dg-warning "has been finalized" }
+ call test(2, 0, [21,22], 20)
+
+! This should result in a final call 'var' = initialization = simple(22),
+! followed by one with for the structure constructor.
+ ThyType2 = simple(99) ! { dg-warning "has been finalized" }
+ call test(2, 99, [0,0], 30)
+
+! This should result in a final call for 'var' with self = simple(21).
+ ThyType = ThyType2
+ call test(1, 21, [0,0], 40)
+
+! This should result in two final calls; the last is for Mytype2 = simple(2).
+ deallocate (MyType, MyType2)
+ call test(2, 2, [0,0], 50)
+
+! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
+ deallocate (MyTypeArray)
+ call test(1, 0, [21,22], 60)
+
+! The lhs is finalized before assignment.
+! The function result is finalized after the assignment.
+ allocate (MyType, source = simple (11))
+ MyType = constructor1 (99)
+ call test(2, 99, [0,0], 70)
+ deallocate (MyType)
+! *****************
+! Class assignments
+! *****************
+
+ final_count = 0
+
+! This should result in a final call for MyClass, which is simple(3) and then
+! the structure constructor with value simple(4)).
+ allocate (MyClass, source = simple (3))
+ MyClass = simple (4) ! { dg-warning "has been finalized" }
+ call test(2, 4, [0,0], 100)
+
+! This should result in a final call with the assigned value of simple(4).
+ deallocate (MyClass)
+ call test(1, 4, [0,0], 110)
+
+
+ allocate (MyClassArray, source = [simple (5), simple (6)])
+! Make sure that there is no final call since MyClassArray is not allocated.
+ call test(0, 4, [0,0], 120)
+
+ MyClassArray = [simple (7), simple (8)] ! { dg-warning "has been finalized" }
+! The first final call should finalize MyClassArray and the second should return
+! the value of the array constructor.
+ call test(2, 0, [7,8], 130)
+
+! This should result in a final call with the assigned value.
+ deallocate (MyClassArray)
+ call test(1, 0, [7,8], 140)
+
+! This should produce no final calls since MyClassArray was deallocated.
+ 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(2, 0, [1, 3], 150, rarray = [2.0, 4.0])
+
+! This produces 2 final calls in turn for 'src' as it goes out of scope, for
+! MyClassArray before it is assigned to and the result of 'constructor2' after
+! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
+ MyClassArray = constructor2 ([10,20], [10.0,20.0])
+ call test(6, 0, [10,20], 160, rarray = [10.0,20.0])
+
+! This produces two final calls with the contents of 'MyClassArray. and its
+! parent component.
+ deallocate (MyClassArray)
+ call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])
+
+! Clean up for valgrind testing
+ if (allocated (MyType)) deallocate (MyType)
+ if (allocated (MyType2)) deallocate (MyType2)
+ if (allocated (MyTypeArray)) deallocate (MyTypeArray)
+ if (allocated (MyClass)) deallocate (MyClass)
+ if (allocated (MyClassArray)) deallocate (MyClassArray)
+
+! Error messages printed out by 'test'.
+ if (fails .ne. 0) then
+ Print *, fails, " Errors"
+ error stop
+ endif
+end program test_final
diff --git a/gcc/testsuite/gfortran.dg/finalize_39.f90 b/gcc/testsuite/gfortran.dg/finalize_39.f90
new file mode 100644
index 00000000000..58f338d2ebc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_39.f90
@@ -0,0 +1,71 @@
+! { 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 <baladi@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
diff --git a/gcc/testsuite/gfortran.dg/finalize_40.f90 b/gcc/testsuite/gfortran.dg/finalize_40.f90
new file mode 100644
index 00000000000..cf85f1398e1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_40.f90
@@ -0,0 +1,44 @@
+! { dg-do run }
+!
+! Test that PR67471 is fixed. Used not to call the finalizer.
+!
+! Contributed by Ian Harvey <ian_harvey@bigpond.com>
+!
+module test_final_mod
+ implicit none
+ type :: my_final
+ integer :: n = 1
+ contains
+ final :: destroy_scalar, 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
+
+! Eliminate the warning about the lack of a scalar finalizer.
+ subroutine destroy_scalar(self)
+ type(my_final), intent(inout) :: self
+ final_calls = final_calls + self%n
+ end subroutine destroy_scalar
+
+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
diff --git a/gcc/testsuite/gfortran.dg/finalize_41.f90 b/gcc/testsuite/gfortran.dg/finalize_41.f90
new file mode 100644
index 00000000000..9458d9c6664
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_41.f90
@@ -0,0 +1,139 @@
+! { dg-do run }
+!
+! Test that PR69298 is fixed. Used to segfault on finalization in
+! subroutine 'in_type'.
+!
+! Contributed by Neil Carlson <neil.n.carlson@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 ! At entry: 1 array and 9 scalars
+ new_test%thing = stuff_type( 4 ) ! Gives 2 scalar calls
+ do i = 1, 3
+ new_test%things(i) = stuff_type( i ) ! Gives 6 scalar calls
+ 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()
+! One array call and 1 scalar call after leaving scope => 1 + 9 total; NAGFOR and IFORT agree
+ if (final_calls .ne. 109) stop 1
+ call in_type()
+! 21 calls to scalar finalizer and 4 to the vector version; IFORT agrees
+! NAGFOR also produces 21 scalar calls but 5 vector calls.
+ if (final_calls .ne. 421) print *, final_calls
+contains
+
+ subroutine here()
+ implicit none
+ type(stuff_type) :: thing
+ type(stuff_type) :: bits(3)
+ integer :: i
+ integer :: tally
+ thing = stuff_type(4) ! Two scalar final calls; INTENT(OUT) and initialiser
+ do i = 1, 3
+ bits(i) = stuff_type(i) ! ditto times 3
+ end do
+ tally = thing%get_junk()
+ do i = 1, 3
+ tally = tally + bits(i)%get_junk()
+ end do
+ if (tally .ne. 10) stop 3 ! 8 scalar final calls by here
+ end subroutine here
+
+ subroutine in_type()
+ implicit none
+ type(test_type) :: thing
+ thing = test_type() ! 8 scalar in test_type + 1 vector and 1 scalar to finalize function result and
+ ! 1 vectors and 2 scalars from the expansion of the defined assignment.
+ if (thing%get_value() .ne. 10) stop 4
+ end subroutine in_type
+end program test
diff --git a/gcc/testsuite/gfortran.dg/finalize_42.f90 b/gcc/testsuite/gfortran.dg/finalize_42.f90
new file mode 100644
index 00000000000..09178af85b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_42.f90
@@ -0,0 +1,53 @@
+! { 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 <jhogg41@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
+ end subroutine mytype_assign
+
+ subroutine mytype_final(this)
+ type(mytype) :: this
+ next = next + 1
+ if (this%idx /= 0) stop 1 ! finalize 'create_mtype' result
+ end subroutine mytype_final
+
+ type(mytype) function create_mytype()
+ create_mytype%idx = next
+ next = next + 1
+ end function create_mytype
+
+end module mymod
+
+program test
+ use mymod
+ implicit none
+
+ type(mytype) :: x
+
+ x = create_mytype()
+ if (x%idx /= 1) stop 2 ! Defined assignment failed
+ if (next /= 3) stop 3 ! Used to give 2 because finalization did not occur
+end program test
diff --git a/gcc/testsuite/gfortran.dg/finalize_43.f90 b/gcc/testsuite/gfortran.dg/finalize_43.f90
new file mode 100644
index 00000000000..b55ec8515c1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_43.f90
@@ -0,0 +1,41 @@
+! { 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 <andrew@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
diff --git a/gcc/testsuite/gfortran.dg/finalize_44.f90 b/gcc/testsuite/gfortran.dg/finalize_44.f90
new file mode 100644
index 00000000000..a7683ae792e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_44.f90
@@ -0,0 +1,123 @@
+! { 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.carlson@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
diff --git a/gcc/testsuite/gfortran.dg/finalize_45.f90 b/gcc/testsuite/gfortran.dg/finalize_45.f90
new file mode 100644
index 00000000000..0819cf6e168
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_45.f90
@@ -0,0 +1,132 @@
+! { dg-do run }
+!
+! Test the fix for PR84472 in which the finalizations around the
+! assignment in 'mymain' were not happening.
+!
+! Contributed by Vipul Parekh <fortranfan@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
+ procedure, public :: assign_t
+ generic, public :: ASSIGNMENT(=) => assign_t
+ end type
+
+ interface t
+ module procedure :: construct_t
+ end interface
+
+ public :: t, assign_t
+
+contains
+
+ impure elemental subroutine assign_t (to, from)
+ class(t), intent(out) :: to
+ class(t), intent(in) :: from
+ if (associated (from%m_s)) then
+ allocate(to%m_s, source = from%m_s)
+ else
+ allocate(to%m_s, source = "new")
+ endif
+ end subroutine assign_t
+
+ 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
+ print *, this%m_s
+ 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
+! See comment below.
+ 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()
+
+! NAGFOR has assoc_counts =2, which is probably correct. If nullification
+! of the pointer component is not done in gfortran, function finalization
+! results in a double free. TODO fix this.
+ if (final_counts /= 2) stop 3
+ if (assoc_counts /= 2) stop 4
+ end
+end
+
diff --git a/gcc/testsuite/gfortran.dg/finalize_46.f90 b/gcc/testsuite/gfortran.dg/finalize_46.f90
new file mode 100644
index 00000000000..cd1465e6abf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_46.f90
@@ -0,0 +1,92 @@
+! { dg-do run }
+!
+! Test the fix for pr88735.
+!
+! Contributed by Martin Stein <mscfd@gmx.net>
+!
+module mod
+ implicit none
+ type, public :: t
+ integer, pointer :: i => NULL ()
+ character :: myname = 'z'
+ character :: alloc = 'n'
+ contains
+ procedure, public :: set
+ generic, public :: assignment(=) => set
+ final :: finalise
+ end type t
+ integer, public :: assoc_in_final = 0
+ integer, public :: calls_to_final = 0
+ character, public :: myname1, myname2
+
+contains
+
+ subroutine set(self, x)
+ class(t), intent(out) :: self
+ class(t), intent(in) :: x
+ if (associated(self%i)) then
+ stop 1 ! Default init for INTENT(OUT)
+ endif
+ if (associated(x%i)) then
+ myname2 = self%myname
+ self%i => x%i
+ self%i = self%i + 1
+ end if
+end subroutine set
+
+ subroutine finalise(self)
+ type(t), intent(inout) :: self
+ calls_to_final = calls_to_final + 1
+ myname1 = self%myname
+ if (associated(self%i)) then
+ assoc_in_final = assoc_in_final + 1
+ if (self%alloc .eq. 'y') deallocate (self%i)
+ end if
+ end subroutine finalise
+
+end module mod
+
+program finalise_assign
+ use mod
+ implicit none
+ type :: s
+ integer :: i = 0
+ type(t) :: x
+ end type s
+ type(s) :: a, b
+ type(t) :: c
+ a%x%myname = 'a'
+ b%x%myname = 'b'
+ c%myname = 'c'
+ allocate (a%x%i)
+ a%x%i = 123
+ a%x%alloc = 'y'
+
+ b = a
+ if (assoc_in_final /= 0) stop 2 ! b%x%i not associated before finalization
+ if (calls_to_final /= 2) stop 3 ! One finalization call
+ if (myname1 .ne. 'b') stop 4 ! Finalization before intent out become undefined
+ if (myname2 .ne. 'z') stop 5 ! Intent out now default initialized
+ if (.not.associated (b%x%i, a%x%i)) stop 6
+
+ allocate (c%i, source = 789)
+ c%alloc = 'y'
+ c = a%x
+ if (assoc_in_final /= 1) stop 6 ! c%i is allocated prior to the assignment
+ if (calls_to_final /= 3) stop 7 ! One finalization call for the assignment
+ if (myname1 .ne. 'c') stop 8 ! Finalization before intent out become undefined
+ if (myname2 .ne. 'z') stop 9 ! Intent out now default initialized
+
+ b = a
+ if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
+ if (calls_to_final /= 5) stop 11 ! One finalization call for the assignment
+ if (myname1 .ne. 'z') stop 12 ! b%x%myname was default initialized in earlier assignment
+ if (myname2 .ne. 'z') stop 13 ! Intent out now default initialized
+ if (b%x%i .ne. 126) stop 14 ! Three assignments with self%x%i pointing to same target
+ deallocate (a%x%i)
+ if (.not.associated (b%x%i, c%i)) then
+ stop 15 ! ditto
+ b%x%i =>NULL () ! Although not needed here, clean up
+ c%i => NULL ()
+ endif
+end program finalise_assign
diff --git a/gcc/testsuite/gfortran.dg/finalize_47.f90 b/gcc/testsuite/gfortran.dg/finalize_47.f90
new file mode 100644
index 00000000000..f1ca8bd4640
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_47.f90
@@ -0,0 +1,105 @@
+! { dg-do run }
+!
+! Check that PR91316 is fixed. Note removal of recursive I/O.
+!
+! Contributed by Jose Rui Faustino de Sousa <jrfsousa@gcc.gnu.org>
+!
+! NAGFOR complains correctly about the finalization of an INTENT(OUT) dummy
+! with an impure finalization subroutine, within a pure procedure.
+! It also complains about the finalization of final_set, which does not seem
+! to be correct (see finalize_50.f90).
+! Both procedures have been made impure so that this testcase runs with both
+! compilers.
+!
+module final_m
+ implicit none
+ private
+ public :: &
+ assignment(=)
+
+ public :: &
+ final_t
+
+ 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(=)
+
+ integer, public :: final_ctr = 0
+ integer, public :: final_res = 0
+
+contains
+
+ impure elemental subroutine final_init(this, n)
+ type(final_t), intent(out) :: this
+ integer, intent(in) :: n
+ this%n = n
+ end subroutine final_init
+
+ impure elemental function final_set(n) result(this)
+ integer, intent(in) :: n
+ type(final_t) :: this
+ this%n = n
+ end function final_set
+
+ elemental function final_get(this) result(n)
+ type(final_t), intent(in) :: this
+ integer :: n
+ n = this%n
+ end function final_get
+
+ subroutine final_end(this)
+ type(final_t), intent(inout) :: this
+! print *, "DESTROY: ", this%n !< generates illegal, recursive io in 'final_s4'
+ final_res = this%n
+ final_ctr = final_ctr + 1
+ this%n = -1
+ end subroutine final_end
+end module final_m
+
+program final_p
+ use final_m
+ implicit none
+ type(final_t) :: f0
+! call final_init(f0, 0)
+ call final_s1()
+ call final_s2()
+ call final_s3()
+ call final_s4()
+ call final_end(f0)
+contains
+ subroutine final_s1()
+ type(final_t) :: f
+ call final_init(f, 1)
+ print *, "f1: ", final_get(f)
+ if ((final_ctr .ne. 1) .or. (final_res .ne. -1)) stop 1
+ end subroutine final_s1
+ subroutine final_s2()
+ type(final_t) :: f
+ f = 2
+ print *, "f2: ", final_get(f)
+ if ((final_ctr .ne. 3) .or. (final_res .ne. -1)) stop 1
+ end subroutine final_s2
+ subroutine final_s3()
+ type(final_t) :: f
+ f = final_set(3)
+ print *, "f3: ", final_get(f)
+ if ((final_ctr .ne. 6) .or. (final_res .ne. 3)) stop 1
+ end subroutine final_s3
+ subroutine final_s4()
+ print *, "f4: ", final_get(final_set(4))
+ if ((final_ctr .ne. 8) .or. (final_res .ne. 4)) stop 1
+ end subroutine final_s4
+end program final_p
diff --git a/gcc/testsuite/gfortran.dg/finalize_48.f90 b/gcc/testsuite/gfortran.dg/finalize_48.f90
new file mode 100644
index 00000000000..98b5006e1d3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_48.f90
@@ -0,0 +1,59 @@
+! { dg-do run }
+!
+! Check that pr106576 is fixed. The temporary from the function result
+! was not being finalized.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+module y
+ implicit none
+ type foo
+ integer :: n
+ contains
+ final :: cleanup
+ end type foo
+ interface assignment (=)
+ module procedure assign
+ end interface assignment (=)
+ character(16) :: buffer(4)
+ integer :: buffer_count = 1
+contains
+
+ subroutine assign (rop, op)
+ type(foo), intent(inout) :: rop
+ type(foo), intent(in) :: op
+ rop%n = op%n + 1
+ write (buffer(buffer_count), '(A12,I4)') "assign", rop%n
+ buffer_count = buffer_count + 1
+ end subroutine assign
+
+ function to_foo(n) result(res)
+ integer, intent(in) :: n
+ type (foo) :: res
+ res%n = n
+ write (buffer(buffer_count), '(A12,I4)') "to_foo", res%n
+ buffer_count = buffer_count + 1
+ end function to_foo
+
+ subroutine cleanup (self)
+ type (foo), intent(inout) :: self
+ write (buffer(buffer_count), '(A12,I4)') "cleanup", self%n
+ buffer_count = buffer_count + 1
+ end subroutine cleanup
+end module y
+
+program memain
+ use y
+ implicit none
+ character(16) :: check(4) = [" to_foo 3", &
+ " assign 4", &
+ " cleanup 3", &
+ " cleanup 4"]
+ call chk
+ if (any (buffer .ne. check)) stop 1
+contains
+ subroutine chk
+ type (foo) :: a
+ a = to_foo(3)
+ end subroutine chk
+end program memain
diff --git a/gcc/testsuite/gfortran.dg/finalize_49.f90 b/gcc/testsuite/gfortran.dg/finalize_49.f90
new file mode 100644
index 00000000000..49b09f78474
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_49.f90
@@ -0,0 +1,67 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Part of PR106576.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module finalizable_m
+ !! This module supports the main program at the bottom of this file, which
+ !! tests compiler conformance with clause 7.5.6.3, paragraph 6 in the Fortran
+ !! Interpretation Document (https://j3-fortran.org/doc/year/18/18-007r1.pdf):
+ !! "If a specification expression in a scoping unit references
+ !! a function, the result is finalized before execution of the executable
+ !! constructs in the scoping unit."
+ implicit none
+
+ private
+ public :: finalizable_t, component
+
+ type finalizable_t
+ private
+ integer, allocatable :: component_
+ contains
+ final :: finalize
+ end Type
+
+ interface finalizable_t
+ module procedure construct
+ end interface
+
+contains
+
+ pure function construct(component) result(finalizable)
+ integer, intent(in) :: component
+ type(finalizable_t) finalizable
+ allocate(finalizable%component_, source = component)
+ end function
+
+ pure function component(self) result(self_component)
+ type(finalizable_t), intent(in) :: self
+ integer self_component
+ self_component = self%component_
+ end function
+
+ pure subroutine finalize(self)
+ type(finalizable_t), intent(inout) :: self
+ if (allocated(self%component_)) deallocate(self%component_)
+ end subroutine
+
+end module
+
+program specification_expression_finalization
+ use finalizable_m, only : finalizable_t, component
+ implicit none
+
+ call finalize_specification_expression_result
+
+contains
+
+ subroutine finalize_specification_expression_result
+ real tmp(component(finalizable_t(component=1))) !! Finalizes the finalizable_t function result
+ real eliminate_unused_variable_warning
+ tmp = eliminate_unused_variable_warning
+ end subroutine
+
+end program
+! { dg-final { scan-tree-dump-times "_final != 0B" 1 "original" } }
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/finalize_50.f90 b/gcc/testsuite/gfortran.dg/finalize_50.f90
new file mode 100644
index 00000000000..1825e6bbcac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_50.f90
@@ -0,0 +1,254 @@
+! { dg-do run }
+!
+! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Most of PR106576:
+! The finalization of function results within specification expressions is tested
+! in finalize_49.f90.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module test_result_m
+ !! Define tests for each scenario in which the Fortran 2018
+ !! standard mandates type finalization.
+ implicit none
+
+ private
+ public :: test_result_t, get_test_results
+
+ type test_result_t
+ character(len=132) description
+ logical outcome
+ end type
+
+ type object_t
+ integer dummy
+ contains
+ final :: count_finalizations
+ end type
+
+ type wrapper_t
+ private
+ type(object_t), allocatable :: object
+ end type
+
+ integer :: finalizations = 0
+ integer, parameter :: avoid_unused_variable_warning = 1
+
+contains
+
+ function get_test_results() result(test_results)
+ type(test_result_t), allocatable :: test_results(:)
+
+ test_results = [ &
+ test_result_t("finalizes a non-allocatable object on the LHS of an intrinsic assignment", lhs_object()) &
+ ,test_result_t("finalizes an allocated allocatable LHS of an intrinsic assignment", allocated_allocatable_lhs()) &
+ ,test_result_t("finalizes a target when the associated pointer is deallocated", target_deallocation()) &
+ ,test_result_t("finalizes an object upon explicit deallocation", finalize_on_deallocate()) &
+ ,test_result_t("finalizes a non-pointer non-allocatable object at the END statement", finalize_on_end()) &
+ ,test_result_t("finalizes a non-pointer non-allocatable object at the end of a block construct", block_end()) &
+ ,test_result_t("finalizes a function reference on the RHS of an intrinsic assignment", rhs_function_reference()) &
+ ,test_result_t("finalizes an intent(out) derived type dummy argument", intent_out()) &
+ ,test_result_t("finalizes an allocatable component object", allocatable_component()) &
+ ]
+ end function
+
+ function construct_object() result(object)
+ !! Constructor for object_t
+ type(object_t) object
+ object % dummy = avoid_unused_variable_warning
+ end function
+
+ subroutine count_finalizations(self)
+ !! Destructor for object_t
+ type(object_t), intent(inout) :: self
+ finalizations = finalizations + 1
+ self % dummy = avoid_unused_variable_warning
+ end subroutine
+
+ function lhs_object() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
+ !! "not an unallocated allocatable variable"
+ type(object_t) lhs, rhs
+ logical outcome
+ integer initial_tally
+
+ rhs%dummy = avoid_unused_variable_warning
+ initial_tally = finalizations
+ lhs = rhs ! finalizes lhs
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ end function
+
+ function allocated_allocatable_lhs() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
+ !! "allocated allocatable variable"
+ type(object_t), allocatable :: lhs
+ type(object_t) rhs
+ logical outcome
+ integer initial_tally
+
+ rhs%dummy = avoid_unused_variable_warning
+ initial_tally = finalizations
+ allocate(lhs)
+ lhs = rhs ! finalizes lhs
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ end function
+
+ function target_deallocation() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2 behavior:
+ !! "pointer is deallocated"
+ type(object_t), pointer :: object_ptr => null()
+ logical outcome
+ integer initial_tally
+
+ allocate(object_ptr, source=object_t(dummy=0))
+ initial_tally = finalizations
+ deallocate(object_ptr) ! finalizes object
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ end function
+
+ function allocatable_component() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, para. 2 ("allocatable entity is deallocated")
+ !! + 9.7.3.2, para. 6 ("INTENT(OUT) allocatable dummy argument is deallocated")
+ type(wrapper_t), allocatable :: wrapper
+ logical outcome
+ integer initial_tally
+
+ initial_tally = finalizations
+
+ allocate(wrapper)
+ allocate(wrapper%object)
+ call finalize_intent_out_component(wrapper)
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+
+ contains
+
+ subroutine finalize_intent_out_component(output)
+ type(wrapper_t), intent(out) :: output ! finalizes object component
+ allocate(output%object)
+ output%object%dummy = avoid_unused_variable_warning
+ end subroutine
+
+ end function
+
+ function finalize_on_deallocate() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2:
+ !! "allocatable entity is deallocated"
+ type(object_t), allocatable :: object
+ logical outcome
+ integer initial_tally
+
+ initial_tally = finalizations
+ allocate(object)
+ object%dummy = 1
+ deallocate(object) ! finalizes object
+ associate(final_tally => finalizations - initial_tally)
+ outcome = final_tally==1
+ end associate
+ end function
+
+ function finalize_on_end() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 3:
+ !! "before return or END statement"
+ logical outcome
+ integer initial_tally
+
+ initial_tally = finalizations
+ call finalize_on_end_subroutine() ! Finalizes local_obj
+ associate(final_tally => finalizations - initial_tally)
+ outcome = final_tally==1
+ end associate
+
+ contains
+
+ subroutine finalize_on_end_subroutine()
+ type(object_t) local_obj
+ local_obj % dummy = avoid_unused_variable_warning
+ end subroutine
+
+ end function
+
+ function block_end() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 4:
+ !! "termination of the BLOCK construct"
+ logical outcome
+ integer initial_tally
+
+ initial_tally = finalizations
+ block
+ type(object_t) object
+ object % dummy = avoid_unused_variable_warning
+ end block ! Finalizes object
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ end function
+
+ function rhs_function_reference() result(outcome)
+ !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 5 behavior:
+ !! "nonpointer function result"
+ type(object_t), allocatable :: object
+ logical outcome
+ integer initial_tally
+
+ initial_tally = finalizations
+ object = construct_object() ! finalizes object_t result
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ end function
+
+ function intent_out() result(outcome)
+ !! Test conformance with Fortran 2018 standard clause 7.5.6.3, paragraph 7:
+ !! "nonpointer, nonallocatable, INTENT (OUT) dummy argument"
+ logical outcome
+ type(object_t) object
+ integer initial_tally
+
+ initial_tally = finalizations
+ call finalize_intent_out_arg(object)
+ associate(finalization_tally => finalizations - initial_tally)
+ outcome = finalization_tally==1
+ end associate
+ contains
+ subroutine finalize_intent_out_arg(output)
+ type(object_t), intent(out) :: output ! finalizes output
+ output%dummy = avoid_unused_variable_warning
+ end subroutine
+ end function
+
+end module test_result_m
+
+program main
+ !! Test each scenario in which the Fortran 2018 standard
+ !! requires type finalization.
+ use test_result_m, only : test_result_t, get_test_results
+ implicit none
+ type(test_result_t), allocatable :: test_results(:)
+ integer i
+
+ test_results = get_test_results()
+
+ do i=1,size(test_results)
+ print *, report(test_results(i)%outcome), test_results(i)%description
+ end do
+
+ if (any(.not.test_results%outcome)) stop "Failing tests"
+
+ if (allocated (test_results)) deallocate (test_results)
+
+contains
+
+ pure function report(outcome)
+ logical, intent(in) :: outcome
+ character(len=:), allocatable :: report
+ report = merge("Pass: ", "Fail: ", outcome)
+ end function
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/finalize_51.f90 b/gcc/testsuite/gfortran.dg/finalize_51.f90
new file mode 100644
index 00000000000..734463a78a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_51.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+!
+! Test assumed rank finalizers
+!
+module finalizable_m
+! F2018: 7.5.6.2 para 1: "Otherwise, if there is an elemental final
+! subroutine whose dummy argument has the same kind type parameters
+! as the entity being finalized, or a final subroutine whose dummy
+! argument is assumed-rank with the same kind type parameters as the
+! entity being finalized, it is called with the entity as an actual
+! argument."
+ implicit none
+
+ type finalizable_t
+ integer :: component_
+ contains
+ final :: finalize
+ end Type
+
+ interface finalizable_type
+ module procedure construct0, construct1
+ end interface
+
+ integer :: final_ctr = 0
+
+contains
+
+ pure function construct0(component) result(finalizable)
+ integer, intent(in) :: component
+ type(finalizable_t) finalizable
+ finalizable%component_ = component
+ end function
+
+ impure function construct1(component) result(finalizable)
+ integer, intent(in), dimension(:) :: component
+ type(finalizable_t), dimension(:), allocatable :: finalizable
+ integer :: sz
+ sz = size(component)
+ allocate (finalizable (sz))
+ finalizable%component_ = component
+ end function
+
+ subroutine finalize(self)
+ type(finalizable_t), intent(inout), dimension (..) :: self
+ select rank (self)
+ rank (0)
+ print *, "rank 0 value = ", self%component_
+ rank (1)
+ print *, "rank 1 value = ", self%component_
+ rank default
+ print *, "rank default"
+ end select
+ final_ctr = final_ctr + 1
+ end subroutine
+
+end module
+
+program specification_expression_finalization
+ use finalizable_m
+ implicit none
+
+ type(finalizable_t) :: a = finalizable_t (1)
+ type(finalizable_t) :: b(2) = [finalizable_t (2), finalizable_t (3)]
+
+ a = finalizable_type (42)
+ if (final_ctr .ne. 2) stop 1
+ b = finalizable_type ([42, 43])
+ print *, b%component_
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
index 46b9a9f6518..7b27ddb2e3b 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
@@ -15,5 +15,5 @@ contains
end
end
-! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__STAR;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._data = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._vptr = .* &__vtab__STAR;" 1 "original" } }
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-03-18 7:56 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-03-18 7:56 [gcc r13-6747] Fortran: Fix bugs and missing features in finalization [PR37336] Paul Thomas
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).