From patchwork Thu Feb 3 17:14:43 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 50727 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 59EB93858426 for ; Thu, 3 Feb 2022 17:15:48 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 59EB93858426 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1643908548; bh=5wH9CZT+3KRg5ZLpZLo1C/HwU3lcbTbZbnl7aF+bdlo=; h=Date:Subject:To:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=GSTAZQM3yhQJChxiAuFZifTlgsThWgxFdHWAETJ1Qyn8NbwDFt6PxIkaUoWs4QXL/ aUQWGpK+Yu0PwcndM/y6n5XfEUUfBC1ZEvTYtkQD2UbrbCaJq/facbp4JyeWhbW6Kx 44MvoBxtK9xb+Pw6AffB1Po3LwVDKq/huxIiKH7Q= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-qt1-x834.google.com (mail-qt1-x834.google.com [IPv6:2607:f8b0:4864:20::834]) by sourceware.org (Postfix) with ESMTPS id B16B73858D35; Thu, 3 Feb 2022 17:14:55 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B16B73858D35 Received: by mail-qt1-x834.google.com with SMTP id e16so3212884qtq.6; Thu, 03 Feb 2022 09:14:55 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:mime-version:from:date:message-id:subject:to:cc; bh=NuwwKMhB6WUmA7ZCCAaZr9G3Khl5HhYvdgkm1m5tYz4=; b=QpymN800ce8hslZN6MzVB4KHeZxOxJJ5G2jGChcqM7RIdytEJhgNfv9WU0AA3+WviK /xyD6QyhNNEtd02CZz9vzElQtBp9SpVKad81kdGy2t2eRncNKnXbejDsmzmrG2Y48kpZ k28O5CWHvQMLOD50v6KU73gQO9Ohzdo2e9IlLh2rgJb+4MVqp6E5J2ZJKdzHPDX0qxhu cWG2xPrZk2nmiU4ovXtkA4oO7lxpXHelyyyd3x44QhAD1XxzRqCDEb2gkyv1PDytl/2S G1jb5pAbf2M75WXD5QzYLK5I/HE9RGqRI2ww3AwzEev9KMfXONkrqvWyMj8Xhn1ySrGJ IqrQ== X-Gm-Message-State: AOAM531QzN3jdBm9eDLksmbBLit5b0lTJ2TnW6Ibjc60Brvo1T58GvU9 7utLby5TLwZqjljyEXZymkNw6E8DQfcz78EM3OdMiLP2G+Q= X-Google-Smtp-Source: ABdhPJy+KA+J3anSY+T2ZwYQFrGo7p1WLH/dXOb3b79UyS8m37zLQncJss1iRZIhdrahj7nWCjXk/dlefWcq47HTvRk= X-Received: by 2002:a37:6393:: with SMTP id x141mr24567608qkb.197.1643908495041; Thu, 03 Feb 2022 09:14:55 -0800 (PST) MIME-Version: 1.0 Date: Thu, 3 Feb 2022 17:14:43 +0000 Message-ID: Subject: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-7.4 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, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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 Cc: Alessandro Fanfarillo , Andrew Benson Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch has been an excessively long time in coming. Please accept my apologies for that. All but two of the PR37336 dependencies are fixed, The two exceptions are PRs 59694 and 65347. The former involves lack of finalization of an unreferenced entity declared in a block, which I am sure is trivial but I cannot see where the missing trigger is, and the latter involves finalization of function results within an array constructor, for which I will submit an additional patch shortly. PR104272 also remains, in which finalization is occurring during allocation. I fixed this in one place but it seems to have crept out in another :-) Beyond this patch and ones for the three lagging PRs above, a thorough tidy up and unification of finalization is needed. However, I will concentrate on functionality in the first instance. I have tried to interpret F2018 7.5.6.2 and 7.5.6.3 as well as possible. This is not always straightforward and has involved a lot of head scratching! I have used the Intel compiler as a litmus test for the outcomes. This was largely motivated by the observation that, in the user survey conducted by Steve Lionel, gfortran and ifort are often used together . Therefore, quite aside from wishing to comply with the standard as far as possible, it is more than reasonable that the two compilers comply. On application of this patch, only exception to this is the treatment of finalization of arrays of extended types, where the Intel takes "If the entity is of extended type and the parent type is finalizable, the parent component is finalized" such that the parent component is finalized one element at a time, whereas gfortran finalises the parent components as an array. I strongly suspect that, from reading 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However, this is another issue to come back to in the future. The work centred on three areas: (i) Finalization on assignment: This was required because finalization of the lhs was occurring at the wrong time relative to evaluation of the rhs expression and was taking the finalization of entities with finalizable components in the wrong order. The changes in trans-array.cc (structure_alloc_comps) allow gfc_deallocate_alloc_comp_no_caf to occur without finalization so that it can be preceded by calls to the finalization wrapper. The other key change in this area is the addition of trans-expr.cc (gfc_assignment_finalizer_call), which manages the ordering of finalization and deallocation. (ii) Finalization of derived type function results. Previously, finalization was not occuring at all for derived type results but it did for class results. The former is now implemented in trans-expr.cc (finalize_function_result), into which the treatment of class finalization has been included. In order to handled complex expressions correctly, an extra block has been included in gfc_se and is initialized in gfc_init_se. This block accumulates the finalizations so that they can be added at the right time. It is the way in which I will fix PR65347 (I have already tested the principle). (iii) Minor fixes These include the changes in class.cc and the exclusion of artificial entities from finalization. There are some missing testcases (sorry Andrew and Sandro!), which might not be necessary because the broken/missing features are already fixed. The fact that the work correctly now is a strong indication that this is the case. Regtests OK on FC33/x86_64 - OK for mainline (and 11-branch)? Best regards Paul Fortran:Implement missing finalization features [PR37336] 2022-02-02 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. * resolve.cc (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. * trans-array.cc (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. Add a second, additional boolean argument to nullify pointer components and use it in gfc_copy_alloc_comp_del_ptrs. (gfc_alloc_allocatable_for_assignment): Suppress finalization by setting new arg in call to gfc_deallocate_alloc_comp_no_caf. (gfc_copy_alloc_comp_del_ptrs): New function. * 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_del_ptrs. * trans-expr.cc (gfc_init_se): Initialize finalblock. (finalize_function_result): New function that finalizes function results in the correct order. (gfc_conv_procedure_call): Use new function for finalizable function results. Replace in-line block for class results with call to new function. (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_assignment_finalizer_call): New function to provide finalization on intrinsic assignment. (trans_class_assignment, gfc_trans_assignment_1): Call it and add the block between the rhs evaluation and any reallocation on assignment that there might be. * trans-io.cc (gfc_trans_transfer): Add the final block. * trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise. * trans.cc (gfc_add_finalizer_call): Exclude artificial entities. * trans.h: Add finalblock to gfc_se. gcc/testsuite/ PR fortran/64290 * gfortran.dg/finalize_38.f90 : New test. * gfortran.dg/allocate_with_source_25.f90 : The number of final calls goes down from 6 to 4. 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. diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index 731e9b0fe6a..a249eea4a30 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. */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 835a4783718..fe17df2f73d 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -10512,6 +10512,10 @@ 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) + cnext->expr1->must_finalize = 1; + break; @@ -10599,6 +10603,10 @@ 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) + cnext->expr1->must_finalize = 1; + break; /* WHERE operator assignment statement */ @@ -10645,6 +10653,10 @@ 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) + c->expr1->must_finalize = 1; + break; case EXEC_ASSIGN_CALL: @@ -11324,6 +11336,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); @@ -12069,6 +12082,9 @@ start: && code->expr1->ts.u.derived->attr.defined_assign_comp) generate_component_assignments (&code, ns); + if (code->op == EXEC_ASSIGN) + code->expr1->must_finalize = 1; + break; case EXEC_LABEL_ASSIGN: diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index cfb6eac11c7..689628e1cb6 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); } @@ -7478,7 +7478,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) { @@ -8910,7 +8910,8 @@ gfc_caf_is_dealloc_only (int caf_mode) /* Recursively traverse an object of derived type, generating code to deallocate, nullify or copy allocatable components. This is the work horse - function for the functions named in this enum. */ + function for the functions named in this enum. When del_ptrs is set with + COPY_ALLOC_COMP, pointers are nullified. */ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, @@ -8920,9 +8921,11 @@ 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, + bool del_ptrs = false) { gfc_component *c; gfc_loopinfo loop; @@ -9010,11 +9013,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); @@ -9048,13 +9052,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); } @@ -9116,7 +9122,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 { @@ -9124,7 +9130,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); } } @@ -9240,8 +9247,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, @@ -9269,7 +9276,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 { @@ -9277,7 +9284,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); } } @@ -9575,7 +9583,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; @@ -9611,14 +9620,14 @@ 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); } } break; case COPY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) + if ((c->attr.pointer && !del_ptrs) || c->attr.proc_pointer) continue; /* We need source and destination components. */ @@ -9660,6 +9669,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dst_data = gfc_conv_descriptor_data_get (dst_data); } + if (CLASS_DATA (c)->attr.pointer) + { + gfc_add_modify (&fnblock, dst_data, + build_int_cst (TREE_TYPE (dst_data), 0)); + continue; + } + gfc_init_block (&tmpblock); gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), @@ -9706,6 +9722,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp, null_data)); continue; } + else if (c->attr.pointer) + { + if (c->attr.dimension) + tmp = gfc_conv_descriptor_data_get (dcmp); + else + tmp = dcmp; + gfc_add_modify (&fnblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + continue; + } + /* To implement guarded deep copy, i.e., deep copy only allocatable components that are really allocated, the deep copy code has to @@ -9719,7 +9746,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; @@ -10092,7 +10120,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); } @@ -10105,7 +10134,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 @@ -10143,7 +10173,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; } @@ -10153,10 +10184,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); } @@ -10164,7 +10197,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); } @@ -10180,6 +10214,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 deleting pointers and + suppressing any finalization that might occur. This is used in the + finaliztion of function results. */ + +tree +gfc_copy_alloc_comp_del_ptrs (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, true); +} + + /* Recursively traverse an object of derived type, generating code to copy only its allocatable components. */ @@ -10950,7 +10998,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); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 04fee617590..2743158cb11 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_del_ptrs (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-expr.cc b/gcc/fortran/trans-expr.cc index eb6a78c3a62..34ad867e041 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1904,6 +1904,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; @@ -5975,6 +5976,117 @@ post_call: } +/* Finalize a function result using the finalizer wrapper. The result is fixed + in order to prevent repeated calls. */ + +static void +finalize_function_result (gfc_se *se, gfc_symbol *derived, + symbol_attribute attr, int rank) +{ + tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr; + gfc_symbol *vtab; + gfc_se post_se; + bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)); + + if (attr.pointer) + 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 + { + desc = gfc_evaluate_now (se->expr, &se->pre); + se->expr = gfc_evaluate_now (desc, &se->pre); + /* Need to copy allocated components and delete pointer components. */ + gfc_add_expr_to_block (&se->pre, + gfc_copy_alloc_comp_del_ptrs (derived, desc, + se->expr, rank, 0)); + 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); + } + + 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)); + } + } + + tmp = gfc_create_var (TREE_TYPE (desc), "res"); + gfc_add_modify (&se->pre, tmp, desc); + desc = tmp; + + 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) + { + data_ptr = gfc_conv_descriptor_data_get (desc); + + gfc_add_expr_to_block (&se->loop->post, tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + data_ptr, + fold_convert (TREE_TYPE (data_ptr), + null_pointer_node)); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, + gfc_call_free (data_ptr), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->loop->post, tmp); + } + else + { + gfc_add_expr_to_block (&se->finalblock, tmp); + if (is_class) + { + data_ptr = gfc_conv_descriptor_data_get (desc); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + data_ptr, + fold_convert (TREE_TYPE (data_ptr), + null_pointer_node)); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, + gfc_call_free (data_ptr), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->finalblock, tmp); + } + } +} + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -7011,6 +7123,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 @@ -7675,9 +7788,17 @@ 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 + : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL); + bool finalizable = der != NULL && gfc_is_finalizable (der, NULL); + + if (!byref && finalizable) + finalize_function_result (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); @@ -7737,6 +7858,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) + finalize_function_result (se, der, attr, expr->rank); } else if (ts.type == BT_CHARACTER) { @@ -7829,8 +7953,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) { @@ -7852,66 +7974,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)) + finalize_function_result (se, NULL, attr, expr->rank); } - -no_finalization: gfc_add_block_to_block (&se->post, &post); } @@ -10430,7 +10501,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); @@ -10438,6 +10510,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, @@ -10469,6 +10542,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); tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr); gfc_add_modify (&block, lse->expr, tmp); @@ -10478,6 +10552,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)) { @@ -10872,6 +10947,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_function_expr (&se, expr2); gfc_add_block_to_block (&se.pre, &se.post); + gfc_add_block_to_block (&se.pre, &se.finalblock); if (ss) gfc_cleanup_loop (&loop); @@ -11387,6 +11463,96 @@ is_runtime_conformable (gfc_expr *expr1, 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 */ + +static tree +gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag) +{ + stmtblock_t final_block; + gfc_init_block (&final_block); + 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; + + /* 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 NULL_TREE; + + /* F2018 7.5.6.2: Only finalizable entities are finalized. */ + for (; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + return NULL_TREE; + + if (!(sym->ts.type == BT_CLASS + || (sym->ts.type == BT_DERIVED + && gfc_is_finalizable (sym->ts.u.derived, NULL))) + || !gfc_add_finalizer_call (&final_block, expr1)) + return NULL_TREE; + + 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)); + } + + return final_expr; +} + + static tree trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_se *lse, gfc_se *rse, bool use_vptr_copy, @@ -11394,6 +11560,16 @@ 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; + tree final_expr; + + final_expr = gfc_assignment_finalizer_call (lhs, false); + if (final_expr != NULL_TREE) + { + if (rse->loop) + gfc_prepend_expr_to_block (&rse->loop->pre, final_expr); + else + gfc_add_expr_to_block (block, final_expr); + } /* Store the old vptr so that dynamic types can be compared for reallocation to occur or not. */ @@ -11419,8 +11595,12 @@ 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; + if (TREE_CODE (lse->expr) == INDIRECT_REF) + tmp = TREE_OPERAND (lse->expr, 0); + else + tmp = lse->expr; + class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) + ? gfc_class_data_get (tmp) : tmp; /* Allocate block. */ gfc_init_block (&alloc); @@ -11519,6 +11699,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 @@ -11542,6 +11723,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tree tmp; stmtblock_t block; stmtblock_t body; + tree final_expr; bool l_is_temp; bool scalar_to_array; tree string_length; @@ -11582,6 +11764,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 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 @@ -11855,6 +12038,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 @@ -11900,6 +12085,32 @@ 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 (expr1, init_flag); + if (final_expr + && !(expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.artificial)) + { + if (lss == gfc_ss_terminator) + { + if (tmp != NULL_TREE && final_expr != NULL_TREE) + { + gfc_add_block_to_block (&block, &rse.pre); + gfc_add_expr_to_block (&block, final_expr); + } + else + gfc_add_expr_to_block (&lse.finalblock, final_expr); + } + else + { + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr); + } + } + 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, @@ -11909,12 +12120,18 @@ 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 (lss == gfc_ss_terminator) + { + 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) @@ -11979,6 +12196,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Wrap the whole thing up. */ gfc_add_block_to_block (&block, &loop.pre); gfc_add_block_to_block (&block, &loop.post); + gfc_add_block_to_block (&block, &rse.finalblock); gfc_cleanup_loop (&loop); } diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 732221f848b..bf4f0671585 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -2664,6 +2664,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 04f8147d23b..e0f513f8941 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -443,7 +443,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 @@ -542,6 +543,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); } @@ -6337,7 +6339,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); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 333dfa69642..fabdcde7267 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1242,6 +1242,9 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) return false; + if (gfc_expr_attr (expr2).artificial) + return false; + if (expr2->ts.type == BT_DERIVED) { gfc_is_finalizable (expr2->ts.u.derived, &final_expr); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 738c7487a56..72af54c4d29 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. */ 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" } }