From patchwork Tue Sep 10 06:11:01 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 273766 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 CN "www.sourceware.org", Issuer "StartCom Class 1 Primary Intermediate Server CA" (not verified)) by ozlabs.org (Postfix) with ESMTPS id E8B402C00D1 for ; Tue, 10 Sep 2013 16:11:22 +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=q+okBxr37UO5N5H1h8LtbGUY5+osQ3Q6RLkI+3S9s8wlng NMlY/WNKqWsC/moDHP18NhmpnLyMi6x91rFiUU+or3tRcMEDdUEMuEsdOnVYPPx9 QXKO+qp+nj2d+1AKKG33MB/MHcNH0kM0jneLHUSI5P2NWa2g3ZF55gT/m94wA= 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=0JgANTn5cJquLgRDE34vt2bHUwo=; b=PviC3Scxy9eX/1OmrbSJ /1F2UNBclRpuAecY5SXOTV0RYctxkt1P2K0HGui4Pr56HGtZs0FFrbmOIDu6bS72 RaBMyw3jLkwl/ABzI7fbWW3lM2i0uKjYwPP8Ap1v5Z2Npyg9EDSx20PcR1Lw9KFV rZqRaQa6jZA13l7kIaWx2BY= Received: (qmail 2106 invoked by alias); 10 Sep 2013 06:11:08 -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 2083 invoked by uid 89); 10 Sep 2013 06:11:07 -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; Tue, 10 Sep 2013 06:11:07 +0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: Yes, score=6.1 required=5.0 tests=AWL, BAYES_00, KHOP_DYNAMIC, RCVD_IN_BRBL_LASTEXT, RCVD_IN_PBL, 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 94B273D69E; Tue, 10 Sep 2013 08:11:01 +0200 (CEST) Message-ID: <522EB7F5.10606@net-b.de> Date: Tue, 10 Sep 2013 08:11:01 +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 - Fix an issue with defined assignment Dear all, in Fortran 2003, it can happen that for an intrinisic assignment of a derived type, the component fits to a defined assignment; in that case, the latter is invoked. gfortran implements this since GCC 4.8 (December). However, it turned out that the current algorithm doesn't work if the LHS is allocatable and unallocated as it generated the following code: if (_F.DA0 != 0B) goto L.1; _F.DA0 = (struct parent *) __builtin_malloc (4); L.1:; *_F.DA0 = *left; if (left != 0B) goto L.3; left = (struct parent *) __builtin_malloc (4); L.3:; *left = right; The line "*_F.DA0 = *left;" will fail due to the NULL-pointer deref. With the attached patch, one generates the code: if (left != 0B) { if (_F.DA0 != 0B) goto L.2; _F.DA0 = (struct parent *) __builtin_malloc (4); L.2:; *_F.DA0 = *left; } L.1:; if (left != 0B) goto L.4; left = (struct parent *) __builtin_malloc (4); L.4:; *left = right; if (_F.DA0 == 0B) _F.DA0 = left; // Note: That's a pointer assignment Built and regtested on x86-64-gnu-linux. OK for the trunk? What about GCC 4.8? It's not a true regression (as defined assignments are new), but it causes segfaults with code which worked before GCC 4.8 [Dec 2012] (albeit with intrinsic instead of defined assignment). Tobias PS: One code which exposes the problem is a test case shipping with ForTrilinos. 2013-09-10 Tobias Burnus PR fortran/57697 * resolve.c (generate_component_assignments): Handle unallocated LHS with defined assignment of components. 2013-09-10 Tobias Burnus PR fortran/57697 * gfortran.dg/defined_assignment_10.f90: New. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2929679..f2892e2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9546,6 +9546,21 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) temp_code = build_assignment (EXEC_ASSIGN, t1, (*code)->expr1, NULL, NULL, (*code)->loc); + + /* For allocatable LHS, check whether it is allocated. */ + if (gfc_expr_attr((*code)->expr1).allocatable) + { + gfc_code *block; + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 + = gfc_build_intrinsic_call (ns, + GFC_ISYM_ASSOCIATED, "allocated", + (*code)->loc, 2, + gfc_copy_expr ((*code)->expr1), NULL); + block->block->next = temp_code; + temp_code = block; + } add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); } @@ -9554,6 +9569,31 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) gfc_free_expr (this_code->ext.actual->expr); this_code->ext.actual->expr = gfc_copy_expr (t1); add_comp_ref (this_code->ext.actual->expr, comp1); + + /* If the LHS is not allocated, we pointer-assign the LHS address + to the temporary - after the LHS has been allocated. */ + if (gfc_expr_attr((*code)->expr1).allocatable) + { + gfc_code *block; + gfc_expr *cond; + cond = gfc_get_expr (); + cond->ts.type = BT_LOGICAL; + cond->ts.kind = gfc_default_logical_kind; + cond->expr_type = EXPR_OP; + cond->where = (*code)->loc; + cond->value.op.op = INTRINSIC_NOT; + cond->value.op.op1 = gfc_build_intrinsic_call (ns, + GFC_ISYM_ASSOCIATED, "allocated", + (*code)->loc, 2, + gfc_copy_expr (t1), NULL); + 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, (*code)->expr1, + NULL, NULL, (*code)->loc); + add_code_to_chain (&block, &head, &tail); + } } } else if (this_code->op == EXEC_ASSIGN && !this_code->next) diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 new file mode 100644 index 0000000..c802118 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 @@ -0,0 +1,35 @@ +! { 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 + type(parent), allocatable :: left + type(parent) :: right + print *, right%foo + left = right + print *, left%foo + if (left%foo%i /= 20) call abort() +end