From patchwork Mon Dec 19 11:43:43 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 707059 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 3thzbT28h6z9sf9 for ; Mon, 19 Dec 2016 22:44:20 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="CWuQPTVb"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=ABCLtPfSqcAegZo6/4/s5zb/cfrFTJAzJtbvzJsJVtM+Cb+wmShgF iPH+SYGhnzWcD5MuUDE30LtXOmi4E+DEzYn5E2Uo7fV1GRkA1DGIZIg7bJtHn/uL cLkZqdftFcwiZaQavlBY1AUMRYT1Q8Z/9sQIdu8Y7P+4SD7hOjjcrQ= 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:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=mquATwYdmYX32yvbz+ZwXF+ryEM=; b=CWuQPTVblbzIQBa3jy3U L+x2CSj2oBDjULugPQfSApjrS8E2Y8hGgnS4aq5SXt7tVJ47PxDBz6D/wkK6wKuu LnF6uMLz9RkUx7fsDAEHu6UHW3Kq4LjX99nsPg1NF6TFEBeg/RlrCjb7VicO/USv vb5Np7tspZYEx8vf5GNYd/o= Received: (qmail 30884 invoked by alias); 19 Dec 2016 11:44:05 -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 30750 invoked by uid 89); 19 Dec 2016 11:44:03 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, RCVD_IN_SORBS_SPAM, SPF_PASS autolearn=ham version=3.3.2 spammy=formerly, lss, H*F:D*gmx.de, andre X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 19 Dec 2016 11:43:53 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx103 [212.227.17.168]) with ESMTPSA (Nemesis) id 0LpbfG-1clxe32fri-00fNtQ; Mon, 19 Dec 2016 12:43:45 +0100 Date: Mon, 19 Dec 2016 12:43:43 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML , Damian Rouson Subject: [PATCH, Fortran, alloc_poly, v1] Fix allocation of memory for polymorphic assignment Message-ID: <20161219124343.3c3baf4c@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:FDzcDllrv9s=:xtR/8J66MAM8FmsUYtu6Wc YUx6oXVFf8JLbjipC0tuqvA9hoHVaZVof3b6BmysDM1+vtYF8d0iS04WzBNjXmoyC/pDlTVs3 +cLgc/Q6Y9W4Q34yi0IGYtEPJeo0E5xZfCaIygj2i768na6KlxwSybsKECFZvt6HHM9jRX0Jt 0xkqdM+DzWpulFVr3G7puXKO+QeYbGivSKjUc9RmiJfTTBMPloAK2qWdW5HLiuKvYwWRfc7Qf EyMLD/cc/cXXaMjTWBVW8pn94h4HnzbrbRtUS2JeJy74fiejNtgksDi1Q2QhOCvkLKaOMvaOt V1YN1wabD25nktozC6n83th7/Wz4ilQaSajY7DPJVqzD8L4j64od/yQ4jZtke2ptV4AITJHhr qej/jYZD2ThPiQkHyPOVW6eOs3cnsdbUsXhr+4qaGEuurxk7QLmz63BLaguSYxAuRdVDFupaQ rtDQOTgUvrtCB7cl7+XWOanWfsW4PYv9kZBzRrs1kcR5l57oS5Nii5WkFx1oNw+0b3YJrj8CS Uaei/R70H/RQzYJrbkfcoCYK4Zhe0zgYm4OvQrmRAuiinJUdSWgvE5K0KZePZYwOvHyigk9zi d1Fk6Qz+ssDMgjHoOXy7fI8CizN0W5BSvGL6f0FiF9khBay8tNRbwmVUt9kgNn3CTpC/SelR6 I0jBusgoLAgi/Ai+sQEwY72zraUQycRcEr0UVLGlyMkAHjbT9q36cnIMuFpBogpq6kXbmrnqB LSKXzUx/VC7WBYw6hV6ftvNCCz8uNNKiMnFY3B35L+r2hJOVFztvNBRVv9Q= Hi all, attached is a patch to fix the incorrect computation of memory needed in a polymorphic assignment. Formerly the memory required could not be determined and therefore one byte was allocated. This is fixed now, by retrieving the size needed from the _vptr->size. Bootstraps and regtests ok on x86_64-linux/f23. Ok for trunk? Regards, Andre diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 823c96a..5f84680 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -9968,7 +9968,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Modify the expr1 after the assignment, to allow the realloc below. Therefore only needed, when realloc_lhs is enabled. */ if (flag_realloc_lhs && !lhs_attr.pointer) - gfc_add_data_component (expr1); + { + stmtblock_t alloc; + tree tem, class_han = gfc_class_data_get (lse.expr); + if (GFC_CLASS_TYPE_P (TREE_TYPE (rse.expr))) + tem = gfc_class_vtab_size_get (rse.expr); + else + tem = gfc_vptr_size_get ( + gfc_build_addr_expr (NULL_TREE, + gfc_find_vtab (&expr2->ts)->backend_decl)); + gfc_init_block (&alloc); + gfc_allocate_using_malloc (&alloc, class_han, tem, NULL_TREE); + tem = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, class_han, + build_int_cst (prvoid_type_node, 0)); + tem = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (tem, + PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&alloc), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&lse.pre, tem); + } } else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension @@ -10011,7 +10031,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (lss == gfc_ss_terminator) { /* F2003: Add the code for reallocation on assignment. */ - if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)) + if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1) + && !is_poly_assign) alloc_scalar_allocatable_for_assignment (&block, string_length, expr1, expr2); diff --git a/gcc/testsuite/gfortran.dg/class_assign_1.f08 b/gcc/testsuite/gfortran.dg/class_assign_1.f08 new file mode 100644 index 0000000..fb1f655 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_assign_1.f08 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Check that reallocation of the lhs is done with the correct memory size. + + +module base_mod + + type, abstract :: base + contains + procedure(base_add), deferred :: add + generic :: operator(+) => add + end type base + + abstract interface + module function base_add(l, r) result(res) + class(base), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + end function base_add + end interface + +contains + + subroutine foo(x) + class(base), intent(inout), allocatable :: x + class(base), allocatable :: t + + t = x + 2 + x = t + 40 + end subroutine foo + +end module base_mod + +module extend_mod + use base_mod + + type, extends(base) :: extend + integer :: i + contains + procedure :: add + end type extend + +contains + module function add(l, r) result(res) + class(extend), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + select type (l) + class is (extend) + res = extend(l%i + r) + class default + error stop "Unkown class to add to." + end select + end function +end module extend_mod + +program test_poly_ass + use extend_mod + use base_mod + + class(base), allocatable :: obj + obj = extend(0) + call foo(obj) + select type (obj) + class is (extend) + if (obj%i /= 42) error stop + class default + error stop "Result's type wrong." + end select +end program test_poly_ass +