* [Patch, fortran] PR37336 finalization
@ 2023-03-07 13:45 Paul Richard Thomas
2023-03-07 14:58 ` Thomas Koenig
2023-06-02 13:42 ` Paul Richard Thomas
0 siblings, 2 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2023-03-07 13:45 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1.1: Type: text/plain, Size: 8155 bytes --]
Hi All,
I thought that I was ready for submission of this patch early in December,
last year. That was before I tried to tackle the bugs triggered by the
different versions of smart pointer or resource management. I would like to
thank Andrew Benson, Salvatore Filippone, Jerry Delisle and Damian Rouson
for all their help and encouragement in trying to get this right. The
result is compliant with the F2018 standard (I think...!) and is more or
less consistent with the other brands to which I have access. Thanks are
also due to Malcolm Cohen for a very useful exchange of emails.
All the paragraphs of F2018 7.5.6.3 "When finalization occurs" have been
addressed. The difficulties of the last couple of months have all been
related to finalization during intrinsic derived type assignment, where
there are components with type bound defined assignments. These are, for
the main part, dealt with by the chunks in
resolve.cc(generate_component_assignments) and should be consistent with
F2018: 10.2.1.3 "Interpretation of intrinsic assignments" paragraph 13. It
is entirely possible that there are remaining corner cases.
As a result of all this, the patch is now rather large at 2187 lines for
the diff, even without the testcases. It is my intention to write the rest
of the testcases and to break up the patch so that the various new features
are introduced in separate patches. I can hurry this along to get the patch
into 13-branch or I can wait until 14-branch opens.
Best regards
Paul
Fortran: Fix bugs and implement missing features in finalization
[PR37336]
2023-03-07 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/103854
* class.cc (has_finalizer_component): Do not return true for
procedure pointer components.
PR fortran/96122
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.
PR fortran/37336
* class.cc (finalizer_insert_packed_call): Remove the redundant
argument in the call to the final subroutine.
(generate_finalization_wrapper): Add support for assumed rank
finalizers.
(gfc_may_be_finalized): New helper function.
* 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.
(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.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 79591 bytes --]
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ae653e74437..484f525773e 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
gfc_component *c;
for (c = derived->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+ if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+ && c->attr.flavor != FL_PROCEDURE)
{
if (c->ts.u.derived->f2k_derived
&& c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
{
/* Call FINAL_WRAPPER (comp); */
gfc_code *final_wrap;
- gfc_symbol *vtab;
+ gfc_symbol *vtab, *byte_stride;
+ gfc_expr *scalar, *size_expr, *fini_coarray_expr;
gfc_component *c;
vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
break;
gcc_assert (c);
+
+ /* Set scalar argument for storage_size. */
+ gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts = e->ts;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
+ gfc_commit_symbol (byte_stride);
+ scalar = gfc_lval_expr_from_sym (byte_stride);
+
final_wrap = gfc_get_code (EXEC_CALL);
final_wrap->symtree = c->initializer->symtree;
final_wrap->resolved_sym = c->initializer->symtree->n.sym;
final_wrap->ext.actual = gfc_get_actual_arglist ();
final_wrap->ext.actual->expr = e;
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ scalar,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* Which provides the argument 'byte_stride'..... */
+ final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->expr = size_expr;
+
+ /* ...and last of all the 'fini_coarray' argument. */
+ fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+ final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
if (*code)
{
(*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->next->resolved_sym = fini->proc_tree->n.sym;
block->next->ext.actual = gfc_get_actual_arglist ();
block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
- block->next->ext.actual->next = gfc_get_actual_arglist ();
- block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
/* ELSE. */
@@ -2047,13 +2089,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)
@@ -2152,6 +2213,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. */
@@ -2682,6 +2745,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/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 2780c82c798..f1649f2fc01 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:
@@ -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)
{
@@ -11509,8 +11601,11 @@ 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_may_be_finalized ((*code)->expr1->ts);
gfc_get_errors (NULL, &error_count);
@@ -11531,19 +11626,34 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
return;
}
+ /* Build a block so that function result temporaries are finalized
+ locally rather than on exiting the 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++;
/* 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);
@@ -11555,6 +11665,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
to the final result already does this. */
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,26 +11676,42 @@ 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.pointer && !gfc_may_be_finalized (comp1->ts))
|| comp1->attr.proc_pointer_comp
|| comp1->attr.class_pointer
|| comp1->attr.proc_pointer)
continue;
+ /* Do the explicit pointer assignment to finalize the target. */
+ if (comp1->attr.pointer)
+ {
+ this_code = build_assignment (EXEC_POINTER_ASSIGN,
+ (*code)->expr1, (*code)->expr2,
+ comp1, comp2, (*code)->loc);
+ add_code_to_chain (&this_code, &head, &tail);
+ continue;
+ }
+
/* Make an assignment for this component. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
comp1, comp2, (*code)->loc);
+ if (comp1->attr.allocatable
+ && comp1->ts.type != BT_DERIVED)
+ {
+ add_code_to_chain (&this_code, &head, &tail);
+ continue;
+ }
+
/* Convert the assignment if there is a defined assignment for
this type. Otherwise, using the call from gfc_resolve_code,
recurse into its components. */
@@ -11611,8 +11739,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 +11754,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);
@@ -11688,15 +11825,27 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
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 +11858,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 +11880,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 +11904,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
if (head != tail)
free (head);
*code = tail;
-
- component_assignment_level--;
}
@@ -12164,6 +12323,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 +13908,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 +14017,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 +14750,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 +14763,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 +15440,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 +16536,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 045c8b00b90..a13787b3158 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1910,6 +1910,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;
@@ -7073,6 +7074,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
@@ -7439,6 +7441,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);
@@ -7737,9 +7740,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);
@@ -7799,6 +7813,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)
{
@@ -7891,8 +7908,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)
{
@@ -7914,66 +7929,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);
}
@@ -9485,10 +9449,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:
@@ -10489,7 +10472,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);
@@ -10497,6 +10481,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,
@@ -10526,8 +10511,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);
@@ -10537,6 +10523,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))
{
@@ -10867,6 +10854,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;
@@ -10885,12 +10877,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);
@@ -10900,6 +10924,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
@@ -10930,7 +10966,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);
@@ -11453,6 +11501,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. */
@@ -11478,8 +11537,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);
@@ -11500,6 +11560,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,
@@ -11508,7 +11572,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);
}
@@ -11581,6 +11645,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
@@ -11604,6 +11669,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;
@@ -11635,15 +11701,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
@@ -11917,6 +11997,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
@@ -11962,6 +12044,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,
@@ -11971,12 +12074,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..1268f04e576 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -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/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" } }
[-- Attachment #3: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 6683 bytes --]
! { 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
[-- Attachment #4: finalize_40.f90 --]
[-- Type: text/x-fortran, Size: 1063 bytes --]
! { 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
[-- Attachment #5: finalize_39.f90 --]
[-- Type: text/x-fortran, Size: 1998 bytes --]
! { 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
[-- Attachment #6: finalize_41.f90 --]
[-- Type: text/x-fortran, Size: 3909 bytes --]
! { 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
[-- Attachment #7: finalize_38a.f90 --]
[-- Type: text/x-fortran, Size: 7670 bytes --]
! { 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
[-- Attachment #8: finalize_42.f90 --]
[-- Type: text/x-fortran, Size: 1242 bytes --]
! { 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
[-- Attachment #9: finalize_43.f90 --]
[-- Type: text/x-fortran, Size: 1117 bytes --]
! { 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
[-- Attachment #10: finalize_45.f90 --]
[-- Type: text/x-fortran, Size: 2800 bytes --]
! { 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
[-- Attachment #11: finalize_44.f90 --]
[-- Type: text/x-fortran, Size: 2916 bytes --]
! { 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
[-- Attachment #12: finalize_46.f90 --]
[-- Type: text/x-fortran, Size: 2801 bytes --]
! { 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 ! Two finalization calls
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 ! Two finalization calls 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
[-- Attachment #13: finalize_47.f90 --]
[-- Type: text/x-fortran, Size: 2632 bytes --]
! { 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
[-- Attachment #14: finalize_48.f90 --]
[-- Type: text/x-fortran, Size: 1500 bytes --]
! { 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
[-- Attachment #15: finalize_49.f90 --]
[-- Type: text/x-fortran, Size: 1977 bytes --]
! { 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" } }
[-- Attachment #16: finalize_50.f90 --]
[-- Type: text/x-fortran, Size: 8256 bytes --]
! { 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
[-- Attachment #17: finalize_51.f90 --]
[-- Type: text/x-fortran, Size: 1855 bytes --]
! { 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
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-03-07 13:45 [Patch, fortran] PR37336 finalization Paul Richard Thomas
@ 2023-03-07 14:58 ` Thomas Koenig
2023-03-07 17:15 ` Steve Kargl
2023-06-02 13:42 ` Paul Richard Thomas
1 sibling, 1 reply; 10+ messages in thread
From: Thomas Koenig @ 2023-03-07 14:58 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Paul,
first of all, thank you very much indeed for the hard work you put into
this! This is a great step for gfortran.
> I can hurry this along to get the patch
> into 13-branch or I can wait until 14-branch opens.
Personally, I think that this fixes so many bugs, and makes
the compiler so much better, that I would prefer having it
in gcc-13. Finalization was only of very limited use before,
and the risk of meaningful regressions (short of a build
failure) is therefore very low.
Again, thanks a lot!
Best regards
Thomas
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-03-07 14:58 ` Thomas Koenig
@ 2023-03-07 17:15 ` Steve Kargl
0 siblings, 0 replies; 10+ messages in thread
From: Steve Kargl @ 2023-03-07 17:15 UTC (permalink / raw)
To: Thomas Koenig via Fortran; +Cc: Paul Richard Thomas, gcc-patches
On Tue, Mar 07, 2023 at 03:58:32PM +0100, Thomas Koenig via Fortran wrote:
> Paul,
>
> first of all, thank you very much indeed for the hard work you put into
> this! This is a great step for gfortran.
Ditto**2
> > I can hurry this along to get the patch
> > into 13-branch or I can wait until 14-branch opens.
>
> Personally, I think that this fixes so many bugs, and makes
> the compiler so much better, that I would prefer having it
> in gcc-13. Finalization was only of very limited use before,
> and the risk of meaningful regressions (short of a build
> failure) is therefore very low.
>
I agree with Thomas. The main branch is in stage 4,
which is regression and documentation fixing mode. I
would think the number of bugs fixed by your patch
can be argued as fixing regressions. I can set aside
some time on Saturday to help with a review (if required).
--
Steve
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-03-07 13:45 [Patch, fortran] PR37336 finalization Paul Richard Thomas
2023-03-07 14:58 ` Thomas Koenig
@ 2023-06-02 13:42 ` Paul Richard Thomas
2023-06-03 5:50 ` Thomas Koenig
1 sibling, 1 reply; 10+ messages in thread
From: Paul Richard Thomas @ 2023-06-02 13:42 UTC (permalink / raw)
To: fortran, gcc-patches
Hi All,
I propose to backport
r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
soon. Before that, I propose to remove the F2003/2008 finalization of
structure and array constructors in 13- and 14-branches. I can see why
it was removed from the standard in a correction to F2008 and think
that it is likely to cause endless confusion and maintenance
complications. However, finalization of function results within
constructors will be retained.
If there are any objections, please let me know.
Paul
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-02 13:42 ` Paul Richard Thomas
@ 2023-06-03 5:50 ` Thomas Koenig
2023-06-03 7:32 ` Steve Kargl
2023-06-03 13:16 ` Paul Richard Thomas
0 siblings, 2 replies; 10+ messages in thread
From: Thomas Koenig @ 2023-06-03 5:50 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Hi Paul,
> I propose to backport
> r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
> soon.
Is this something that we usually do?
While finalization was basically broken before, some people still used
working subsets (or subsets that were broken, and they adapted or
wrote their code accordingly).
What is the general opinion on that? I'm undecided.
> Before that, I propose to remove the F2003/2008 finalization of
> structure and array constructors in 13- and 14-branches. I can see why
> it was removed from the standard in a correction to F2008 and think
> that it is likely to cause endless confusion and maintenance
> complications. However, finalization of function results within
> constructors will be retained.
That, I agree with. Should it be noted somewhere as an intentional
deviation from the standard?
Best regards
Thomas
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-03 5:50 ` Thomas Koenig
@ 2023-06-03 7:32 ` Steve Kargl
2023-06-03 13:16 ` Paul Richard Thomas
1 sibling, 0 replies; 10+ messages in thread
From: Steve Kargl @ 2023-06-03 7:32 UTC (permalink / raw)
To: Thomas Koenig via Fortran; +Cc: Paul Richard Thomas, gcc-patches
On Sat, Jun 03, 2023 at 07:50:19AM +0200, Thomas Koenig via Fortran wrote:
> Hi Paul,
>
> > I propose to backport
> > r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
> > soon.
>
> Is this something that we usually do?
>
> While finalization was basically broken before, some people still used
> working subsets (or subsets that were broken, and they adapted or
> wrote their code accordingly).
>
> What is the general opinion on that? I'm undecided.
>
I think a backport that fixes a bug that is a violation
of Fortran standard is always okay. A backport of anything
else is up to the discretion of the contributor. If pault
or you or harald or ... want to backport a patch, after all
these years, I think we should trust their judgement.
--
Steve
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-03 5:50 ` Thomas Koenig
2023-06-03 7:32 ` Steve Kargl
@ 2023-06-03 13:16 ` Paul Richard Thomas
2023-06-03 19:10 ` Harald Anlauf
2023-06-03 19:22 ` Thomas Koenig
1 sibling, 2 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2023-06-03 13:16 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches
Hi Thomas,
I want to get something approaching correct finalization to the
distros, which implies 12-branch at present. Hopefully I can do the
same with associate in a month or two's time.
I am dithering about changing the F2003/08 part of finalization since
the default is 2018 compliance. That said, it does need a change since
the suppression of constructor finalization is also suppressing
finalization of function results within the compilers. I'll do that
first, perhaps?
Cheers
Paul
On Sat, 3 Jun 2023 at 06:50, Thomas Koenig <tkoenig@netcologne.de> wrote:
>
> Hi Paul,
>
> > I propose to backport
> > r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
> > soon.
>
> Is this something that we usually do?
>
> While finalization was basically broken before, some people still used
> working subsets (or subsets that were broken, and they adapted or
> wrote their code accordingly).
>
> What is the general opinion on that? I'm undecided.
>
> > Before that, I propose to remove the F2003/2008 finalization of
> > structure and array constructors in 13- and 14-branches. I can see why
> > it was removed from the standard in a correction to F2008 and think
> > that it is likely to cause endless confusion and maintenance
> > complications. However, finalization of function results within
> > constructors will be retained.
>
> That, I agree with. Should it be noted somewhere as an intentional
> deviation from the standard?
>
> Best regards
>
> Thomas
>
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-03 13:16 ` Paul Richard Thomas
@ 2023-06-03 19:10 ` Harald Anlauf
2023-06-03 19:10 ` Harald Anlauf
2023-06-03 19:22 ` Thomas Koenig
1 sibling, 1 reply; 10+ messages in thread
From: Harald Anlauf @ 2023-06-03 19:10 UTC (permalink / raw)
To: Paul Richard Thomas, Thomas Koenig; +Cc: fortran, gcc-patches
Hi Paul, all,
On 6/3/23 15:16, Paul Richard Thomas via Gcc-patches wrote:
> Hi Thomas,
>
> I want to get something approaching correct finalization to the
> distros, which implies 12-branch at present. Hopefully I can do the
> same with associate in a month or two's time.
IMHO it is not only distros, but also installations at (scientific)
computing centers with a larger user base and a large software stack.
Migrating to a different major version of gcc/gfortran is not a trivial
task for them.
I'd fully support the idea of backporting the finalization fixes, as
IIUC this on the one hand touches a rather isolated part, and on the
other hand already got quite some testing. It is also already in the
13-branch (or only mostly?). Given that 12.3 was released recently
and 12.4 is far away, there'd be sufficient time to fix any fallout.
Regarding the associate fixes, we could get as much of those into 13.2,
which we'd normally expect in just a few months. As long as spare time
to work on gfortran is limited, I'd rather prefer to get as much fixed
for that release.
(This is not a no: I simply expect that real regression testing for the
associate changes may take more time.)
> I am dithering about changing the F2003/08 part of finalization since
> the default is 2018 compliance. That said, it does need a change since
> the suppression of constructor finalization is also suppressing
> finalization of function results within the compilers. I'll do that
> first, perhaps?
That sounds like a good idea.
Cheers,
Harald
> Cheers
>
> Paul
>
>
>
> On Sat, 3 Jun 2023 at 06:50, Thomas Koenig <tkoenig@netcologne.de> wrote:
>>
>> Hi Paul,
>>
>>> I propose to backport
>>> r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
>>> soon.
>>
>> Is this something that we usually do?
>>
>> While finalization was basically broken before, some people still used
>> working subsets (or subsets that were broken, and they adapted or
>> wrote their code accordingly).
>>
>> What is the general opinion on that? I'm undecided.
>>
>>> Before that, I propose to remove the F2003/2008 finalization of
>>> structure and array constructors in 13- and 14-branches. I can see why
>>> it was removed from the standard in a correction to F2008 and think
>>> that it is likely to cause endless confusion and maintenance
>>> complications. However, finalization of function results within
>>> constructors will be retained.
>>
>> That, I agree with. Should it be noted somewhere as an intentional
>> deviation from the standard?
>>
>> Best regards
>>
>> Thomas
>>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
>
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-03 19:10 ` Harald Anlauf
@ 2023-06-03 19:10 ` Harald Anlauf
0 siblings, 0 replies; 10+ messages in thread
From: Harald Anlauf @ 2023-06-03 19:10 UTC (permalink / raw)
To: gcc-patches; +Cc: fortran
Hi Paul, all,
On 6/3/23 15:16, Paul Richard Thomas via Gcc-patches wrote:
> Hi Thomas,
>
> I want to get something approaching correct finalization to the
> distros, which implies 12-branch at present. Hopefully I can do the
> same with associate in a month or two's time.
IMHO it is not only distros, but also installations at (scientific)
computing centers with a larger user base and a large software stack.
Migrating to a different major version of gcc/gfortran is not a trivial
task for them.
I'd fully support the idea of backporting the finalization fixes, as
IIUC this on the one hand touches a rather isolated part, and on the
other hand already got quite some testing. It is also already in the
13-branch (or only mostly?). Given that 12.3 was released recently
and 12.4 is far away, there'd be sufficient time to fix any fallout.
Regarding the associate fixes, we could get as much of those into 13.2,
which we'd normally expect in just a few months. As long as spare time
to work on gfortran is limited, I'd rather prefer to get as much fixed
for that release.
(This is not a no: I simply expect that real regression testing for the
associate changes may take more time.)
> I am dithering about changing the F2003/08 part of finalization since
> the default is 2018 compliance. That said, it does need a change since
> the suppression of constructor finalization is also suppressing
> finalization of function results within the compilers. I'll do that
> first, perhaps?
That sounds like a good idea.
Cheers,
Harald
> Cheers
>
> Paul
>
>
>
> On Sat, 3 Jun 2023 at 06:50, Thomas Koenig <tkoenig@netcologne.de> wrote:
>>
>> Hi Paul,
>>
>>> I propose to backport
>>> r13-6747-gd7caf313525a46f200d7f5db1ba893f853774aee to 12-branch very
>>> soon.
>>
>> Is this something that we usually do?
>>
>> While finalization was basically broken before, some people still used
>> working subsets (or subsets that were broken, and they adapted or
>> wrote their code accordingly).
>>
>> What is the general opinion on that? I'm undecided.
>>
>>> Before that, I propose to remove the F2003/2008 finalization of
>>> structure and array constructors in 13- and 14-branches. I can see why
>>> it was removed from the standard in a correction to F2008 and think
>>> that it is likely to cause endless confusion and maintenance
>>> complications. However, finalization of function results within
>>> constructors will be retained.
>>
>> That, I agree with. Should it be noted somewhere as an intentional
>> deviation from the standard?
>>
>> Best regards
>>
>> Thomas
>>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
>
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] PR37336 finalization
2023-06-03 13:16 ` Paul Richard Thomas
2023-06-03 19:10 ` Harald Anlauf
@ 2023-06-03 19:22 ` Thomas Koenig
1 sibling, 0 replies; 10+ messages in thread
From: Thomas Koenig @ 2023-06-03 19:22 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: fortran, gcc-patches
Hi Paul,
> I want to get something approaching correct finalization to the
> distros, which implies 12-branch at present. Hopefully I can do the
> same with associate in a month or two's time.
OK by me then.
(I just wanted to be sure that we had this discussion :-)
Best regards
Thomas
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2023-06-03 19:22 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-03-07 13:45 [Patch, fortran] PR37336 finalization Paul Richard Thomas
2023-03-07 14:58 ` Thomas Koenig
2023-03-07 17:15 ` Steve Kargl
2023-06-02 13:42 ` Paul Richard Thomas
2023-06-03 5:50 ` Thomas Koenig
2023-06-03 7:32 ` Steve Kargl
2023-06-03 13:16 ` Paul Richard Thomas
2023-06-03 19:10 ` Harald Anlauf
2023-06-03 19:10 ` Harald Anlauf
2023-06-03 19:22 ` Thomas Koenig
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).