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)
{
/* 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);
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;
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. */
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)
}
}
+finish_assumed_rank:
+
/* Finalize and deallocate allocatable components. The same manual
scalarization is used as above. */
}
+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. */
if (sym->formal)
fputs (", ", dumpfile);
}
-
+
for (f = sym->formal; f; f = f->next)
{
gfc_symbol *s;
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) \
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)
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;
/* 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 */
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:
/* Resolve a BLOCK construct statement. */
+static gfc_expr*
+get_temp_from_expr (gfc_expr *, gfc_namespace *);
+static gfc_code *
+build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *,
+ gfc_component *, gfc_component *, locus);
static void
resolve_block_construct (gfc_code* code)
{
- /* Resolve the BLOCK's namespace. */
- gfc_resolve (code->ext.block.ns);
+ gfc_namespace *ns = code->ext.block.ns;
/* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during resolve_symbol. */
+ resolved during resolve_symbol. Resolve the BLOCK's namespace. */
+ gfc_resolve (ns);
}
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);
}
+/* 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)
{
}
-/* Implement 7.2.1.3 of the F08 standard:
- "An intrinsic assignment where the variable is of derived type is
- performed as if each component of the variable were assigned from the
- corresponding component of expr using pointer assignment (7.2.2) for
- each pointer component, defined assignment for each nonpointer
- nonallocatable component of a type that has a type-bound defined
- assignment consistent with the component, intrinsic assignment for
- each other nonpointer nonallocatable component, ..."
+/* Implement 10.2.1.3 paragraph 13 of the F18 standard:
+ "An intrinsic assignment where the variable is of derived type is performed
+ as if each component of the variable were assigned from the corresponding
+ component of expr using pointer assignment (10.2.2) for each pointer
+ component, defined assignment for each nonpointer nonallocatable component
+ of a type that has a type-bound defined assignment consistent with the
+ component, intrinsic assignment for each other nonpointer nonallocatable
+ component, and intrinsic assignment for each allocated coarray component.
+ For unallocated coarray components, the corresponding component of the
+ variable shall be unallocated. For a noncoarray allocatable component the
+ following sequence of operations is applied.
+ (1) If the component of the variable is allocated, it is deallocated.
+ (2) If the component of the value of expr is allocated, the
+ corresponding component of the variable is allocated with the same
+ dynamic type and type parameters as the component of the value of
+ expr. If it is an array, it is allocated with the same bounds. The
+ value of the component of the value of expr is then assigned to the
+ corresponding component of the variable using defined assignment if
+ the declared type of the component has a type-bound defined
+ assignment consistent with the component, and intrinsic assignment
+ for the dynamic type of that component otherwise."
+
+ The pointer assignments are taken care of by the intrinsic assignment of the
+ structure itself. This function recursively adds defined assignments where
+ required. The recursion is accomplished by calling gfc_resolve_code.
+
+ When the lhs in a defined assignment has intent INOUT or is intent OUT
+ and the component of 'var' is finalizable, we need a temporary for the
+ lhs. In pseudo-code for an assignment var = expr:
+
+ ! Confine finalization of temporaries, as far as possible.
+ Enclose the code for the assignment in a block
+ ! Only call function 'expr' once.
+ #if ('expr is not a constant or an variable)
+ temp_expr = expr
+ expr = temp_x
+ ! Do the intrinsic assignment
+ #if typeof ('var') has a typebound final subroutine
+ finalize (var)
+ var = expr
+ ! Now do the component assignments
+ #do over derived type components [%cmp]
+ #if (cmp is a pointer of any kind)
+ continue
+ build the assignment
+ resolve the code
+ #if the code is a typebound assignment
+ #if (arg1 is INOUT or finalizable OUT && !t1)
+ t1 = var
+ arg1 = t1
+ deal with allocatation or not of var and this component
+ #elseif the code is an assignment by itself
+ #if this component does not need finalization
+ delete code and continue
+ #else
+ remove the leading assignment
+ #endif
+ commit the code
+ #if (t1 and (arg1 is INOUT or finalizable OUT))
+ var%cmp = t1%cmp
+ #enddo
+ put all code chunks involving t1 to the top of the generated code
+ insert the generated block in place of the original code
+*/
- The pointer assignments are taken care of by the intrinsic
- assignment of the structure itself. This function recursively adds
- defined assignments where required. The recursion is accomplished
- by calling gfc_resolve_code.
+static bool
+is_finalizable_type (gfc_typespec ts)
+{
+ gfc_component *c;
- When the lhs in a defined assignment has intent INOUT, we need a
- temporary for the lhs. In pseudo-code:
+ if (ts.type != BT_DERIVED)
+ return false;
- ! Only call function lhs once.
- if (lhs is not a constant or an variable)
- temp_x = expr2
- expr2 => temp_x
- ! Do the intrinsic assignment
- expr1 = expr2
- ! Now do the defined assignments
- do over components with typebound defined assignment [%cmp]
- #if one component's assignment procedure is INOUT
- t1 = expr1
- #if expr2 non-variable
- temp_x = expr2
- expr2 => temp_x
- # endif
- expr1 = expr2
- # for each cmp
- t1%cmp {defined=} expr2%cmp
- expr1%cmp = t1%cmp
- #else
- expr1 = expr2
+ /* (1) Check for FINAL subroutines. */
+ if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
+ return true;
- # for each cmp
- expr1%cmp {defined=} expr2%cmp
- #endif
- */
+ /* (2) Check for components of finalizable type. */
+ for (c = ts.u.derived->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED
+ && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+ && c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->finalizers)
+ return true;
+
+ return false;
+}
/* The temporary assignments have to be put on top of the additional
code to avoid the result being changed by the intrinsic assignment.
*/
static int component_assignment_level = 0;
static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
+static bool finalizable_comp;
static void
generate_component_assignments (gfc_code **code, gfc_namespace *ns)
{
gfc_component *comp1, *comp2;
gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
- gfc_expr *t1;
+ gfc_code *tmp_code = NULL;
+ gfc_expr *t1 = NULL;
+ gfc_expr *tmp_expr = NULL;
int error_count, depth;
+ bool finalizable_lhs;
gfc_get_errors (NULL, &error_count);
return;
}
+ if (!component_assignment_level)
+ finalizable_comp = true;
+
+ /* Build a block so that function result temporaries are finalized
+ locally on exiting the rather than enclosing scope. */
+ if (!component_assignment_level)
+ {
+ ns = gfc_build_block_ns (ns);
+ tmp_code = gfc_get_code (EXEC_NOP);
+ *tmp_code = **code;
+ tmp_code->next = NULL;
+ (*code)->op = EXEC_BLOCK;
+ (*code)->ext.block.ns = ns;
+ (*code)->ext.block.assoc = NULL;
+ (*code)->expr1 = (*code)->expr2 = NULL;
+ ns->code = tmp_code;
+ code = &ns->code;
+ }
+
component_assignment_level++;
+ finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
+
/* Create a temporary so that functions get called only once. */
if ((*code)->expr2->expr_type != EXPR_VARIABLE
&& (*code)->expr2->expr_type != EXPR_CONSTANT)
{
- gfc_expr *tmp_expr;
-
/* Assign the rhs to the temporary. */
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
this_code = build_assignment (EXEC_ASSIGN,
tmp_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
+ this_code->expr2->must_finalize = 1;
/* Add the code and substitute the rhs expression. */
add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
gfc_free_expr ((*code)->expr2);
/* Do the intrinsic assignment. This is not needed if the lhs is one
of the temporaries generated here, since the intrinsic assignment
to the final result already does this. */
- if ((*code)->expr1->symtree->n.sym->name[2] != '@')
+ if ((*code)->expr1->symtree->n.sym->name[2] != '.')
{
+ if (finalizable_lhs)
+ (*code)->expr1->must_finalize = 1;
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
NULL, NULL, (*code)->loc);
comp1 = (*code)->expr1->ts.u.derived->components;
comp2 = (*code)->expr2->ts.u.derived->components;
- t1 = NULL;
for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
{
bool inout = false;
+ bool finalizable_out = false;
/* The intrinsic assignment does the right thing for pointers
of all kinds and allocatable components. */
if (!gfc_bt_struct (comp1->ts.type)
|| comp1->attr.pointer
- || comp1->attr.allocatable
|| comp1->attr.proc_pointer_comp
|| comp1->attr.class_pointer
|| comp1->attr.proc_pointer)
continue;
+ finalizable_comp = is_finalizable_type (comp1->ts)
+ && !finalizable_lhs;
+
/* Make an assignment for this component. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
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;
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);
else if (this_code->op == EXEC_ASSIGN && !this_code->next)
{
/* Don't add intrinsic assignments since they are already
- effected by the intrinsic assignment of the structure. */
- gfc_free_statements (this_code);
- this_code = NULL;
- continue;
+ effected by the intrinsic assignment of the structure, unless
+ finalization is required. */
+ if (finalizable_comp)
+ this_code->expr1->must_finalize = 1;
+ else
+ {
+ gfc_free_statements (this_code);
+ this_code = NULL;
+ continue;
+ }
+ }
+ else
+ {
+ /* Resolution has expanded an assignment of a derived type with
+ defined assigned components. Remove the redundant, leading
+ assignment. */
+ gcc_assert (this_code->op == EXEC_ASSIGN);
+ gfc_code *tmp = this_code;
+ this_code = this_code->next;
+ tmp->next = NULL;
+ gfc_free_statements (tmp);
}
add_code_to_chain (&this_code, &head, &tail);
- if (t1 && inout)
+ if (t1 && (inout || finalizable_out))
{
/* Transfer the value to the final result. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, t1,
comp1, comp2, (*code)->loc);
+ this_code->expr1->must_finalize = 0;
add_code_to_chain (&this_code, &head, &tail);
}
}
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)
{
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);
if (head != tail)
free (head);
*code = tail;
-
- component_assignment_level--;
}
&& 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;
}
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)
{
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);
{
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)
return;
}
+ if (c->attr.allocatable)
+ continue;
+
check_defined_assignments (c->ts.u.derived);
if (c->ts.u.derived->attr.defined_assign_comp)
{
&& 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);
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);
+ }
}
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;
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);
}
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;
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;
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);
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)
gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
+ ts = c->expr->ts;
}
/* The frontend should already have done any expansions
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);
}
gfc_ss *s;
tree neg_len;
char *msg;
+ stmtblock_t finalblock;
/* Save the old values for nested checking. */
old_first_len = first_len;
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. */
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);
+
}
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;
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);
+ }
}
}
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);
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. */
gfc_array_index_type, tmp,
stride, gfc_index_zero_node);
gfc_add_modify (pblock, stride, tmp);
- }
+ }
size = stride;
}
if (!se->direct_byref)
se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
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;
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);
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);
}
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
{
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
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,
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
{
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
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;
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);
}
}
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;
{
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);
}
{
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
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;
}
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);
}
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);
}
/* 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. */
tree
&& 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);
}
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
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;
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 *);
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)
&& !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
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);
}
{
memset (se, 0, sizeof (gfc_se));
gfc_init_block (&se->pre);
+ gfc_init_block (&se->finalblock);
gfc_init_block (&se->post);
se->parent = parent;
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
vec_safe_push (arglist, parmse.expr);
}
+
gfc_add_block_to_block (&se->pre, &clobbers);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
/* 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);
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)
{
&& 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)
{
/* 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);
}
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:
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);
}
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,
}
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);
{
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))
{
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;
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);
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
}
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);
{
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. */
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);
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,
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);
}
}
}
+
/* 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
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ bool final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
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
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
}
}
+ /* 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,
!(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)
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);
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
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);
}
gfc_expr *lhs;
tree res;
gfc_se se;
+ stmtblock_t final_block;
gfc_init_se (&se, NULL);
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;
}
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
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);
}
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);
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);
else
{
gfc_conv_expr (&se, var);
- gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+// gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
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);
}
+ /* 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:
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;
/* 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. */
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);
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" } }
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
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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for pr88735.
+!
+! Contributed by Martin Stein <mscfd@gmx.net>
+!
+module mod
+ implicit none
+ type, public :: t
+ integer, pointer :: i => NULL ()
+ character :: myname = 'z'
+ character :: alloc = 'n'
+ contains
+ procedure, public :: set
+ generic, public :: assignment(=) => set
+ final :: finalise
+ end type t
+ integer, public :: assoc_in_final = 0
+ integer, public :: calls_to_final = 0
+ character, public :: myname1, myname2
+
+contains
+
+ subroutine set(self, x)
+ class(t), intent(out) :: self
+ class(t), intent(in) :: x
+ if (associated(self%i)) then
+ stop 1 ! Default init for INTENT(OUT)
+ endif
+ if (associated(x%i)) then
+ myname2 = self%myname
+ self%i => x%i
+ self%i = self%i + 1
+ end if
+end subroutine set
+
+ subroutine finalise(self)
+ type(t), intent(inout) :: self
+ calls_to_final = calls_to_final + 1
+ myname1 = self%myname
+ if (associated(self%i)) then
+ assoc_in_final = assoc_in_final + 1
+ if (self%alloc .eq. 'y') deallocate (self%i)
+ end if
+ end subroutine finalise
+
+end module mod
+
+program finalise_assign
+ use mod
+ implicit none
+ type :: s
+ integer :: i = 0
+ type(t) :: x
+ end type s
+ type(s) :: a, b
+ type(t) :: c
+ a%x%myname = 'a'
+ b%x%myname = 'b'
+ c%myname = 'c'
+ allocate (a%x%i)
+ a%x%i = 123
+ a%x%alloc = 'y'
+
+ b = a
+ if (assoc_in_final /= 0) stop 2 ! b%x%i not associated before finalization
+ if (calls_to_final /= 2) stop 3 ! One finalization call
+ if (myname1 .ne. 'b') stop 4 ! Finalization before intent out become undefined
+ if (myname2 .ne. 'z') stop 5 ! Intent out now default initialized
+ if (.not.associated (b%x%i, a%x%i)) stop 6
+
+ allocate (c%i, source = 789)
+ c%alloc = 'y'
+ c = a%x
+ if (assoc_in_final /= 1) stop 6 ! c%i is allocated prior to the assignment
+ if (calls_to_final /= 3) stop 7 ! One finalization call for the assignment
+ if (myname1 .ne. 'c') stop 8 ! Finalization before intent out become undefined
+ if (myname2 .ne. 'z') stop 9 ! Intent out now default initialized
+
+ b = a
+ if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
+ if (calls_to_final /= 5) stop 11 ! One finalization call for the assignment
+ if (myname1 .ne. 'z') stop 12 ! b%x%myname was default initialized in earlier assignment
+ if (myname2 .ne. 'z') stop 13 ! Intent out now default initialized
+ if (b%x%i .ne. 126) stop 14 ! Three assignments with self%x%i pointing to same target
+ deallocate (a%x%i)
+ if (.not.associated (b%x%i, c%i)) then
+ stop 15 ! ditto
+ b%x%i =>NULL () ! Although not needed here, clean up
+ c%i => NULL ()
+ endif
+end program finalise_assign
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Part of PR106576.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module finalizable_m
+ !! This module supports the main program at the bottom of this file, which
+ !! tests compiler conformance with clause 7.5.6.3, paragraph 6 in the Fortran
+ !! Interpretation Document (https://j3-fortran.org/doc/year/18/18-007r1.pdf):
+ !! "If a specification expression in a scoping unit references
+ !! a function, the result is finalized before execution of the executable
+ !! constructs in the scoping unit."
+ implicit none
+
+ private
+ public :: finalizable_t, component
+
+ type finalizable_t
+ private
+ integer, allocatable :: component_
+ contains
+ final :: finalize
+ end Type
+
+ interface finalizable_t
+ module procedure construct
+ end interface
+
+contains
+
+ pure function construct(component) result(finalizable)
+ integer, intent(in) :: component
+ type(finalizable_t) finalizable
+ allocate(finalizable%component_, source = component)
+ end function
+
+ pure function component(self) result(self_component)
+ type(finalizable_t), intent(in) :: self
+ integer self_component
+ self_component = self%component_
+ end function
+
+ pure subroutine finalize(self)
+ type(finalizable_t), intent(inout) :: self
+ if (allocated(self%component_)) deallocate(self%component_)
+ end subroutine
+
+end module
+
+program specification_expression_finalization
+ use finalizable_m, only : finalizable_t, component
+ implicit none
+
+ call finalize_specification_expression_result
+
+contains
+
+ subroutine finalize_specification_expression_result
+ real tmp(component(finalizable_t(component=1))) !! Finalizes the finalizable_t function result
+ real eliminate_unused_variable_warning
+ tmp = eliminate_unused_variable_warning
+ end subroutine
+
+end program
+! { dg-final { scan-tree-dump-times "_final != 0B" 1 "original" } }
\ No newline at end of file
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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" } }