@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
gfc_component *c;
for (c = derived->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+ if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+ && c->attr.flavor != FL_PROCEDURE)
{
if (c->ts.u.derived->f2k_derived
&& c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
{
/* Call FINAL_WRAPPER (comp); */
gfc_code *final_wrap;
- gfc_symbol *vtab;
+ gfc_symbol *vtab, *byte_stride;
+ gfc_expr *scalar, *size_expr, *fini_coarray_expr;
gfc_component *c;
vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
break;
gcc_assert (c);
+
+ /* Set scalar argument for storage_size. */
+ gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts = e->ts;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
+ gfc_commit_symbol (byte_stride);
+ scalar = gfc_lval_expr_from_sym (byte_stride);
+
final_wrap = gfc_get_code (EXEC_CALL);
final_wrap->symtree = c->initializer->symtree;
final_wrap->resolved_sym = c->initializer->symtree->n.sym;
final_wrap->ext.actual = gfc_get_actual_arglist ();
final_wrap->ext.actual->expr = e;
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ scalar,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* Which provides the argument 'byte_stride'..... */
+ final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->expr = size_expr;
+
+ /* ...and last of all the 'fini_coarray' argument. */
+ fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+ final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
if (*code)
{
(*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->next->resolved_sym = fini->proc_tree->n.sym;
block->next->ext.actual = gfc_get_actual_arglist ();
block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
- block->next->ext.actual->next = gfc_get_actual_arglist ();
- block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
/* ELSE. */
@@ -2047,13 +2089,32 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_set_sym_referenced (ptr);
gfc_commit_symbol (ptr);
+ fini = derived->f2k_derived->finalizers;
+
+ /* Assumed rank finalizers can be called directly. The call takes care
+ of setting up the descriptor. resolve_finalizers has already checked
+ that this is the only finalizer for this kind/type (F2018: C790). */
+ if (fini->proc_tree && fini->proc_tree->n.sym->formal->sym->as
+ && fini->proc_tree->n.sym->formal->sym->as->type == AS_ASSUMED_RANK)
+ {
+ last_code->next = gfc_get_code (EXEC_CALL);
+ last_code->next->symtree = fini->proc_tree;
+ last_code->next->resolved_sym = fini->proc_tree->n.sym;
+ last_code->next->ext.actual = gfc_get_actual_arglist ();
+ last_code->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+
+ last_code = last_code->next;
+ goto finish_assumed_rank;
+ }
+
/* SELECT CASE (RANK (array)). */
last_code->next = gfc_get_code (EXEC_SELECT);
last_code = last_code->next;
last_code->expr1 = gfc_copy_expr (rank);
block = NULL;
- for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+
+ for (; fini; fini = fini->next)
{
gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
if (fini->proc_tree->n.sym->attr.elemental)
@@ -2152,6 +2213,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
}
}
+finish_assumed_rank:
+
/* Finalize and deallocate allocatable components. The same manual
scalarization is used as above. */
@@ -2682,6 +2745,14 @@ yes:
}
+bool
+gfc_may_be_finalized (gfc_typespec ts)
+{
+ return (ts.type == BT_CLASS || (ts.type == BT_DERIVED
+ && ts.u.derived && gfc_is_finalizable (ts.u.derived, NULL)));
+}
+
+
/* Find (or generate) the symbol for an intrinsic type's vtab. This is
needed to support unlimited polymorphism. */
@@ -3931,6 +3931,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, bool*,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
+bool gfc_may_be_finalized (gfc_typespec);
#define CLASS_DATA(sym) sym->ts.u.derived->components
#define UNLIMITED_POLY(sym) \
@@ -3478,6 +3478,24 @@ resolve_function (gfc_expr *expr)
expr->ts = expr->symtree->n.sym->result->ts;
}
+ /* These derived types with an incomplete namespace, arising from use
+ association, cause gfc_get_derived_vtab to segfault. If the function
+ namespace does not suffice, something is badly wrong. */
+ if (expr->ts.type == BT_DERIVED
+ && !expr->ts.u.derived->ns->proc_name)
+ {
+ gfc_symbol *der;
+ gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
+ if (der)
+ {
+ expr->ts.u.derived->refs--;
+ expr->ts.u.derived = der;
+ der->refs++;
+ }
+ else
+ expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
+ }
+
if (!expr->ref && !expr->value.function.isym)
{
if (expr->value.function.esym)
@@ -10556,6 +10574,11 @@ resolve_where (gfc_code *code, gfc_expr *mask)
if (e && !resolve_where_shape (cnext->expr1, e))
gfc_error ("WHERE assignment target at %L has "
"inconsistent shape", &cnext->expr1->where);
+
+ if (cnext->op == EXEC_ASSIGN
+ && gfc_may_be_finalized (cnext->expr1->ts))
+ cnext->expr1->must_finalize = 1;
+
break;
@@ -10643,6 +10666,11 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
/* WHERE assignment statement */
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+ if (cnext->op == EXEC_ASSIGN
+ && gfc_may_be_finalized (cnext->expr1->ts))
+ cnext->expr1->must_finalize = 1;
+
break;
/* WHERE operator assignment statement */
@@ -10689,6 +10717,11 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+ if (c->op == EXEC_ASSIGN
+ && gfc_may_be_finalized (c->expr1->ts))
+ c->expr1->must_finalize = 1;
+
break;
case EXEC_ASSIGN_CALL:
@@ -11369,6 +11407,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
tmp->n.sym->attr.use_assoc = 0;
tmp->n.sym->attr.intent = INTENT_UNKNOWN;
+
if (as)
{
tmp->n.sym->as = gfc_copy_array_spec (as);
@@ -11420,9 +11459,62 @@ add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
}
+/* Generate a final call from a variable expression */
+
+static void
+generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
+{
+ gfc_code *this_code;
+ gfc_expr *final_expr = NULL;
+ gfc_expr *size_expr;
+ gfc_expr *fini_coarray;
+
+ gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
+ if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
+ return;
+
+ /* Now generate the finalizer call. */
+ this_code = gfc_get_code (EXEC_CALL);
+ this_code->symtree = final_expr->symtree;
+ this_code->resolved_sym = final_expr->symtree->n.sym;
+
+ //* Expression to be finalized */
+ this_code->ext.actual = gfc_get_actual_arglist ();
+ this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
+
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ this_code->ext.actual->next = gfc_get_actual_arglist ();
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+ this_code->ext.actual->next->expr = size_expr;
+
+ /* fini_coarray */
+ this_code->ext.actual->next->next = gfc_get_actual_arglist ();
+ fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &tmp_expr->where);
+ fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
+ this_code->ext.actual->next->next->expr = fini_coarray;
+
+ add_code_to_chain (&this_code, head, tail);
+
+}
+
/* Counts the potential number of part array references that would
result from resolution of typebound defined assignments. */
+
static int
nonscalar_typebound_assign (gfc_symbol *derived, int depth)
{
@@ -11509,8 +11601,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
{
gfc_component *comp1, *comp2;
gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
- gfc_expr *t1;
+ gfc_code *tmp_code = NULL;
+ gfc_expr *t1 = NULL;
+ gfc_expr *tmp_expr = NULL;
int error_count, depth;
+ bool finalizable_lhs = gfc_may_be_finalized ((*code)->expr1->ts);
gfc_get_errors (NULL, &error_count);
@@ -11531,19 +11626,34 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
return;
}
+ /* Build a block so that function result temporaries are finalized
+ locally rather than on exiting the enclosing scope. */
+ if (!component_assignment_level)
+ {
+ ns = gfc_build_block_ns (ns);
+ tmp_code = gfc_get_code (EXEC_NOP);
+ *tmp_code = **code;
+ tmp_code->next = NULL;
+ (*code)->op = EXEC_BLOCK;
+ (*code)->ext.block.ns = ns;
+ (*code)->ext.block.assoc = NULL;
+ (*code)->expr1 = (*code)->expr2 = NULL;
+ ns->code = tmp_code;
+ code = &ns->code;
+ }
+
component_assignment_level++;
/* Create a temporary so that functions get called only once. */
if ((*code)->expr2->expr_type != EXPR_VARIABLE
&& (*code)->expr2->expr_type != EXPR_CONSTANT)
{
- gfc_expr *tmp_expr;
-
/* Assign the rhs to the temporary. */
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
this_code = build_assignment (EXEC_ASSIGN,
tmp_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
+ this_code->expr2->must_finalize = 1;
/* Add the code and substitute the rhs expression. */
add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
gfc_free_expr ((*code)->expr2);
@@ -11555,6 +11665,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
to the final result already does this. */
if ((*code)->expr1->symtree->n.sym->name[2] != '@')
{
+ if (finalizable_lhs)
+ (*code)->expr1->must_finalize = 1;
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
NULL, NULL, (*code)->loc);
@@ -11564,26 +11676,42 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
comp1 = (*code)->expr1->ts.u.derived->components;
comp2 = (*code)->expr2->ts.u.derived->components;
- t1 = NULL;
for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
{
bool inout = false;
+ bool finalizable_out = false;
/* The intrinsic assignment does the right thing for pointers
of all kinds and allocatable components. */
if (!gfc_bt_struct (comp1->ts.type)
- || comp1->attr.pointer
- || comp1->attr.allocatable
+ || (comp1->attr.pointer && !gfc_may_be_finalized (comp1->ts))
|| comp1->attr.proc_pointer_comp
|| comp1->attr.class_pointer
|| comp1->attr.proc_pointer)
continue;
+ /* Do the explicit pointer assignment to finalize the target. */
+ if (comp1->attr.pointer)
+ {
+ this_code = build_assignment (EXEC_POINTER_ASSIGN,
+ (*code)->expr1, (*code)->expr2,
+ comp1, comp2, (*code)->loc);
+ add_code_to_chain (&this_code, &head, &tail);
+ continue;
+ }
+
/* Make an assignment for this component. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, (*code)->expr2,
comp1, comp2, (*code)->loc);
+ if (comp1->attr.allocatable
+ && comp1->ts.type != BT_DERIVED)
+ {
+ add_code_to_chain (&this_code, &head, &tail);
+ continue;
+ }
+
/* Convert the assignment if there is a defined assignment for
this type. Otherwise, using the call from gfc_resolve_code,
recurse into its components. */
@@ -11611,8 +11739,13 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
a temporary must be generated and used instead. */
rsym = this_code->resolved_sym;
dummy_args = gfc_sym_get_dummy_args (rsym);
- if (dummy_args
- && dummy_args->sym->attr.intent == INTENT_INOUT)
+ finalizable_out = gfc_may_be_finalized (comp1->ts)
+ && dummy_args
+ && dummy_args->sym->attr.intent == INTENT_OUT;
+ inout = dummy_args
+ && dummy_args->sym->attr.intent == INTENT_INOUT;
+ if ((inout || finalizable_out)
+ && !comp1->attr.allocatable)
{
gfc_code *temp_code;
inout = true;
@@ -11621,7 +11754,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
it at the head of the generated code. */
if (!t1)
{
- t1 = get_temp_from_expr ((*code)->expr1, ns);
+ gfc_namespace *tmp_ns = ns;
+ if (ns->parent && gfc_may_be_finalized (comp1->ts))
+ tmp_ns = (*code)->expr1->symtree->n.sym->ns;
+ t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
+ t1->symtree->n.sym->attr.artificial = 1;
temp_code = build_assignment (EXEC_ASSIGN,
t1, (*code)->expr1,
NULL, NULL, (*code)->loc);
@@ -11688,15 +11825,27 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
this_code = NULL;
continue;
}
+ else
+ {
+ /* Resolution has expanded an assignment of a derived type with
+ defined assigned components. Remove the redundant, leading
+ assignment. */
+ gcc_assert (this_code->op == EXEC_ASSIGN);
+ gfc_code *tmp = this_code;
+ this_code = this_code->next;
+ tmp->next = NULL;
+ gfc_free_statements (tmp);
+ }
add_code_to_chain (&this_code, &head, &tail);
- if (t1 && inout)
+ if (t1 && (inout || finalizable_out))
{
/* Transfer the value to the final result. */
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1, t1,
comp1, comp2, (*code)->loc);
+ this_code->expr1->must_finalize = 0;
add_code_to_chain (&this_code, &head, &tail);
}
}
@@ -11709,8 +11858,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
tmp_head = tmp_tail = NULL;
}
- // If we did a pointer assignment - thus, we need to ensure that the LHS is
- // not accidentally deallocated. Hence, nullify t1.
+ /* If we did a pointer assignment - thus, we need to ensure that the LHS is
+ not accidentally deallocated. Hence, nullify t1. */
if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
&& gfc_expr_attr ((*code)->expr1).allocatable)
{
@@ -11731,6 +11880,18 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
tail = block;
}
+ component_assignment_level--;
+
+ /* Make an explicit final call for the function result. */
+ if (tmp_expr)
+ generate_final_call (tmp_expr, &head, &tail);
+
+ if (tmp_code)
+ {
+ ns->code = head;
+ return;
+ }
+
/* Now attach the remaining code chain to the input code. Step on
to the end of the new code since resolution is complete. */
gcc_assert ((*code)->op == EXEC_ASSIGN);
@@ -11743,8 +11904,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
if (head != tail)
free (head);
*code = tail;
-
- component_assignment_level--;
}
@@ -12164,6 +12323,14 @@ start:
&& code->expr1->ts.u.derived
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
+ else if (code->op == EXEC_ASSIGN)
+ {
+ if (gfc_may_be_finalized (code->expr1->ts))
+ code->expr1->must_finalize = 1;
+ if (code->expr2->expr_type == EXPR_ARRAY
+ && gfc_may_be_finalized (code->expr2->ts))
+ code->expr2->must_finalize = 1;
+ }
break;
@@ -13741,6 +13908,15 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
}
arg = dummy_args->sym;
+ if (arg->as && arg->as->type == AS_ASSUMED_RANK
+ && ((list != derived->f2k_derived->finalizers) || list->next))
+ {
+ gfc_error ("FINAL procedure at %L with assumed rank argument must "
+ "be the only finalizer with the same kind/type "
+ "(F2018: C790)", &list->where);
+ goto error;
+ }
+
/* This argument must be of our type. */
if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
{
@@ -13841,7 +14017,8 @@ error:
if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
gfc_warning (OPT_Wsurprising,
"Only array FINAL procedures declared for derived type %qs"
- " defined at %L, suggest also scalar one",
+ " defined at %L, suggest also scalar one unless an assumed"
+ " rank finalizer has been declared",
derived->name, &derived->declared_at);
vtab = gfc_find_derived_vtab (derived);
@@ -14573,7 +14750,6 @@ check_defined_assignments (gfc_symbol *derived)
{
if (!gfc_bt_struct (c->ts.type)
|| c->attr.pointer
- || c->attr.allocatable
|| c->attr.proc_pointer_comp
|| c->attr.class_pointer
|| c->attr.proc_pointer)
@@ -14587,6 +14763,9 @@ check_defined_assignments (gfc_symbol *derived)
return;
}
+ if (c->attr.allocatable)
+ continue;
+
check_defined_assignments (c->ts.u.derived);
if (c->ts.u.derived->attr.defined_assign_comp)
{
@@ -15261,7 +15440,7 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.access != ACCESS_PRIVATE
- && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template))
+ && !(sym->attr.vtype || sym->attr.pdt_template))
{
gfc_symbol *vtab = gfc_find_derived_vtab (sym);
gfc_set_sym_referenced (vtab);
@@ -16357,6 +16536,15 @@ resolve_symbol (gfc_symbol *sym)
if (sym->param_list)
resolve_pdt (sym);
+
+ if (!sym->attr.referenced
+ && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+ {
+ gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
+ if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
+ gfc_set_sym_referenced (sym);
+ gfc_free_expr (final_expr);
+ }
}
@@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
{
gcc_assert (expr->ts.type == BT_CHARACTER);
-
+
tmp = gfc_get_character_len_in_bytes (tmp);
-
+
if (tmp == NULL_TREE || integer_zerop (tmp))
{
tree bs;
@@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, bs);
}
-
+
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
}
@@ -2026,10 +2026,11 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
for the dynamic parts must be allocated using realloc. */
static void
-gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor_base base,
- tree * poffset, tree * offsetvar,
- bool dynamic)
+gfc_trans_array_constructor_value (stmtblock_t * pblock,
+ stmtblock_t * finalblock,
+ tree type, tree desc,
+ gfc_constructor_base base, tree * poffset,
+ tree * offsetvar, bool dynamic)
{
tree tmp;
tree start = NULL_TREE;
@@ -2039,6 +2040,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_se se;
mpz_t size;
gfc_constructor *c;
+ gfc_typespec ts;
+ int ctr = 0;
tree shadow_loopvar = NULL_TREE;
gfc_saved_var saved_loopvar;
@@ -2046,6 +2049,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
mpz_init (size);
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
+ ctr++;
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
gfc_put_offset_into_var (pblock, poffset, offsetvar);
@@ -2091,8 +2095,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
- gfc_trans_array_constructor_value (&body, type, desc,
- c->expr->value.constructor,
+ gfc_trans_array_constructor_value (&body, finalblock, type,
+ desc, c->expr->value.constructor,
poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
@@ -2200,6 +2204,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
+ ts = c->expr->ts;
}
/* The frontend should already have done any expansions
@@ -2292,6 +2297,34 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
}
}
+
+ /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+ constructor or array constructor, the entity created by the constructor is
+ finalized after execution of the innermost executable construct containing
+ the reference. This, in fact, was later deleted by the Combined Techical
+ Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
+
+ Transmit finalization of this constructor through 'finalblock'. */
+ if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL
+ && gfc_may_be_finalized (ts)
+ && ctr > 0 && desc != NULL_TREE
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ symbol_attribute attr;
+ gfc_se fse;
+ gfc_warning (0, "The structure constructor at %C has been"
+ " finalized. This feature was removed by f08/0011."
+ " Use -std=f2018 or -std=gnu to eliminate the"
+ " finalization.");
+ attr.pointer = attr.allocatable = 0;
+ gfc_init_se (&fse, NULL);
+ fse.expr = desc;
+ gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
+ gfc_add_block_to_block (finalblock, &fse.pre);
+ gfc_add_block_to_block (finalblock, &fse.finalblock);
+ gfc_add_block_to_block (finalblock, &fse.post);
+ }
+
mpz_clear (size);
}
@@ -2738,6 +2771,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
gfc_ss *s;
tree neg_len;
char *msg;
+ stmtblock_t finalblock;
/* Save the old values for nested checking. */
old_first_len = first_len;
@@ -2897,8 +2931,12 @@ trans_array_constructor (gfc_ss * ss, locus * where)
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
suppress_warning (offsetvar);
TREE_USED (offsetvar) = 0;
- gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
- &offset, &offsetvar, dynamic);
+
+ gfc_init_block (&finalblock);
+ gfc_trans_array_constructor_value (&outer_loop->pre,
+ expr->must_finalize ? &finalblock : NULL,
+ type, desc, c, &offset, &offsetvar,
+ dynamic);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
@@ -2933,6 +2971,15 @@ finish:
first_len = old_first_len;
first_len_val = old_first_len_val;
typespec_chararray_ctor = old_typespec_chararray_ctor;
+
+ /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+ constructor or array constructor, the entity created by the constructor is
+ finalized after execution of the innermost executable construct containing
+ the reference. */
+ if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+ && finalblock.head != NULL_TREE)
+ gfc_add_block_to_block (&loop->post, &finalblock);
+
}
@@ -3161,6 +3208,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
+ gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
ss_info->string_length = se.string_length;
break;
@@ -6454,23 +6502,29 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
for (dim = as->rank; dim < as->rank + as->corank; dim++)
{
- /* Evaluate non-constant array bound expressions. */
+ /* Evaluate non-constant array bound expressions.
+ F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
+ references a function, the result is finalized before execution of the
+ executable constructs in the scoping unit.
+ Adding the finalblocks enables this. */
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (as->lower[dim] && !INTEGER_CST_P (lbound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, lbound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, lbound, se.expr);
+ }
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, ubound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, ubound, se.expr);
+ }
}
}
@@ -6499,23 +6553,29 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
offset = gfc_index_zero_node;
for (dim = 0; dim < as->rank; dim++)
{
- /* Evaluate non-constant array bound expressions. */
+ /* Evaluate non-constant array bound expressions.
+ F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
+ references a function, the result is finalized before execution of the
+ executable constructs in the scoping unit.
+ Adding the finalblocks enables this. */
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (as->lower[dim] && !INTEGER_CST_P (lbound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, lbound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, lbound, se.expr);
+ }
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, ubound, se.expr);
- }
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_block_to_block (pblock, &se.finalblock);
+ gfc_add_modify (pblock, ubound, se.expr);
+ }
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
lbound, size);
@@ -6529,19 +6589,19 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
stride = GFC_TYPE_ARRAY_SIZE (type);
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
- {
- /* Calculate stride = size * (ubound + 1 - lbound). */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ {
+ /* Calculate stride = size * (ubound + 1 - lbound). */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfc_index_one_node, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, ubound, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
- if (stride)
- gfc_add_modify (pblock, stride, tmp);
- else
- stride = gfc_evaluate_now (tmp, pblock);
+ if (stride)
+ gfc_add_modify (pblock, stride, tmp);
+ else
+ stride = gfc_evaluate_now (tmp, pblock);
/* Make sure that negative size arrays are translated
to being zero size. */
@@ -6551,7 +6611,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
gfc_array_index_type, tmp,
stride, gfc_index_zero_node);
gfc_add_modify (pblock, stride, tmp);
- }
+ }
size = stride;
}
@@ -7531,7 +7591,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (!se->direct_byref)
se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -8973,9 +9033,10 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
static gfc_actual_arglist *pdt_param_list;
static tree
-structure_alloc_comps (gfc_symbol * der_type, tree decl,
- tree dest, int rank, int purpose, int caf_mode,
- gfc_co_subroutines_args *args)
+structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
+ int rank, int purpose, int caf_mode,
+ gfc_co_subroutines_args *args,
+ bool no_finalization = false)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -9063,11 +9124,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP, caf_mode, args);
+ COPY_ALLOC_COMP, caf_mode, args,
+ no_finalization);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
gfc_add_expr_to_block (&loopbody, tmp);
@@ -9101,13 +9163,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, args);
+ DEALLOCATE_PDT_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- NULLIFY_ALLOC_COMP, 0, args);
+ NULLIFY_ALLOC_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -9169,7 +9233,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9177,7 +9241,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9293,8 +9358,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
continue;
}
- if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
/* Call the finalizer, which will free the memory and nullify the
pointer of an array. */
deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -9322,7 +9387,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9330,7 +9395,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9628,7 +9694,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode, args);
+ rank, purpose, caf_mode, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@@ -9664,7 +9731,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose, caf_mode
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
- args);
+ args, no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
@@ -9772,7 +9839,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
else
add_when_allocated = NULL_TREE;
@@ -10145,7 +10213,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL);
}
@@ -10158,7 +10227,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL);
}
tree
@@ -10196,7 +10266,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
BCAST_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ &args);
return tmp;
}
@@ -10206,10 +10277,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
status of coarrays. */
tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+ bool no_finalization)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP, 0, NULL);
+ DEALLOCATE_ALLOC_COMP, 0, NULL,
+ no_finalization);
}
@@ -10217,7 +10290,8 @@ tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ NULL);
}
@@ -10233,6 +10307,20 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
}
+/* Recursively traverse an object of derived type, generating code to
+ copy it and its allocatable components, while suppressing any
+ finalization that might occur. This is used in the finalization of
+ function results. */
+
+tree
+gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
+ int rank, int caf_mode)
+{
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
+ caf_mode, NULL, true);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
copy only its allocatable components. */
@@ -10972,7 +11060,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
&& expr1->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
- expr1->rank);
+ expr1->rank, true);
gfc_add_expr_to_block (&realloc_block, tmp);
}
@@ -11145,8 +11233,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS)
&& sym->ts.u.derived->attr.alloc_comp;
- has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
- ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+ has_finalizer = gfc_may_be_finalized (sym->ts);
/* Make sure the frontend gets these right. */
gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
@@ -11269,6 +11356,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
else if ((!sym->attr.allocatable || !has_finalizer)
&& sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
&& !sym->attr.pointer && !sym->attr.save
+ && !(sym->attr.artificial && sym->name[0] == '_')
&& !sym->ns->proc_name->attr.is_main_program)
{
int rank;
@@ -56,11 +56,14 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+ bool no_finalization = false);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
+tree gfc_copy_alloc_comp_no_fini (gfc_symbol *, tree, tree, int, int);
+
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
@@ -4345,6 +4345,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_formal_arglist *f;
tree tmp;
tree present;
+ gfc_symbol *s;
+ bool dealloc_with_value = false;
gfc_init_block (&init);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
@@ -4352,42 +4354,52 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
+ s = f->sym;
tmp = NULL_TREE;
/* Note: Allocatables are excluded as they are already handled
by the caller. */
if (!f->sym->attr.allocatable
- && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
+ && gfc_is_finalizable (s->ts.u.derived, NULL))
{
stmtblock_t block;
gfc_expr *e;
gfc_init_block (&block);
- f->sym->attr.referenced = 1;
- e = gfc_lval_expr_from_sym (f->sym);
+ s->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (s);
gfc_add_finalizer_call (&block, e);
gfc_free_expr (e);
tmp = gfc_finish_block (&block);
}
- if (tmp == NULL_TREE && !f->sym->attr.allocatable
- && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (tmp == NULL_TREE && !s->attr.allocatable
+ && s->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
+ s->backend_decl,
+ s->as ? s->as->rank : 0);
+ dealloc_with_value = s->value;
+ }
- if (tmp != NULL_TREE && (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master))
+ if (tmp != NULL_TREE && (s->attr.optional
+ || s->ns->proc_name->attr.entry_master))
{
- present = gfc_conv_expr_present (f->sym);
+ present = gfc_conv_expr_present (s);
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
present, tmp, build_empty_stmt (input_location));
}
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE && !dealloc_with_value)
gfc_add_expr_to_block (&init, tmp);
- else if (f->sym->value && !f->sym->attr.allocatable)
- gfc_init_default_dt (f->sym, &init, true);
+ else if (s->value && !s->attr.allocatable)
+ {
+ gfc_add_expr_to_block (&init, tmp);
+ gfc_init_default_dt (s, &init, false);
+ dealloc_with_value = false;
+ }
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
@@ -4411,10 +4423,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
present, tmp,
build_empty_stmt (input_location));
}
-
gfc_add_expr_to_block (&init, tmp);
}
-
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
@@ -1910,6 +1910,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
{
memset (se, 0, sizeof (gfc_se));
gfc_init_block (&se->pre);
+ gfc_init_block (&se->finalblock);
gfc_init_block (&se->post);
se->parent = parent;
@@ -7073,6 +7074,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
+ gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
/* Allocated allocatable components of derived types must be
deallocated for non-variable scalars, array arguments to elemental
@@ -7439,6 +7441,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
vec_safe_push (arglist, parmse.expr);
}
+
gfc_add_block_to_block (&se->pre, &clobbers);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
@@ -7737,9 +7740,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Allocatable scalar function results must be freed and nullified
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
+ symbol_attribute attr = comp ? comp->attr : sym->attr;
+ bool allocatable = attr.allocatable && !attr.dimension;
+ gfc_symbol *der = comp ?
+ comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
+ :
+ sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
+ bool finalizable = der != NULL && der->ns->proc_name
+ && gfc_is_finalizable (der, NULL);
+
+ if (!byref && finalizable)
+ gfc_finalize_tree_expr (se, der, attr, expr->rank);
+
if (!byref && sym->ts.type != BT_CHARACTER
- && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
- || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+ && allocatable && !finalizable)
{
tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, tmp, se->expr);
@@ -7799,6 +7813,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
se->expr = info->descriptor;
/* Bundle in the string length. */
se->string_length = len;
+
+ if (finalizable)
+ gfc_finalize_tree_expr (se, der, attr, expr->rank);
}
else if (ts.type == BT_CHARACTER)
{
@@ -7891,8 +7908,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
{
- tree final_fndecl;
- tree is_final;
int n;
if (se->ss && se->ss->loop)
{
@@ -7914,66 +7929,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* TODO Eliminate the doubling of temporaries. This
one is necessary to ensure no memory leakage. */
se->expr = gfc_evaluate_now (se->expr, &se->pre);
- tmp = gfc_class_data_get (se->expr);
- tmp = gfc_conv_scalar_to_descriptor (se, tmp,
- CLASS_DATA (expr->value.function.esym->result)->attr);
}
- if ((gfc_is_class_array_function (expr)
- || gfc_is_alloc_class_scalar_function (expr))
- && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
- goto no_finalization;
-
- final_fndecl = gfc_class_vtab_final_get (se->expr);
- is_final = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- final_fndecl,
- fold_convert (TREE_TYPE (final_fndecl),
- null_pointer_node));
- final_fndecl = build_fold_indirect_ref_loc (input_location,
- final_fndecl);
- tmp = build_call_expr_loc (input_location,
- final_fndecl, 3,
- gfc_build_addr_expr (NULL, tmp),
- gfc_class_vtab_size_get (se->expr),
- boolean_false_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, is_final, tmp,
- build_empty_stmt (input_location));
-
- if (se->ss && se->ss->loop)
- {
- gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- info->data,
- fold_convert (TREE_TYPE (info->data),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (info->data),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->ss->loop->post, tmp);
- }
- else
- {
- tree classdata;
- gfc_prepend_expr_to_block (&se->post, tmp);
- classdata = gfc_class_data_get (se->expr);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- classdata,
- fold_convert (TREE_TYPE (classdata),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (classdata),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->post, tmp);
- }
+ /* Finalize the result, if necessary. */
+ attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+ if (!((gfc_is_class_array_function (expr)
+ || gfc_is_alloc_class_scalar_function (expr))
+ && attr.pointer))
+ gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
}
-
-no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
@@ -9485,10 +9449,29 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
case EXPR_STRUCTURE:
gfc_conv_structure (se, expr, 0);
+ /* F2008 4.5.6.3 para 5: If an executable construct references a
+ structure constructor or array constructor, the entity created by
+ the constructor is finalized after execution of the innermost
+ executable construct containing the reference. This, in fact,
+ was later deleted by the Combined Techical Corrigenda 1 TO 4 for
+ fortran 2008 (f08/0011). */
+ if (!gfc_notification_std (GFC_STD_F2018_DEL) && expr->must_finalize
+ && gfc_may_be_finalized (expr->ts))
+ {
+ gfc_warning (0, "The structure constructor at %C has been"
+ " finalized. This feature was removed by f08/0011."
+ " Use -std=f2018 or -std=gnu to eliminate the"
+ " finalization.");
+ symbol_attribute attr;
+ attr.allocatable = attr.pointer = 0;
+ gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
+ gfc_add_block_to_block (&se->post, &se->finalblock);
+ }
break;
case EXPR_ARRAY:
gfc_conv_array_constructor_expr (se, expr);
+ gfc_add_block_to_block (&se->post, &se->finalblock);
break;
default:
@@ -10489,7 +10472,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (dealloc)
{
tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+ 0, true);
if (deep_copy)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
@@ -10497,6 +10481,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_modify (&block, lse->expr,
@@ -10526,8 +10511,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
else if (gfc_bt_struct (ts.type))
{
- gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
+ gfc_add_block_to_block (&block, &lse->pre);
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
@@ -10537,6 +10523,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->finalblock);
if (!trans_scalar_class_assign (&block, lse, rse))
{
@@ -10867,6 +10854,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_ss *ss = NULL;
gfc_component *comp = NULL;
gfc_loopinfo loop;
+ tree tmp;
+ tree lhs;
+ gfc_se final_se;
+ gfc_symbol *sym = expr1->symtree->n.sym;
+ bool finalizable = gfc_may_be_finalized (expr1->ts);
if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
@@ -10885,12 +10877,44 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre);
se.want_pointer = 1;
+ /* First the lhs must be finalized, if necessary. We use a copy of the symbol
+ backend decl, stash the original away for the finalization so that the
+ value used is that before the assignment. This is necessary because
+ evaluation of the rhs expression using direct by reference can change
+ the value. However, the standard mandates that the finalization must occur
+ after evaluation of the rhs. */
+ gfc_init_se (&final_se, NULL);
+
+ if (finalizable)
+ {
+ tmp = sym->backend_decl;
+ lhs = sym->backend_decl;
+ if (TREE_CODE (tmp) == INDIRECT_REF)
+ tmp = TREE_OPERAND (tmp, 0);
+ sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
+ gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
+ expr1->rank, 0);
+ gfc_add_expr_to_block (&final_se.pre, tmp);
+ }
+ }
+
+ if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
+ {
+ gfc_add_block_to_block (&se.pre, &final_se.pre);
+ gfc_add_block_to_block (&se.post, &final_se.finalblock);
+ }
+
+ if (finalizable)
+ sym->backend_decl = lhs;
+
gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
if (expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived->attr.alloc_comp)
{
- tree tmp;
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
expr1->rank);
gfc_add_expr_to_block (&se.pre, tmp);
@@ -10900,6 +10924,18 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);
+ /* Since this is a direct by reference call, references to the lhs can be
+ used for finalization of the function result just as long as the blocks
+ from final_se are added at the right time. */
+ gfc_init_se (&final_se, NULL);
+ if (finalizable && expr2->value.function.esym)
+ {
+ final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
+ expr2->value.function.esym->attr,
+ expr2->rank);
+ }
+
/* Reallocate on assignment needs the loopinfo for extrinsic functions.
This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
Clearly, this cannot be done for an allocatable function result, since
@@ -10930,7 +10966,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
}
gfc_conv_function_expr (&se, expr2);
+
+ /* Fix the result. */
gfc_add_block_to_block (&se.pre, &se.post);
+ if (finalizable)
+ gfc_add_block_to_block (&se.pre, &final_se.pre);
+
+ /* Do the finalization, including final calls from function arguments. */
+ if (finalizable)
+ {
+ gfc_add_block_to_block (&se.pre, &final_se.post);
+ gfc_add_block_to_block (&se.pre, &se.finalblock);
+ gfc_add_block_to_block (&se.pre, &final_se.finalblock);
+ }
if (ss)
gfc_cleanup_loop (&loop);
@@ -11453,6 +11501,17 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
{
tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ bool final_expr;
+
+ final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
+ if (final_expr)
+ {
+ if (rse->loop)
+ gfc_prepend_expr_to_block (&rse->loop->pre,
+ gfc_finish_block (&lse->finalblock));
+ else
+ gfc_add_block_to_block (block, &lse->finalblock);
+ }
/* Store the old vptr so that dynamic types can be compared for
reallocation to occur or not. */
@@ -11478,8 +11537,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (vptr);
- class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- ? gfc_class_data_get (lse->expr) : lse->expr;
+ tmp = lse->expr;
+ class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ ? gfc_class_data_get (tmp) : tmp;
if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
class_han = gfc_build_addr_expr (NULL_TREE, class_han);
@@ -11500,6 +11560,10 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
tmp, re, build_empty_stmt (input_location));
gfc_add_expr_to_block (&re_alloc, re);
+ tree realloc_expr = lhs->ts.type == BT_CLASS ?
+ gfc_finish_block (&re_alloc) :
+ build_empty_stmt (input_location);
+
/* Allocate if _data is NULL, reallocate otherwise. */
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
@@ -11508,7 +11572,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_unlikely (tmp,
PRED_FORTRAN_FAIL_ALLOC),
gfc_finish_block (&alloc),
- gfc_finish_block (&re_alloc));
+ realloc_expr);
gfc_add_expr_to_block (&lse->pre, tmp);
}
@@ -11581,6 +11645,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
@@ -11604,6 +11669,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ bool final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
@@ -11635,15 +11701,29 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
rss = NULL;
- if ((expr1->ts.type == BT_DERIVED)
- && (gfc_is_class_array_function (expr2)
- || gfc_is_alloc_class_scalar_function (expr2)))
- expr2->must_finalize = 1;
+ if (expr2->expr_type != EXPR_VARIABLE
+ && expr2->expr_type != EXPR_CONSTANT
+ && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
+ {
+ expr2->must_finalize = 1;
+ /* F2008 4.5.6.3 para 5: If an executable construct references a
+ structure constructor or array constructor, the entity created by
+ the constructor is finalized after execution of the innermost
+ executable construct containing the reference.
+ These finalizations were later deleted by the Combined Techical
+ Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
+ if (gfc_notification_std (GFC_STD_F2018_DEL)
+ && (expr2->expr_type == EXPR_STRUCTURE
+ || expr2->expr_type == EXPR_ARRAY))
+ expr2->must_finalize = 0;
+ }
+
/* Checking whether a class assignment is desired is quite complicated and
needed at two locations, so do it once only before the information is
needed. */
lhs_attr = gfc_expr_attr (expr1);
+
is_poly_assign = (use_vptr_copy || lhs_attr.pointer
|| (lhs_attr.allocatable && !lhs_attr.dimension))
&& (expr1->ts.type == BT_CLASS
@@ -11917,6 +11997,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
else
gfc_add_expr_to_block (&loop.post, tmp2);
}
+
+ expr1->must_finalize = 0;
}
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11962,6 +12044,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
}
+ /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+ after evaluation of the rhs and before reallocation. */
+ final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
+ if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.artificial))
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_block_to_block (&block, &lse.finalblock);
+ }
+ else
+ {
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_block_to_block (&loop.code[expr1->rank - 1],
+ &lse.finalblock);
+ }
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.pre);
+
/* If nothing else works, do it the old fashioned way! */
if (tmp == NULL_TREE)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
@@ -11971,12 +12074,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
- /* Add the pre blocks to the body. */
- gfc_add_block_to_block (&body, &rse.pre);
+
+ /* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
+
/* Add the post blocks to the body. */
- gfc_add_block_to_block (&body, &rse.post);
+ if (!l_is_temp)
+ {
+ gfc_add_block_to_block (&rse.finalblock, &rse.post);
+ gfc_add_block_to_block (&body, &rse.finalblock);
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.post);
+
gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
@@ -2690,6 +2690,7 @@ scalarize:
gfc_add_block_to_block (&body, &se.pre);
gfc_add_block_to_block (&body, &se.post);
+ gfc_add_block_to_block (&body, &se.finalblock);
if (se.ss == NULL)
tmp = gfc_finish_block (&body);
@@ -444,7 +444,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
else
gfc_add_expr_to_block (&se.pre, se.expr);
- gfc_add_block_to_block (&se.pre, &se.post);
+ gfc_add_block_to_block (&se.finalblock, &se.post);
+ gfc_add_block_to_block (&se.pre, &se.finalblock);
}
else
@@ -543,6 +544,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
+ gfc_add_block_to_block (&se.pre, &loopse.finalblock);
gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
@@ -2189,6 +2191,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_expr *lhs;
tree res;
gfc_se se;
+ stmtblock_t final_block;
gfc_init_se (&se, NULL);
@@ -2196,6 +2199,15 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
allocation can take place automatically in gfc_trans_assignment.
The frontend prevents them from being either allocated,
deallocated or reallocated. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = sym->backend_decl;
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp,
+ sym->attr.dimension ? sym->as->rank : 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
@@ -2206,9 +2218,33 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
}
lhs = gfc_lval_expr_from_sym (sym);
+ lhs->must_finalize = 0;
res = gfc_trans_assignment (lhs, e, false, true);
gfc_add_expr_to_block (&se.pre, res);
+ gfc_init_block (&final_block);
+
+ if (sym->attr.associate_var
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.defined_assign_comp
+ && gfc_may_be_finalized (sym->ts)
+ && e->expr_type == EXPR_FUNCTION)
+ {
+ gfc_expr *ef;
+ ef = gfc_lval_expr_from_sym (sym);
+ gfc_add_finalizer_call (&final_block, ef);
+ gfc_free_expr (ef);
+ }
+
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = sym->backend_decl;
+ tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived,
+ tmp, 0);
+ gfc_add_expr_to_block (&final_block, tmp);
+ }
+
tmp = sym->backend_decl;
if (e->expr_type == EXPR_FUNCTION
&& sym->ts.type == BT_DERIVED
@@ -2243,6 +2279,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
else
tmp = NULL_TREE;
+ gfc_add_expr_to_block (&final_block, tmp);
+ tmp = gfc_finish_block (&final_block);
res = gfc_finish_block (&se.pre);
gfc_add_init_cleanup (block, res, tmp);
gfc_free_expr (lhs);
@@ -6347,7 +6385,10 @@ gfc_trans_allocate (gfc_code * code)
}
gfc_add_block_to_block (&block, &se.pre);
if (code->expr3->must_finalize)
- gfc_add_block_to_block (&final_block, &se.post);
+ {
+ gfc_add_block_to_block (&final_block, &se.finalblock);
+ gfc_add_block_to_block (&final_block, &se.post);
+ }
else
gfc_add_block_to_block (&post, &se.post);
@@ -7007,8 +7048,13 @@ gfc_trans_allocate (gfc_code * code)
gfc_expr *init_expr = gfc_expr_to_initialize (expr);
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
flag_realloc_lhs = 0;
+
+ /* Set the symbol to be artificial so that the result is not finalized. */
+ init_expr->symtree->n.sym->attr.artificial = 1;
tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
false);
+ init_expr->symtree->n.sym->attr.artificial = 0;
+
flag_realloc_lhs = realloc_lhs;
/* Free the expression allocated for init_expr. */
gfc_free_expr (init_expr);
@@ -1276,6 +1276,14 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
return false;
+ /* Finalization of these temporaries is made by explicit calls in
+ resolve.cc(generate_component_assignments). */
+ if (expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->name[0] == '_'
+ && expr2->ts.type == BT_DERIVED
+ && expr2->ts.u.derived->attr.defined_assign_comp)
+ return false;
+
if (expr2->ts.type == BT_DERIVED)
{
gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
@@ -1370,6 +1378,277 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
}
+ /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+ (10.2.1.3), if the variable is not an unallocated allocatable variable,
+ it is finalized after evaluation of expr and before the definition of
+ the variable. If the variable is an allocated allocatable variable, or
+ has an allocated allocatable subobject, that would be deallocated by
+ intrinsic assignment, the finalization occurs before the deallocation */
+
+bool
+gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
+{
+ symbol_attribute lhs_attr;
+ tree final_expr;
+ tree ptr;
+ tree cond;
+ gfc_se se;
+ gfc_symbol *sym = expr1->symtree->n.sym;
+ gfc_ref *ref = expr1->ref;
+ stmtblock_t final_block;
+ gfc_init_block (&final_block);
+ gfc_expr *finalize_expr;
+ bool class_array_ref;
+
+ /* We have to exclude vtable procedures (_copy and _final especially), uses
+ of gfc_trans_assignment_1 in initialization and allocation before trying
+ to build a final call. */
+ if (!expr1->must_finalize
+ || sym->attr.artificial
+ || sym->ns->proc_name->attr.artificial
+ || init_flag)
+ return false;
+
+ class_array_ref = ref && ref->type == REF_COMPONENT
+ && !strcmp (ref->u.c.component->name, "_data")
+ && ref->next && ref->next->type == REF_ARRAY
+ && !ref->next->next;
+
+ if (class_array_ref)
+ {
+ finalize_expr = gfc_lval_expr_from_sym (sym);
+ finalize_expr->must_finalize = 1;
+ ref = NULL;
+ }
+ else
+ finalize_expr = gfc_copy_expr (expr1);
+
+ /* F2018 7.5.6.2: Only finalizable entities are finalized. */
+ if (!(expr1->ts.type == BT_DERIVED
+ && gfc_is_finalizable (expr1->ts.u.derived, NULL))
+ && expr1->ts.type != BT_CLASS)
+ return false;
+
+ if (!gfc_may_be_finalized (sym->ts))
+ return false;
+
+ gfc_init_block (&final_block);
+ bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
+ gfc_free_expr (finalize_expr);
+
+ if (!finalizable)
+ return false;
+
+ lhs_attr = gfc_expr_attr (expr1);
+
+ /* Check allocatable/pointer is allocated/associated. */
+ if (lhs_attr.allocatable || lhs_attr.pointer)
+ {
+ if (expr1->ts.type == BT_CLASS)
+ {
+ ptr = gfc_get_class_from_gfc_expr (expr1);
+ gcc_assert (ptr != NULL_TREE);
+ ptr = gfc_class_data_get (ptr);
+ if (lhs_attr.dimension)
+ ptr = gfc_conv_descriptor_data_get (ptr);
+ }
+ else
+ {
+ gfc_init_se (&se, NULL);
+ if (expr1->rank)
+ {
+ gfc_conv_expr_descriptor (&se, expr1);
+ ptr = gfc_conv_descriptor_data_get (se.expr);
+ }
+ else
+ {
+ gfc_conv_expr (&se, expr1);
+ ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+ }
+
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ ptr, build_zero_cst (TREE_TYPE (ptr)));
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, gfc_finish_block (&final_block),
+ build_empty_stmt (input_location));
+ }
+ else
+ final_expr = gfc_finish_block (&final_block);
+
+ /* Check optional present. */
+ if (sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (sym);
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, final_expr,
+ build_empty_stmt (input_location));
+ }
+
+ gfc_add_expr_to_block (&lse->finalblock, final_expr);
+
+ return true;
+}
+
+
+/* Finalize a TREE expression using the finalizer wrapper. The result is
+ fixed in order to prevent repeated calls. */
+
+void
+gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
+ symbol_attribute attr, int rank)
+{
+ tree vptr, final_fndecl, desc, tmp, size, is_final;
+ tree data_ptr, data_null, cond;
+ gfc_symbol *vtab;
+ gfc_se post_se;
+ bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+ if (attr.pointer)
+ return;
+
+ /* Derived type function results with components that have defined
+ assignements are handled in resolve.cc(generate_component_assignments) */
+ if (derived && (derived->attr.is_c_interop
+ || derived->attr.is_iso_c
+ || derived->attr.is_bind_c
+ || derived->attr.defined_assign_comp))
+ return;
+
+ if (is_class)
+ {
+ if (!VAR_P (se->expr))
+ {
+ desc = gfc_evaluate_now (se->expr, &se->pre);
+ se->expr = desc;
+ }
+ desc = gfc_class_data_get (se->expr);
+ vptr = gfc_class_vptr_get (se->expr);
+ }
+ else if (derived && gfc_is_finalizable (derived, NULL))
+ {
+ if (derived->attr.zero_comp && !rank)
+ {
+ /* Any attempt to assign zero length entities, causes the gimplifier
+ all manner of problems. Instead, a variable is created to act as
+ as the argument for the final call. */
+ desc = gfc_create_var (TREE_TYPE (se->expr), "zero");
+ }
+ else if (se->direct_byref)
+ {
+ desc = gfc_evaluate_now (se->expr, &se->finalblock);
+ if (derived->attr.alloc_comp)
+ {
+ /* Need to copy allocated components and not finalize. */
+ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ }
+ }
+ else
+ {
+ desc = gfc_evaluate_now (se->expr, &se->pre);
+ se->expr = gfc_evaluate_now (desc, &se->pre);
+ if (derived->attr.alloc_comp)
+ {
+ /* Need to copy allocated components and not finalize. */
+ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
+
+ vtab = gfc_find_derived_vtab (derived);
+ if (vtab->backend_decl == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ else
+ vptr = vtab->backend_decl;
+ vptr = gfc_build_addr_expr (NULL, vptr);
+ }
+ else
+ return;
+
+ size = gfc_vptr_size_get (vptr);
+ final_fndecl = gfc_vptr_final_get (vptr);
+ is_final = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ final_fndecl,
+ fold_convert (TREE_TYPE (final_fndecl),
+ null_pointer_node));
+
+ final_fndecl = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ if (is_class)
+ desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+ else
+ {
+ gfc_init_se (&post_se, NULL);
+ desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+ gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+ }
+ }
+
+ if (derived && derived->attr.zero_comp)
+ {
+ /* All the conditions below break down for zero length derived types. */
+ tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ size, boolean_false_node);
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ return;
+ }
+
+ if (!VAR_P (desc))
+ {
+ tmp = gfc_create_var (TREE_TYPE (desc), "res");
+ if (se->direct_byref)
+ gfc_add_modify (&se->finalblock, tmp, desc);
+ else
+ gfc_add_modify (&se->pre, tmp, desc);
+ desc = tmp;
+ }
+
+ data_ptr = gfc_conv_descriptor_data_get (desc);
+ data_null = fold_convert (TREE_TYPE (data_ptr), null_pointer_node);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, data_ptr, data_null);
+ is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ logical_type_node, is_final, cond);
+ tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ size, boolean_false_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, is_final, tmp,
+ build_empty_stmt (input_location));
+
+ if (is_class && se->ss && se->ss->loop)
+ {
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->loop->post, tmp);
+ gfc_add_modify (&se->loop->post, data_ptr, data_null);
+ }
+ else
+ {
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+
+ /* Let the scalarizer take care of freeing of temporary arrays. */
+ if (attr.allocatable && !(se->loop && se->loop->temp_dim))
+ {
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ gfc_call_free (data_ptr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->finalblock, tmp);
+ gfc_add_modify (&se->finalblock, data_ptr, data_null);
+ }
+ }
+}
+
+
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
@@ -43,6 +43,10 @@ typedef struct gfc_se
stmtblock_t pre;
stmtblock_t post;
+ /* Carries finalization code that is required to be executed execution of the
+ innermost executable construct. */
+ stmtblock_t finalblock;
+
/* the result of the expression */
tree expr;
@@ -55,7 +59,7 @@ typedef struct gfc_se
/* Whether expr is a reference to an unlimited polymorphic object. */
unsigned unlimited_polymorphic:1;
-
+
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
@@ -450,6 +454,8 @@ tree gfc_get_vptr_from_expr (tree);
tree gfc_copy_class_to_class (tree, tree, tree, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
+void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
+bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
bool, tree *derived_array = NULL);
@@ -68,4 +68,4 @@ contains
end function func_foo_a
end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }
@@ -21,9 +21,7 @@ contains
associate(X => T()) ! This was failing: Symbol 'x' at (1) has no IMPLICIT type
final_flag = X%val
end associate
-! This should now be 4 but the finalization is not happening.
-! TODO put it right!
- if (final_flag .ne. 2) STOP 1
+ if (final_flag .ne. 2) stop 1
end subroutine Testf
end module
@@ -24,7 +24,7 @@ contains
allocate(x%i(1000))
end subroutine
-end program
+end program
! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
-! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_vptr->_final \\(&desc" 1 "original" } }
@@ -15,5 +15,5 @@ contains
end
end
-! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__STAR;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._data = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._vptr = .* &__vtab__STAR;" 1 "original" } }