From patchwork Sun Aug 26 15:54:49 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 962273 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-484455-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="ieVItWjg"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.b="PaSQElro"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 41z03H4H3cz9s4c for ; Mon, 27 Aug 2018 01:55:21 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:cc:content-type; q=dns; s=default; b=ZsjWEFpy0fV9ujA+tW9G+itR1cWgYitaiDWfK46EzuR 8wVp7Cyu6FvoQ+MLo5fl9atRpoDNM1Il/C7IWJCvNGauudUtT0ykdWTtJHCCz9qU Q+/ziMucBQungJUHJ/eZCPC/nqUChD33cnZjuwwMuGKh6uHiaLahqpjmpkqe4/V8 = DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:cc:content-type; s=default; bh=2ma6RAcAn51qUTgZKlkWCCel2/g=; b=ieVItWjguHTrJRJ6X vxCKSbw+hp8J3HUQJzq2xObuO6BY0dqSQZdZLh3+Xe+kTovPgGR8fWkktFZFIawD fmqwEs7T6tjTPGZ/hlnROt4ZxRcNTnERbrRced4yy81Xte6o0FuBrp3smfL7SG41 YOl7ETyTryZLaYf+4honhD0BiQ= Received: (qmail 6991 invoked by alias); 26 Aug 2018 15:55:07 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 6957 invoked by uid 89); 26 Aug 2018 15:55:07 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-4.3 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_2, KAM_ASCII_DIVIDERS, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=mold, rich, H*Ad:U*janus, filling X-HELO: mail-yb0-f182.google.com Received: from mail-yb0-f182.google.com (HELO mail-yb0-f182.google.com) (209.85.213.182) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 26 Aug 2018 15:55:03 +0000 Received: by mail-yb0-f182.google.com with SMTP id l16-v6so5174965ybk.11; Sun, 26 Aug 2018 08:55:03 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=mime-version:from:date:message-id:subject:to:cc; bh=hLevc+4O4DS1PQyQEmdda7np3TX1l9/5yu4PDz4u3tE=; b=PaSQElrooWycknbraiN++A4nhAzvQSueXFIHRqwUW0MNCsHH3Ks5711VzptIXDdcfs FMlas+DKxx+qI8JG7FQNsJ0IA8ojkNLWIZLjfMHSuFF1UVUrZTegEz54BkMgPJGemdaG Ms19y3oAixWVFHat57xbbpN1gGe+Lnv2s5kVilWZyXzl6rrobnqPpw40N14913PD4+Ot 5/BkKnHJ6DzfVrNpWX72G7R8nlefv8bZYznlWuepMIT8d/IGZvaRxB/KZ8pZXU119GeT bZyJoVBT4iCCC6XkUOI72iKd5YyLbYj6vzk+uVJtpCVWcr/uGB39G11CaMANuFwbUWbp ct5A== MIME-Version: 1.0 From: Paul Richard Thomas Date: Sun, 26 Aug 2018 16:54:49 +0100 Message-ID: Subject: [Patch, fortran] PRs 80477 and 86481 - memory leaks following function calls. To: "fortran@gcc.gnu.org" , gcc-patches Cc: Janus Weil This patch grew from the original patch for PR80477 because it was found that the array valued version leaked memory as well. Then, I found that the assignment in class_result_9.f90 ICEd, while trying to fix the array valued test, class_result_8.f90. Finally, while I was about it, I fixed PR86481, which is similar but involves cleaning up of the source expression after allocation. Most of the time was spent on persuading the final calls to appear in the right place. All the tests have been checked with valgrind. Bootstrapped and regtested on FC28/x86_64 - OK for trunk? Cheers Paul 2017-08-26 Paul Thomas PR fortran/80477 * trans-expr.c (gfc_conv_procedure_call): Allocatable class scalar results being passed to a derived type formal argument are finalized if possible. Otherwise, rely on existing code for deallocation. Make the deallocation of allocatable result components conditional on finalization not taking place. Make the freeing of data components after finalization conditional on the data being NULL. (gfc_trans_arrayfunc_assign): Change the gcc_assert to a condition to return NULL_TREE. (gfc_trans_assignment_1): If the assignment is class to class and the rhs expression must be finalized but the assignment is not marked as a polymorphic assignment, use the vptr copy function instead of gfc_trans_scalar_assign. PR fortran/86481 * trans-expr.c (gfc_conv_expr_reference): Do not add the post block to the pre block if the expression is to be finalized. * trans-stmt.c (gfc_trans_allocate): If the expr3 must be finalized, load the post block into a finalization block and add it right at the end of the allocation block. 2017-08-26 Paul Thomas PR fortran/80477 * gfortran.dg/class_result_7.f90: New test. * gfortran.dg/class_result_8.f90: New test. * gfortran.dg/class_result_9.f90: New test. PR fortran/86481 * gfortran.dg/allocate_with_source_25.f90: New test. Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 263798) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_procedure_call (gfc_se * se, gf *** 4886,4891 **** --- 4886,4893 ---- for (arg = args, argc = 0; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { + bool finalized = false; + e = arg->expr; fsym = formal ? formal->sym : NULL; parm_kind = MISSING; *************** gfc_conv_procedure_call (gfc_se * se, gf *** 5360,5366 **** && e->ts.type == BT_CLASS && !CLASS_DATA (e)->attr.dimension && !CLASS_DATA (e)->attr.codimension) ! parmse.expr = gfc_class_data_get (parmse.expr); /* Wrap scalar variable in a descriptor. We need to convert the address of a pointer back to the pointer itself before, --- 5362,5403 ---- && e->ts.type == BT_CLASS && !CLASS_DATA (e)->attr.dimension && !CLASS_DATA (e)->attr.codimension) ! { ! parmse.expr = gfc_class_data_get (parmse.expr); ! /* The result is a class temporary, whose _data component ! must be freed to avoid a memory leak. */ ! if (e->expr_type == EXPR_FUNCTION ! && CLASS_DATA (e)->attr.allocatable) ! { ! tree zero; ! ! gfc_expr *var; ! ! /* Borrow the function symbol to make a call to ! gfc_add_finalizer_call and then restore it. */ ! tmp = e->symtree->n.sym->backend_decl; ! e->symtree->n.sym->backend_decl ! = TREE_OPERAND (parmse.expr, 0); ! e->symtree->n.sym->attr.flavor = FL_VARIABLE; ! var = gfc_lval_expr_from_sym (e->symtree->n.sym); ! finalized = gfc_add_finalizer_call (&parmse.post, ! var); ! gfc_free_expr (var); ! e->symtree->n.sym->backend_decl = tmp; ! e->symtree->n.sym->attr.flavor = FL_PROCEDURE; ! ! /* Then free the class _data. */ ! zero = build_int_cst (TREE_TYPE (parmse.expr), 0); ! tmp = fold_build2_loc (input_location, NE_EXPR, ! logical_type_node, ! parmse.expr, zero); ! tmp = build3_v (COND_EXPR, tmp, ! gfc_call_free (parmse.expr), ! build_empty_stmt (input_location)); ! gfc_add_expr_to_block (&parmse.post, tmp); ! gfc_add_modify (&parmse.post, parmse.expr, zero); ! } ! } /* Wrap scalar variable in a descriptor. We need to convert the address of a pointer back to the pointer itself before, *************** gfc_conv_procedure_call (gfc_se * se, gf *** 5687,5695 **** tmp = build_fold_indirect_ref_loc (input_location, tmp); } ! tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank); ! ! gfc_prepend_expr_to_block (&post, tmp); } /* Add argument checking of passing an unallocated/NULL actual to --- 5724,5741 ---- tmp = build_fold_indirect_ref_loc (input_location, tmp); } ! if (!finalized && !e->must_finalize) ! { ! if ((e->ts.type == BT_CLASS ! && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) ! || e->ts.type == BT_DERIVED) ! tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, ! parm_rank); ! else if (e->ts.type == BT_CLASS) ! tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived, ! tmp, parm_rank); ! gfc_prepend_expr_to_block (&post, tmp); ! } } /* Add argument checking of passing an unallocated/NULL actual to *************** gfc_conv_procedure_call (gfc_se * se, gf *** 6410,6416 **** 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, --- 6456,6462 ---- 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, *************** gfc_conv_procedure_call (gfc_se * se, gf *** 6420,6447 **** 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_add_expr_to_block (&se->ss->loop->post, tmp); ! tmp = gfc_call_free (info->data); gfc_add_expr_to_block (&se->ss->loop->post, tmp); } else { ! gfc_add_expr_to_block (&se->post, tmp); ! tmp = gfc_class_data_get (se->expr); ! tmp = gfc_call_free (tmp); gfc_add_expr_to_block (&se->post, tmp); } - - no_finalization: - expr->must_finalize = 0; } gfc_add_block_to_block (&se->post, &post); } --- 6466,6508 ---- 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); } } + no_finalization: gfc_add_block_to_block (&se->post, &post); } *************** gfc_conv_expr_reference (gfc_se * se, gf *** 8072,8078 **** var = gfc_create_var (TREE_TYPE (se->expr), NULL); gfc_add_modify (&se->pre, var, se->expr); } ! gfc_add_block_to_block (&se->pre, &se->post); /* Take the address of that value. */ se->expr = gfc_build_addr_expr (NULL_TREE, var); --- 8133,8141 ---- var = gfc_create_var (TREE_TYPE (se->expr), NULL); gfc_add_modify (&se->pre, var, se->expr); } ! ! if (!expr->must_finalize) ! gfc_add_block_to_block (&se->pre, &se->post); /* Take the address of that value. */ se->expr = gfc_build_addr_expr (NULL_TREE, var); *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 9262,9271 **** /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ comp = gfc_get_proc_ptr_comp (expr2); ! gcc_assert (expr2->value.function.isym || (comp && comp->attr.dimension) || (!comp && gfc_return_by_reference (expr2->value.function.esym) ! && expr2->value.function.esym->result->attr.dimension)); gfc_init_se (&se, NULL); gfc_start_block (&se.pre); --- 9325,9336 ---- /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ comp = gfc_get_proc_ptr_comp (expr2); ! ! if (!(expr2->value.function.isym || (comp && comp->attr.dimension) || (!comp && gfc_return_by_reference (expr2->value.function.esym) ! && expr2->value.function.esym->result->attr.dimension))) ! return NULL; gfc_init_se (&se, NULL); gfc_start_block (&se.pre); *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 10238,10243 **** --- 10303,10310 ---- gfc_add_block_to_block (&loop.post, &rse.post); } + tmp = NULL_TREE; + if (is_poly_assign) tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, use_vptr_copy || (lhs_attr.allocatable *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 10266,10278 **** code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); tmp = gfc_conv_intrinsic_subroutine (&code); } ! else tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, gfc_expr_is_variable (expr2) || scalar_to_array || expr2->expr_type == EXPR_ARRAY, !(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); gfc_add_block_to_block (&body, &lse.pre); --- 10333,10367 ---- code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); tmp = gfc_conv_intrinsic_subroutine (&code); } ! else if (!is_poly_assign && expr2->must_finalize ! && expr1->ts.type == BT_CLASS ! && expr2->ts.type == BT_CLASS) ! { ! /* This case comes about when the scalarizer provides array element ! references. Use the vptr copy function, since this does a deep ! copy of allocatable components, without which the finalizer call */ ! tmp = gfc_get_vptr_from_expr (rse.expr); ! if (tmp != NULL_TREE) ! { ! tree fcn = gfc_vptr_copy_get (tmp); ! if (POINTER_TYPE_P (TREE_TYPE (fcn))) ! fcn = build_fold_indirect_ref_loc (input_location, fcn); ! tmp = build_call_expr_loc (input_location, ! fcn, 2, ! gfc_build_addr_expr (NULL, rse.expr), ! gfc_build_addr_expr (NULL, lse.expr)); ! } ! } ! ! /* If nothing else works, do it the old fashioned way! */ ! if (tmp == NULL_TREE) tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, gfc_expr_is_variable (expr2) || scalar_to_array || expr2->expr_type == EXPR_ARRAY, !(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); gfc_add_block_to_block (&body, &lse.pre); Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 263798) --- gcc/fortran/trans-stmt.c (working copy) *************** gfc_trans_allocate (gfc_code * code) *** 5783,5788 **** --- 5783,5789 ---- enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; + stmtblock_t final_block; tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; bool needs_caf_sync, caf_refs_comp; *************** gfc_trans_allocate (gfc_code * code) *** 5801,5806 **** --- 5802,5808 ---- gfc_init_block (&block); gfc_init_block (&post); + gfc_init_block (&final_block); /* STAT= (and maybe ERRMSG=) is present. */ if (code->expr1) *************** gfc_trans_allocate (gfc_code * code) *** 5842,5847 **** --- 5844,5854 ---- is_coarray = gfc_is_coarray (code->expr3); + if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold + && (gfc_is_class_array_function (code->expr3) + || gfc_is_alloc_class_scalar_function (code->expr3))) + code->expr3->must_finalize = 1; + /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; al = al->next) *************** gfc_trans_allocate (gfc_code * code) *** 5914,5920 **** temp_obj_created = temp_var_needed = !VAR_P (se.expr); } gfc_add_block_to_block (&block, &se.pre); ! gfc_add_block_to_block (&post, &se.post); /* Special case when string in expr3 is zero. */ if (code->expr3->ts.type == BT_CHARACTER --- 5921,5930 ---- temp_obj_created = temp_var_needed = !VAR_P (se.expr); } gfc_add_block_to_block (&block, &se.pre); ! if (code->expr3->must_finalize) ! gfc_add_block_to_block (&final_block, &se.post); ! else ! gfc_add_block_to_block (&post, &se.post); /* Special case when string in expr3 is zero. */ if (code->expr3->ts.type == BT_CHARACTER *************** gfc_trans_allocate (gfc_code * code) *** 6743,6748 **** --- 6753,6760 ---- gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &post); + if (code->expr3 && code->expr3->must_finalize) + gfc_add_block_to_block (&block, &final_block); return gfc_finish_block (&block); } Index: gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 =================================================================== *** gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 (working copy) *************** *** 0 **** --- 1,71 ---- + ! { dg-do compile } + ! { dg-options "-fdump-tree-original" } + ! + ! Test the fix for PR86481 + ! + ! Contributed by Rich Townsend + ! + program simple_leak + + implicit none + + type, abstract :: foo_t + end type foo_t + + type, extends(foo_t) :: foo_a_t + real(8), allocatable :: a(:) + end type foo_a_t + + type, extends(foo_t) :: bar_t + class(foo_t), allocatable :: f + end type bar_t + + integer, parameter :: N = 2 + integer, parameter :: D = 3 + + type(bar_t) :: b(N) + integer :: i + + do i = 1, N + b(i) = func_bar(D) + end do + + do i = 1, N + deallocate (b(i)%f) + end do + + contains + + function func_bar (D) result (b) + + integer, intent(in) :: D + type(bar_t) :: b + + allocate(b%f, SOURCE=func_foo(D)) + + end function func_bar + + !**** + + function func_foo (D) result (f) + + integer, intent(in) :: D + class(foo_t), allocatable :: f + + allocate(f, SOURCE=func_foo_a(D)) ! Lose one of these for each allocation + + end function func_foo + + !**** + + function func_foo_a (D) result (f) + + integer, intent(in) :: D + type(foo_a_t) :: f + + allocate(f%a(D)) ! Lose one of these for each allocation => N*D*elem_size(f%a) + + end function func_foo_a + + end program simple_leak + ! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } } Index: gcc/testsuite/gfortran.dg/class_result_7.f90 =================================================================== *** gcc/testsuite/gfortran.dg/class_result_7.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/class_result_7.f90 (working copy) *************** *** 0 **** --- 1,36 ---- + ! { dg-do compile } + ! { dg-options "-fdump-tree-original" } + ! + ! Test the fix for PR80477 + ! + ! Contributed by Stefano Zaghi + ! + module a_type_m + implicit none + type :: a_type_t + real :: x + endtype + contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs + lhs%x = rhs%x + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res + allocate (a_type_t :: res) + res%x = lhs%x + rhs%x + end function + end module + + program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + call assign_a_type (a, add_a_type(a,b)) ! generated a memory leak + end + ! { dg-final { scan-tree-dump-times "builtin_free" 1 "original" } } + ! { dg-final { scan-tree-dump-times "builtin_malloc" 1 "original" } } Index: gcc/testsuite/gfortran.dg/class_result_8.f90 =================================================================== *** gcc/testsuite/gfortran.dg/class_result_8.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/class_result_8.f90 (working copy) *************** *** 0 **** --- 1,41 ---- + ! { dg-do compile } + ! { dg-options "-fdump-tree-original" } + ! + ! Test the fix for the array version of PR80477 + ! + ! Contributed by Stefano Zaghi + ! + module a_type_m + implicit none + type :: a_type_t + real :: x + real, allocatable :: y(:) + endtype + contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs(:) + lhs%x = rhs(1)%x + rhs(2)%x + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res(:) + allocate (a_type_t :: res(2)) + allocate (res(1)%y(1)) + allocate (res(2)%y(1)) + res(1)%x = lhs%x + res(2)%x = rhs%x + end function + end module + + program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + call assign_a_type (a, add_a_type(a,b)) + print *, a%x + end + ! { dg-final { scan-tree-dump-times "builtin_free" 6 "original" } } + ! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } } Index: gcc/testsuite/gfortran.dg/class_result_9.f90 =================================================================== *** gcc/testsuite/gfortran.dg/class_result_9.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/class_result_9.f90 (working copy) *************** *** 0 **** --- 1,45 ---- + ! { dg-do run } + ! + ! Test the fix for an additional bug found while fixing PR80477 + ! + ! Contributed by Paul Thomas + ! + module a_type_m + implicit none + type :: a_type_t + real :: x + real, allocatable :: y(:) + endtype + contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs(:) + lhs%x = rhs(1)%x + rhs(2)%x + lhs%y = rhs(1)%y + rhs(2)%y + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res(:) + allocate (a_type_t :: res(2)) + allocate (res(1)%y(1), source = [10.0]) + allocate (res(2)%y(1), source = [20.0]) + res(1)%x = lhs%x + rhs%x + res(2)%x = rhs%x + rhs%x + end function + end module + + program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + class(a_type_t), allocatable :: res(:) + + res = add_a_type(a,b) ! Remarkably, this ICEd - found while debugging the PR. + call assign_a_type (a, res) + if (int (res(1)%x + res(2)%x) .ne. int (a%x)) stop 1 + if (int (sum (res(1)%y + res(2)%y)) .ne. int (sum (a%y))) stop 1 + deallocate (a%y) + deallocate (res) + end