From patchwork Mon Aug 13 13:37:59 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 176942 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]) by ozlabs.org (Postfix) with SMTP id 69CDE2C008C for ; Mon, 13 Aug 2012 23:38:30 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1345469911; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:Date:Message-ID:Subject:From:To: Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=xm6Sw21 156LQ0ogkXyFir9u7V3I=; b=b55xbd37pNGjfm29eCsfWK8ITGgjAkqtWsl0B34 STeQcz2dm7NZe1hh7VJIWx+jKKMXWvFA061oOfBghZ1RV+/Eirofrfy3nxcggg96 xPSEZbo+b/9zEPAA/fHvxZ+UdJPDHpoZ2CQForhoynjWsWWhAoQYysJwdo/EwA7X RK6M= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:MIME-Version:Received:Received:Date:Message-ID:Subject:From:To:Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=t5s8lUQ9hwxtcNgRGTOU3guVoAGMx6845JpDqUTTByXYTlVLd/wzmHNMj/4yQx 19DvAr3splrI7KGbOxfpVTXZ5SBNUg/SD0cyuCQ4WwlPjwJ2u1MvAsKqMqB44Trv zT9M6pCL6UhmnfTJOpDCXa5GM8ARgUssn6IELCqVQeAIs=; Received: (qmail 27807 invoked by alias); 13 Aug 2012 13:38:22 -0000 Received: (qmail 27784 invoked by uid 22791); 13 Aug 2012 13:38:19 -0000 X-SWARE-Spam-Status: No, hits=-4.0 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, KHOP_RCVD_TRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_YE X-Spam-Check-By: sourceware.org Received: from mail-ob0-f175.google.com (HELO mail-ob0-f175.google.com) (209.85.214.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 13 Aug 2012 13:38:00 +0000 Received: by obc16 with SMTP id 16so7411137obc.20 for ; Mon, 13 Aug 2012 06:37:59 -0700 (PDT) MIME-Version: 1.0 Received: by 10.182.72.9 with SMTP id z9mr11858435obu.5.1344865079690; Mon, 13 Aug 2012 06:37:59 -0700 (PDT) Received: by 10.182.22.73 with HTTP; Mon, 13 Aug 2012 06:37:59 -0700 (PDT) Date: Mon, 13 Aug 2012 15:37:59 +0200 Message-ID: Subject: [Patch, fortran] PR46897 - [OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign From: Paul Richard Thomas To: "fortran@gcc.gnu.org" , gcc-patches Cc: Tobias Burnus , Alessandro Fanfarillo , "Rouson, Damian" 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 Dear All, Please find attached a patch and testcase for the above PR. The comment before generate_component_assignments explains the need for the patch, which itself is fairly self explanatory. Bootstrapped and regtested on Fc9/x86_64 - OK for trunk? Best regards Paul and Alessandro. 2012-08-13 Alessandro Fanfarillo Paul Thomas PR fortran/46897 * resolve.c (add_comp_ref): New function. (generate_component_assignments): New function that calls add_comp_ref. (resolve_code): Call generate_component_assignments. 2012-08-13 Alessandro Fanfarillo Paul Thomas PR fortran/46897 * gfortran.dg/defined_assignment_1.f90: New test. Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 190338) --- gcc/fortran/resolve.c (working copy) *************** resolve_ordinary_assign (gfc_code *code, *** 9485,9490 **** --- 9485,9614 ---- } + /* Add a component reference onto an expression. */ + + static void + add_comp_ref (gfc_expr *e, gfc_component *c) + { + gfc_ref **ref; + ref = &(e->ref); + while (*ref) + ref = &((*ref)->next); + *ref = gfc_get_ref(); + (*ref)->type = REF_COMPONENT; + (*ref)->u.c.sym = c->ts.u.derived; + (*ref)->u.c.component = c; + e->ts = c->ts; + } + + + /* Implement 7.2.1.3 of the F08 standard: + "An intrinsic assignment where the variable is of derived type is + performed as if each component of the variable were assigned from the + corresponding component of expr using pointer assignment (7.2.2) for + each pointer component, defined assignment for each nonpointer + nonallocatable component of a type that has a type-bound defined + assignment consistent with the component, intrinsic assignment for + each other nonpointer nonallocatable component, ..." + + The pointer assignments are taken care of by the intrinsic + assignment of the structure itself. This function recursively adds + defined assignments where required. */ + + static void + generate_component_assignments (gfc_code **code, gfc_namespace *ns) + { + gfc_component *comp1, *comp2; + gfc_code *this_code, *next, *root, *previous; + + /* Filter out continuing processing after an error. */ + if ((*code)->expr1->ts.type != BT_DERIVED + || (*code)->expr2->ts.type != BT_DERIVED) + return; + + comp1 = (*code)->expr1->ts.u.derived->components; + comp2 = (*code)->expr2->ts.u.derived->components; + + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) + { + if (comp1->ts.type != BT_DERIVED + || comp1->ts.u.derived == NULL + || (comp1->attr.pointer || comp1->attr.allocatable) + || (*code)->expr1->ts.u.derived == comp1->ts.u.derived) + continue; + + /* Make an assigment for this component. */ + this_code = gfc_get_code (); + this_code->op = EXEC_ASSIGN; + this_code->next = NULL; + this_code->expr1 = gfc_copy_expr ((*code)->expr1); + this_code->expr2 = gfc_copy_expr ((*code)->expr2); + + add_comp_ref (this_code->expr1, comp1); + add_comp_ref (this_code->expr2, comp2); + + root = this_code; + + /* Convert the assignment if there is a defined assignment for + this type. Otherwise, recurse into its components. */ + if (resolve_ordinary_assign (this_code, ns) + && this_code->op == EXEC_COMPCALL) + resolve_typebound_subroutine (this_code); + else if (this_code && this_code->op == EXEC_ASSIGN) + generate_component_assignments (&this_code, ns); + + previous = NULL; + this_code = root; + + /* Go through the code chain eliminating all but calls to + typebound procedures. Since we have been through + resolve_typebound_subroutine. */ + for (; this_code; this_code = this_code->next) + { + if (this_code->op == EXEC_ASSIGN_CALL) + { + gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym; + /* Check that there is a defined assignment. If so, then + resolve the call. */ + if (fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived + ->tb_op[INTRINSIC_ASSIGN]) + { + resolve_call (this_code); + goto next; + } + } + + next = this_code->next; + if (this_code == root) + root = next; + else + previous->next = next; + + next = this_code; + next->next = NULL; + gfc_free_statements (next); + next: + previous = this_code; + } + + /* Now attach the remaining code chain to the input code. Step on + to the end of the new code since resolution is complete. */ + if (root) + { + next = (*code)->next; + (*code)->next = root; + for (;root; root = root->next) + if (!root->next) + break; + root->next = next; + *code = root; + } + } + } + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ *************** resolve_code (gfc_code *code, gfc_namesp *** 9647,9652 **** --- 9771,9781 ---- else goto call; } + + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ + if (code->expr1->ts.type == BT_DERIVED) + generate_component_assignments (&code, ns); + break; case EXEC_LABEL_ASSIGN: Index: gcc/testsuite/gfortran.dg/defined_assignment_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/defined_assignment_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/defined_assignment_1.f90 (revision 0) *************** *** 0 **** --- 1,90 ---- + ! { dg-do run } + ! Test the fix for PR46897. + ! + ! Contributed by Rouson Damian + ! + module m0 + implicit none + type component + integer :: i + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo + end type + type, extends(parent) :: child + integer :: j + end type + contains + subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine + type(child) function new_child() + end function + end module + + module m1 + implicit none + type component + integer :: i + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type t + type(component) :: foo + end type + contains + subroutine assign1(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 21 + end subroutine + end module + + module m2 + implicit none + type component2 + integer :: i = 2 + end type + interface assignment(=) + module procedure assign2 + end interface + type t2 + type(component2) :: foo + end type + contains + subroutine assign2(lhs,rhs) + type(component2), intent(out) :: lhs + type(component2), intent(in) :: rhs + lhs%i = 22 + end subroutine + end module + + program main + use m0 + use m1 + use m2 + implicit none + type(child) :: infant0 + type(t) :: infant1, newchild1 + type(t2) :: infant2, newchild2 + + ! Test the reported problem. + infant0 = new_child() + if (infant0%parent%foo%i .ne. 20) call abort + + ! Test the case of comment #1 of the PR. + infant1 = newchild1 + if (infant1%foo%i .ne. 21) call abort + + ! Test the case of comment #2 of the PR. + infant2 = newchild2 + if (infant2%foo%i .ne. 2) call abort + end + +