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