From patchwork Tue Mar 7 13:45:55 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 66080 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 63EB3385141E for ; Tue, 7 Mar 2023 13:47:54 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 63EB3385141E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1678196874; bh=zxMh3IfjoYvHG8UxGuMF5HxioFepAcLnYaJW0bMOkiU=; h=Date:Subject:To:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=vuhQMCYQDHKdbLzKmFZJj14bmd2JrAomkb9aao4ct/VpFugZ1oUJXMAJMg1aRQuKp gttdynr228IBZWHzILjVElGRex6UWQprBJq3qRY1pLyjmCCtCUy/VcpYVAejj1gGRY 7v0Fd6QMMYwybtoNNDtYi7s0QgbxSpx3AEfL9MRQ= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pf1-x42c.google.com (mail-pf1-x42c.google.com [IPv6:2607:f8b0:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id 3461C3851C03; Tue, 7 Mar 2023 13:46:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3461C3851C03 Received: by mail-pf1-x42c.google.com with SMTP id c10so8017786pfv.13; Tue, 07 Mar 2023 05:46:08 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; t=1678196767; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=xk8VZv1A1mNOguhJe++FoIF22n/v3cPq3u9GysaulCs=; b=UinTcsuL0NeH0hdW5YZyPZJiIRMFpnbvG/MH2wygUwpFIByrVbip/s1AU40lRi881q XpLjHDLdMzqwfz0tlTNqxcfV5iyD47oKkK3pgDdwCBss4Lxy7yjk35MQzTCWTvnX8ybW cKfIhSBmMvXYOoMN+FSUutF/faL8VycGl1kvl6bzjZNSU/F1FXCRuT5RogazCUA8bdTT pQ3M/BTuiDn+aC3FIi/GsAVVIl+rV2yeTGcJNMzPbYIxTkU2ACP6G7tTv8ggROJcaVCB KtGISlyU3R+Ps75J4srmAk8wuTtEYa9H/jBymRkPQfKo/uxmCPqSfJd9y/IjCzRWoIDZ sMSg== X-Gm-Message-State: AO0yUKWok1QnQdv+ET6MfWxLJK8b3jvcWk+rZUnKpHQib2jLcjZzetGP fVy0M/AHFgL4BouTF45hH9YVtkam3he96dzYD/DI6VK3PI8= X-Google-Smtp-Source: AK7set/QBBXWfyR7OYikvYwjcknkDOWIGtSAGw8BpIYb5Jbw9zD4HAyeQ8E/W14ehAJ8cBiGfH5jdk8MGVyx5pXRSIw= X-Received: by 2002:a62:834b:0:b0:5e2:c313:a660 with SMTP id h72-20020a62834b000000b005e2c313a660mr6202076pfe.6.1678196766610; Tue, 07 Mar 2023 05:46:06 -0800 (PST) MIME-Version: 1.0 Date: Tue, 7 Mar 2023 13:45:55 +0000 Message-ID: Subject: [Patch, fortran] PR37336 finalization To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-6.8 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FILL_THIS_FORM, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-Content-Filtered-By: Mailman/MimeDel 2.1.29 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Paul Richard Thomas via Gcc-patches From: Paul Richard Thomas Reply-To: Paul Richard Thomas Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi All, I thought that I was ready for submission of this patch early in December, last year. That was before I tried to tackle the bugs triggered by the different versions of smart pointer or resource management. I would like to thank Andrew Benson, Salvatore Filippone, Jerry Delisle and Damian Rouson for all their help and encouragement in trying to get this right. The result is compliant with the F2018 standard (I think...!) and is more or less consistent with the other brands to which I have access. Thanks are also due to Malcolm Cohen for a very useful exchange of emails. All the paragraphs of F2018 7.5.6.3 "When finalization occurs" have been addressed. The difficulties of the last couple of months have all been related to finalization during intrinsic derived type assignment, where there are components with type bound defined assignments. These are, for the main part, dealt with by the chunks in resolve.cc(generate_component_assignments) and should be consistent with F2018: 10.2.1.3 "Interpretation of intrinsic assignments" paragraph 13. It is entirely possible that there are remaining corner cases. As a result of all this, the patch is now rather large at 2187 lines for the diff, even without the testcases. It is my intention to write the rest of the testcases and to break up the patch so that the various new features are introduced in separate patches. I can hurry this along to get the patch into 13-branch or I can wait until 14-branch opens. Best regards Paul Fortran: Fix bugs and implement missing features in finalization [PR37336] 2023-03-07 Paul Thomas gcc/fortran PR fortran/103854 * class.cc (has_finalizer_component): Do not return true for procedure pointer components. PR fortran/96122 * class.cc (finalize_component): Include the missing arguments in the call to the component's finalizer wrapper. PR fortran/37336 * class.cc (finalizer_insert_packed_call): Remove the redundant argument in the call to the final subroutine. (generate_finalization_wrapper): Add support for assumed rank finalizers. (gfc_may_be_finalized): New helper function. * gfortran.h : Add prototype for gfc_may_be_finalized. * resolve.cc (resolve_function): Correct derived types that have an incomplete namespace. (resolve_where, gfc_resolve_where_code_in_forall, gfc_resolve_forall_body, gfc_resolve_code): Check that the op code is still EXEC_ASSIGN. If it is set lhs to must finalize. (generate_component_assignments): Set must_finalize if needed. (gfc_resolve_finalizers): Error if assumed rank finalizer is not the only one. Warning on lack of scalar finalizer modified to account for assumed rank finalizers. (generate_final_call): New function. (generate_component_assignments): Enclose the outermost call in a block to capture automatic deallocation and final calls. Set must_finalize as required to satisfy the standards. Use an explicit pointer assignment for pointer components to capture finalization of the target. Likewise use explicit assignment for allocatable components. Do not use the temporary copy of the lhs in defined assignment if the component is allocatable. Put the temporary in the same namespace as the lhs symbol if the component may be finalized. Remove the leading assignment from the expansion of assignment of components that have their own defined assignment components. Suppress finalization of assignment of temporary components to the lhs. Make an explicit final call for the rhs function temporary if it exists. (gfc_resolve_code): Set must_finalize for assignments with an array constructor on the rhs. (gfc_resolve_finalizers): Ensure that an assumed rank finalizer is the only finalizer for that type and correct the surprising warning for the lack of a scalar finalizer. (check_defined_assignments): Handle allocatable components. (resolve_fl_derived): Set referenced the vtab for use associated symbols. (resolve_symbol): Set referenced an unreferenced symbol that will be finalized. * trans-array.cc (gfc_trans_array_constructor_value): Add code to finalize the constructor result. Warn that this feature was removed in F2018 and that it is suppressed by -std=2018. (trans_array_constructor): Add finalblock, pass to previous and apply to loop->post if filled. (gfc_add_loop_ss_code): Add se finalblock to outer loop post. (gfc_trans_array_cobounds, gfc_trans_array_bounds): Add any generated finalization code to the main block. (structure_alloc_comps): Add boolean argument to suppress finalization and use it for calls from gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to false. (gfc_copy_alloc_comp_no_fini): New wrapper for structure_alloc_comps. (gfc_alloc_allocatable_for_assignment): Suppress finalization by setting new arg in call to gfc_deallocate_alloc_comp_no_caf. (gfc_trans_deferred_array): Use gfc_may_be_finalized and do not deallocate the components of entities with a leading '_' in the name that are also marked as artificial. * trans-array.h : Add the new boolean argument to the prototype of gfc_deallocate_alloc_comp_no_caf with a default of false. Add prototype for gfc_copy_alloc_comp_no_fini. * trans-decl.cc(init_intent_out_dt): Tidy up the code. * trans-expr.cc (gfc_init_se): Initialize finalblock. (gfc_conv_procedure_call): Use gfc_finalize_tree_expr to finalize function results. Replace in-line block for class results with call to new function. (gfc_conv_expr): Finalize structure constructors for F2003 and F2008. Warn that this feature was deleted in F2018 and, unlike array constructors, is not default. Add array constructor finalblock to the post block. (gfc_trans_scalar_assign): Suppress finalization by setting new argument in call to gfc_deallocate_alloc_comp_no_caf. Add the finalization blocks to the main block. (gfc_trans_arrayfunc_assign): Use gfc_assignment_finalizer_call and ensure that finalization occurs after the evaluation of the rhs but using the initial value for the lhs. Finalize rhs function results using gfc_finalize_tree_expr. (trans_class_assignment, gfc_trans_assignment_1): As previous function, taking care to order evaluation, assignment and finalization correctly. * trans-io.cc (gfc_trans_transfer): Add the final block. * trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise. (trans_associate_var): Nullify derived allocatable components and finalize function targets with defined assignment components on leaving the block scope. (trans_allocate): Finalize source expressions, if required, and set init_expr artificial temporarily to suppress the finalization in gfc_trans_assignment. * trans.cc (gfc_add_finalizer_call): Do not finalize the temporaries generated in type assignment with defined assignment components. (gfc_assignment_finalizer_call): New function. (gfc_finalize_tree_expr): New function. * trans.h: Add finalblock to gfc_se. Add the prototypes for gfc_finalize_tree_expr and gfc_assignment_finalizer_call. gcc/testsuite/ PR fortran/64290 * gfortran.dg/finalize_38.f90 : New test. * gfortran.dg/finalize_38a.f90 : New test. * gfortran.dg/allocate_with_source_25.f90 : The number of final calls goes down from 6 to 4. * gfortran.dg/associate_25.f90 : Remove the incorrect comment. * gfortran.dg/auto_dealloc_2.f90 : Change the tree dump expr but the final count remains the same. * gfortran.dg/unlimited_polymorphic_8.f90 : Tree dump reveals foo.1.x rather than foo.0.x PR fortran/67444 * gfortran.dg/finalize_39.f90 : New test. PR fortran/67471 * gfortran.dg/finalize_40.f90 : New test. PR fortran/69298 PR fortran/70863 * gfortran.dg/finalize_41.f90 : New test. PR fortran/71798 * gfortran.dg/finalize_42.f90 : New test. PR fortran/80524 * gfortran.dg/finalize_43.f90 : New test. PR fortran/82996 * gfortran.dg/finalize_44.f90 : New test. PR fortran/84472 * gfortran.dg/finalize_45.f90 : New test. PR fortran/88735 PR fortran/93691 * gfortran.dg/finalize_46.f90 : New test. PR fortran/91316 * gfortran.dg/finalize_47.f90 : New test. PR fortran/106576 * gfortran.dg/finalize_48.f90 : New test. PR fortran/37336 * gfortran.dg/finalize_49.f90 : New test. * gfortran.dg/finalize_50.f90 : New test. * gfortran.dg/finalize_51.f90 : New test. 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" } }