From patchwork Thu Mar 15 11:13:34 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 146874 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 C5F24B6EEE for ; Thu, 15 Mar 2012 22:14:11 +1100 (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=1332414852; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=YMVn/s+ Y6lXjCIa6dv2S8NRqaM4=; b=fapwzdEb8Mv8P6ESgaB45LWTCM3jWsLGt+Fv4SE Nyy+Cz3ZHFvDX5mD28L+kiwxIPmL3z3TG/gnAVWumzOmU3Ows7xlxwvvSgAE0VF/ ak4vDk9HchnxYNNFvApgP5HQ1g7IYCNvDPJdY56X+yQ+zZz+4hV5WhIxQHiJMl94 z6wU= 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:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=Q5cWeRBqCA0ZGkYZFyF+NNgWF16iF3yTqJY0B4j3Wynqta2KufOtmepCVxLNN6 bgWC4+nP79WLwY+vj/fDU5OQ4wSAISlv1xIUGfDAUzGsmcembGlbHdfQGEBvg9wS Hq0DMM/rFgJqoZfriqUfJ6/7cDYCE4/q4gq8wwlysXy+E=; Received: (qmail 25047 invoked by alias); 15 Mar 2012 11:13:59 -0000 Received: (qmail 25031 invoked by uid 22791); 15 Mar 2012 11:13:57 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 15 Mar 2012 11:13:39 +0000 Received: from [192.168.178.22] (port-92-204-75-4.dynamic.qsc.de [92.204.75.4]) by mx01.qsc.de (Postfix) with ESMTP id 887E83CBED; Thu, 15 Mar 2012 12:13:35 +0100 (CET) Message-ID: <4F61CEDE.3000001@net-b.de> Date: Thu, 15 Mar 2012 12:13:34 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:10.0.2) Gecko/20120215 Thunderbird/10.0.2 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR52585 - Fix ASSOCIATE with proc-pointer dummies 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 A rather obvious patch: With proc-pointer dummies, one compared the address of the pointer and not of the pointer target. Build and regtested on x86-64-linux. OK for the trunk? (What's the sentiment regarding backporting to 4.7.1?) Tobias PS: The patch looks larger than it is: I converted some spaces into tabs. 2012-03-15 Tobias Burnus PR fortran/52585 * trans-intrinsic.c (gfc_conv_associated): Fix handling of procpointer dummy arguments. 2012-03-15 Tobias Burnus PR fortran/52585 * gfortran.dg/proc_ptr_36.f90: New. diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index ac9f507..2ec97c2 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5761,10 +5787,14 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) /* No optional target. */ if (ss1 == gfc_ss_terminator) { - /* A pointer to a scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - tmp2 = arg1se.expr; + /* A pointer to a scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + tmp2 = arg1se.expr; } else { @@ -5794,12 +5824,21 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) if (ss1 == gfc_ss_terminator) { - /* A pointer to a scalar. */ - gcc_assert (ss2 == gfc_ss_terminator); - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - arg2se.want_pointer = 1; - gfc_conv_expr (&arg2se, arg2->expr); + /* A pointer to a scalar. */ + gcc_assert (ss2 == gfc_ss_terminator); + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + + arg2se.want_pointer = 1; + gfc_conv_expr (&arg2se, arg2->expr); + if (arg2->expr->symtree->n.sym->attr.proc_pointer + && arg2->expr->symtree->n.sym->attr.dummy) + arg2se.expr = build_fold_indirect_ref_loc (input_location, + arg2se.expr); gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, --- /dev/null 2012-03-15 07:05:00.651809558 +0100 +++ /home/tob/projects/gcc-git/gcc/gcc/testsuite/gfortran.dg/proc_ptr_36.f90 2012-03-15 11:34:46.000000000 +0100 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! PR fortran/52585 +! +! Test proc-pointer dummies with ASSOCIATE +! +! Contributed by Mat Cross of NAG +! +module m0 + abstract interface + subroutine sub + end subroutine sub + end interface + interface + subroutine s(ss, isassoc) + import sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + end subroutine s + end interface +end module m0 + +use m0, only : sub, s +procedure(sub) :: sub2, pp +pointer :: pp +pp => sub2 +if (.not. associated(pp)) call abort () +if (.not. associated(pp,sub2)) call abort () +call s(pp, .true.) +pp => null() +if (associated(pp)) call abort () +if (associated(pp,sub2)) call abort () +call s(pp, .false.) +end + +subroutine s(ss, isassoc) + use m0, only : sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + procedure(sub) :: sub2 + if (isassoc .neqv. associated(ss)) call abort () + if (isassoc .neqv. associated(ss,sub2)) call abort () +end subroutine s + +subroutine sub2 +end subroutine sub2 + +! { dg-final { cleanup-modules "m0" } }