From patchwork Thu Apr 12 15:23:56 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 152095 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 0CEF4B7012 for ; Fri, 13 Apr 2012 01:25:00 +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=1334849101; 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=NZ0XabB j5JXrwVnV/Tde5fceeyI=; b=P+YEjmUfQOKemCN8N6jE1e+P2SfJo0T9Ncl5FhF 07zyjzjEoJt3/u0OAjkrDb26L7v89JnQfmGQhsq4UtkBQjpXy9iKvnxfVOMsoFMu 1Q2+jWyHWg5V/QsXJh1t1TwmkLk95Egd8XfrcpbwlVHm0nEOCyt6O9Q/lHHfu+mq UD2E= 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=tu4NNaaAlGOLgQsN43IAXPiWjgS4IIkMLqxQsnBr5ABHdqrIj/O64XqrQtIU/p m/dazDBqYMXAAQVXDd+4a0EfvDPh8btLPheLr+BkDt39zI6G1Z5dBovdddshTrdV bhoxkwGL4yvtHCU9GamE5IFD/sZzeOH/R4ZMIoWZSf/o8=; Received: (qmail 14516 invoked by alias); 12 Apr 2012 15:24:26 -0000 Received: (qmail 14376 invoked by uid 22791); 12 Apr 2012 15:24:22 -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, 12 Apr 2012 15:24:05 +0000 Received: from [192.168.178.22] (port-92-204-5-234.dynamic.qsc.de [92.204.5.234]) by mx01.qsc.de (Postfix) with ESMTP id DA07F3CB76; Thu, 12 Apr 2012 17:23:58 +0200 (CEST) Message-ID: <4F86F38C.8050702@net-b.de> Date: Thu, 12 Apr 2012 17:23:56 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:11.0) Gecko/20120328 Thunderbird/11.0.1 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR52864 - fix actual/formal checks 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 This patch is a kind of follow up to the other one for the same PR - though this one is for a separate test case, it is not a regression and it's about actual/formal checks. When trying to fix the rejects-valid bug, I realized that one function was never accessed as a call to expr.c's gfc_check_vardef_context is done before. I made some cleanup and added some code to ensure pointer CLASS are correctly handled. I am not positive that the removed code is unreachable, but I failed to produce reachable code and also the test suit passed. Thus, this patch removed a rejects-valid bug, an accepts-invalid bug, cleans up the code a bit and adds a test case for existing checks (besides testing the bug fixes). Build and regtested on x86-64-linux. OK for the trunk? Tobias 20012-04-12 Tobias Burnus PR fortran/52864 * interface.c (compare_parameter_intent): Remove. (check_intents): Remove call, handle CLASS pointer. (compare_actual_formal): Handle CLASS pointer. 20012-04-12 Tobias Burnus PR fortran/52864 * gfortran.dg/pointer_intent_7.f90: New. * gfortran.dg/pure_formal_3.f90: New. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 298ae23..3c8f9cb 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2504,7 +2520,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, ? _("actual argument to INTENT = OUT/INOUT") : NULL); - if (f->sym->attr.pointer + if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) && gfc_check_vardef_context (a->expr, true, false, context) == FAILURE) return 0; @@ -2799,25 +2817,6 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) } -/* Given a symbol of a formal argument list and an expression, - return nonzero if their intents are compatible, zero otherwise. */ - -static int -compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual) -{ - if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer) - return 1; - - if (actual->symtree->n.sym->attr.intent != INTENT_IN) - return 1; - - if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT) - return 0; - - return 1; -} - - /* Given formal and actual argument lists that correspond to one another, check that they are compatible in the sense that intents are not mismatched. */ @@ -2839,25 +2838,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) f_intent = f->sym->attr.intent; - if (!compare_parameter_intent(f->sym, a->expr)) - { - gfc_error ("Procedure argument at %L is INTENT(IN) while interface " - "specifies INTENT(%s)", &a->expr->where, - gfc_intent_string (f_intent)); - return FAILURE; - } - if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym)) { - if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) - { - gfc_error ("Procedure argument at %L is local to a PURE " - "procedure and is passed to an INTENT(%s) argument", - &a->expr->where, gfc_intent_string (f_intent)); - return FAILURE; - } - - if (f->sym->attr.pointer) + if ((f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym) + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) { gfc_error ("Procedure argument at %L is local to a PURE " "procedure and has the POINTER attribute", @@ -2877,7 +2862,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) return FAILURE; } - if (f->sym->attr.pointer) + if ((f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym) + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) { gfc_error ("Coindexed actual argument at %L in PURE procedure " "is passed to a POINTER dummy argument", --- /dev/null 2012-04-12 06:55:49.927755790 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pointer_intent_7.f90 2012-04-12 12:21:37.000000000 +0200 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! PR fortran/ +! +! Contributed by Neil Carlson +! +! Check whether passing an intent(in) pointer +! to an intent(inout) nonpointer is allowed +! +module modA + type :: typeA + integer, pointer :: ptr + end type +contains + subroutine foo (a,b,c) + type(typeA), intent(in) :: a + type(typeA), intent(in) , pointer :: b + class(typeA), intent(in) , pointer :: c + + call bar (a%ptr) + call bar2 (b) + call bar3 (b) + call bar2 (c) + call bar3 (c) + call bar2p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + call bar3p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + call bar2p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + call bar3p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + end subroutine + subroutine bar (n) + integer, intent(inout) :: n + end subroutine + subroutine bar2 (n) + type(typeA), intent(inout) :: n + end subroutine + subroutine bar3 (n) + class(typeA), intent(inout) :: n + end subroutine + subroutine bar2p (n) + type(typeA), intent(inout), pointer :: n + end subroutine + subroutine bar3p (n) + class(typeA), intent(inout), pointer :: n + end subroutine +end module --- /dev/null 2012-04-12 06:55:49.927755790 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pure_formal_3.f90 2012-04-12 16:05:46.000000000 +0200 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Clean up, made when working on PR fortran/52864 +! +! Test some PURE and intent checks - related to pointers. +module m + type t + end type t + integer, pointer :: x + class(t), pointer :: y +end module m + +pure subroutine foo() + use m + call bar(x) ! { dg-error "can not appear in a variable definition context" } + call bar2(x) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" } + call bb(y) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" } +contains + pure subroutine bar(x) + integer, pointer, intent(inout) :: x + end subroutine + pure subroutine bar2(x) + integer, pointer :: x + end subroutine + pure subroutine bb(x) + class(t), pointer, intent(in) :: x + end subroutine +end subroutine