From patchwork Thu Sep 19 19:11:28 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 276048 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 8C6C72C00BC for ; Fri, 20 Sep 2013 05:11:47 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=wHJPqhUA7YJ0rz20PO5hn9SVBjc93AV4aszLDd6my7qaX+ vHDruJEEHMTtlYde6sdRgib8alZhIg78WWVNuAnThY7d0DW+bWJKR7ZLdpiYCRB3 uRLgb4oE+y7kEhHFTfOtCttN/KRfBHvs4zmpW/SQRenKPTq7JqL2rHDBx00Uk= 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 :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=54EjGERvqwrJA/Kyz26czGmORqY=; b=E5jgljKUnHpWDocWn3v9 Ff7EfSa7CsOMvLqj78ki+UFTl2CJjoaQiqaKLS7kBE1b8kVV7JOB7b60eoLcZ9hH P2IOKHG8ye0TFyLD+G2uU355BFv0PD/+UtpwBm/L7BW769XaMXZ1GTKA7C9/D8Fg p6UxclFXMRuF9rHa6looJqc= Received: (qmail 5423 invoked by alias); 19 Sep 2013 19:11:35 -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 5400 invoked by uid 89); 19 Sep 2013 19:11:34 -0000 Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Thu, 19 Sep 2013 19:11:34 +0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: Yes, score=5.1 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, KHOP_DYNAMIC, RCVD_IN_BRBL_LASTEXT, RCVD_IN_PBL, RCVD_IN_RP_RNBL, RCVD_IN_SEMBLACK, RCVD_IN_SORBS_DUL, RDNS_DYNAMIC autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from archimedes.net-b.de (port-92-194-31-5.dynamic.qsc.de [92.194.31.5]) by mx01.qsc.de (Postfix) with ESMTP id 809603D527; Thu, 19 Sep 2013 21:11:28 +0200 (CEST) Message-ID: <523B4C60.5050607@net-b.de> Date: Thu, 19 Sep 2013 21:11:28 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130801 Thunderbird/17.0.8 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR57697/58469 - Fix another defined-assignment issue This patch fixes two issues: a) It could happen that no code change has happened. In that case, the one freed an expression which still should be used. b) In my previous patch, I used a pointer assignment to the temporary of the LHS (after its allocation) [only if the LHS was initially unassigned]. That lead to a problem with double deallocation (temporary + LHS). In the previous test case, it didn't matter as the LHS wasn't freed (implicit SAVE of in the main program). That's now solved by a NULL-pointer assignment. Finally, I corrected some indenting issues and removed unreachable code. Build and regtested on x86-64-gnu-linux. OK for the trunk and the 4.8 branch? Tobias PS: For the testcase of (a), I am not quite sure whether the intrinsic assignment should invoke the defined assignment. It currently doesn't for gfortran and crayftn. In any case, the invalid freeing is wrong. 2013-09-19 Tobias Burnus PR fortran/57697 PR fortran/58469 * resolve.c (generate_component_assignments): Avoid double free at runtime and freeing a still-being used expr. 2013-09-19 Tobias Burnus PR fortran/57697 PR fortran/58469 * gfortran.dg/defined_assignment_8.f90: New. * gfortran.dg/defined_assignment_9.f90: New. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d33fe49..4befb9fd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9602,8 +9602,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) && gfc_expr_attr ((*code)->expr1).allocatable) { gfc_code *block; - gfc_expr *cond; - cond = gfc_get_expr (); + gfc_expr *cond; + + cond = gfc_get_expr (); cond->ts.type = BT_LOGICAL; cond->ts.kind = gfc_default_logical_kind; cond->expr_type = EXPR_OP; @@ -9621,7 +9622,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) add_code_to_chain (&block, &head, &tail); } } - } + } else if (this_code->op == EXEC_ASSIGN && !this_code->next) { /* Don't add intrinsic assignments since they are already @@ -9643,13 +9644,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) } } - /* This is probably not necessary. */ - if (this_code) - { - gfc_free_statements (this_code); - this_code = NULL; - } - /* Put the temporary assignments at the top of the generated code. */ if (tmp_head && component_assignment_level == 1) { @@ -9658,6 +9652,28 @@ 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 (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable + && gfc_expr_attr ((*code)->expr1).allocatable) + { + gfc_code *block; + gfc_expr *cond; + gfc_expr *e; + + e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); + cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", + (*code)->loc, 2, gfc_copy_expr (t1), e); + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 = cond; + block->block->next = build_assignment (EXEC_POINTER_ASSIGN, + t1, gfc_get_null_expr (&(*code)->loc), + NULL, NULL, (*code)->loc); + gfc_append_code (tail, block); + tail = block; + } + /* 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); @@ -9667,7 +9683,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) gfc_free_expr ((*code)->expr1); gfc_free_expr ((*code)->expr2); **code = *head; - free (head); + if (head != tail) + free (head); *code = tail; component_assignment_level--; diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 new file mode 100644 index 0000000..aab8085 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/58469 +! +! Related: PR fortran/57697 +! +! Was ICEing before +! +module m0 + implicit none + type :: component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type, extends(component) :: comp2 + real :: aa + end type comp2 + type parent + type(comp2) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + type(parent), allocatable :: left + type(parent) :: right + print *, right%foo + left = right + print *, left%foo + if (left%foo%i /= 42) call abort() +end diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 new file mode 100644 index 0000000..50fa007 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR fortran/57697 +! +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type parent + type(component) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + block + type(parent), allocatable :: left + type(parent) :: right +! print *, right%foo + left = right +! print *, left%foo + if (left%foo%i /= 20) call abort() + end block + block + type(parent), allocatable :: left(:) + type(parent) :: right(5) +! print *, right%foo + left = right +! print *, left%foo + if (any (left%foo%i /= 20)) call abort() + end block +end