From patchwork Tue Nov 29 18:32:58 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 128312 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 DA9CA1007D1 for ; Wed, 30 Nov 2011 05:33:21 +1100 (EST) Received: (qmail 18657 invoked by alias); 29 Nov 2011 18:33:17 -0000 Received: (qmail 18642 invoked by uid 22791); 29 Nov 2011 18:33:16 -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 mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 29 Nov 2011 18:33:00 +0000 Received: from [192.168.178.22] (port-92-204-12-48.dynamic.qsc.de [92.204.12.48]) by mx02.qsc.de (Postfix) with ESMTP id 0CC741E72A; Tue, 29 Nov 2011 19:32:58 +0100 (CET) Message-ID: <4ED5255A.5000407@net-b.de> Date: Tue, 29 Nov 2011 19:32:58 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:8.0) Gecko/20111105 Thunderbird/8.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] [4.6/4.7] PR 50684 - fix intent(in) check 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, gfortran 4.6 and 4.7 have a too tight check whether a variable can be modified if the actual argument is INTENT(IN). This patch relaxes/fixes the checking. Build and regtested on x86-64-linux. OK for the trunk - and for 4.6 (as it is a regression)? Tobias 2011-11-29 Tobias Burnus PR fortran/50684 * check.c (variable_check): Fix intent(in) check. 2011-11-29 Tobias Burnus PR fortran/50684 * gfortran.dg/move_alloc_8.f90: New. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 832eb64..19e2da5 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -476,10 +488,31 @@ variable_check (gfc_expr *e, int n, bool allow_proc) && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - return FAILURE; + gfc_ref *ref; + bool pointer = e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer + : e->symtree->n.sym->attr.pointer; + + for (ref = e->ref; ref; ref = ref->next) + { + if (pointer && ref->type == REF_COMPONENT) + break; + if (ref->type == REF_COMPONENT + && ((ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.class_pointer) + || (ref->u.c.component->ts.type != BT_CLASS + && ref->u.c.component->attr.pointer))) + break; + } + + if (!ref) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be " + "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; + } } if (e->expr_type == EXPR_VARIABLE --- /dev/null 2011-11-29 07:50:43.475522632 +0100 +++ gcc/gcc/testsuite/gfortran.dg/move_alloc_8.f90 2011-11-29 18:30:18.000000000 +0100 @@ -0,0 +1,106 @@ +! { dg-do compile } +! +! PR fortran/50684 +! +! Module "bug" contributed by Martin Steghöfer. +! + +MODULE BUG + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE POINTER_INTENT_IN_BUG_WORKING(POINTER_INTENT_IN_VARIABLE) + TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE + TYPE(MY_TYPE), POINTER :: POINTER_VARIABLE_LOCAL + INTEGER, ALLOCATABLE :: LOCAL_VALUE + + POINTER_VARIABLE_LOCAL=>POINTER_INTENT_IN_VARIABLE + CALL MOVE_ALLOC(POINTER_VARIABLE_LOCAL%VALUE, LOCAL_VALUE) + + RETURN + END SUBROUTINE POINTER_INTENT_IN_BUG_WORKING + + SUBROUTINE POINTER_INTENT_IN_BUG_FAILING(POINTER_INTENT_IN_VARIABLE) + TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE + INTEGER, ALLOCATABLE :: LOCAL_VALUE + + CALL MOVE_ALLOC(POINTER_INTENT_IN_VARIABLE%VALUE, LOCAL_VALUE) + + RETURN + END SUBROUTINE POINTER_INTENT_IN_BUG_FAILING +end module bug + +subroutine test1() + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE sub (dt) + type(MY_TYPE), intent(in) :: dt + INTEGER, ALLOCATABLE :: lv + call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." } + END SUBROUTINE +end subroutine test1 + +subroutine test2 (x, px) + implicit none + type t + integer, allocatable :: a + end type t + + type t2 + type(t), pointer :: ptr + integer, allocatable :: a + end type t2 + + type(t2), intent(in) :: x + type(t2), pointer, intent(in) :: px + + integer, allocatable :: a + type(t2), pointer :: ta + + call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%ptr%a, a) ! OK (3) + call move_alloc (px%a, a) ! OK (4) + call move_alloc (px%ptr%a, a) ! OK (5) +end subroutine test2 + +subroutine test3 (x, px) + implicit none + type t + integer, allocatable :: a + end type t + + type t2 + class(t), pointer :: ptr + integer, allocatable :: a + end type t2 + + type(t2), intent(in) :: x + class(t2), pointer, intent(in) :: px + + integer, allocatable :: a + class(t2), pointer :: ta + + call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%ptr%a, a) ! OK (6) + call move_alloc (px%a, a) ! OK (7) + call move_alloc (px%ptr%a, a) ! OK (8) +end subroutine test3 + +subroutine test4() + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE sub (dt) + CLASS(MY_TYPE), intent(in) :: dt + INTEGER, ALLOCATABLE :: lv + call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." } + END SUBROUTINE +end subroutine test4 + +! { dg-final { cleanup-modules "bug" } }