From patchwork Thu Dec 9 22:05:49 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 48730 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3D5403858C27 for ; Thu, 9 Dec 2021 22:07:05 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 3D5403858C27 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1639087625; bh=CfApjaRyr/bEULCayOT6mzhcm6l4NcI7+YnpVdsvo7s=; h=Subject:To:References:Date:In-Reply-To:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=AJGWdbR9O/upsZW9g0AyHtzxNWVilgprdAgRmwe/xXuSM+GOfAZj+Tj2bFywV1JCC LLJmuWAY5KhvzTwzgSntM1WYffC7oL6t411nFf9YAHIBpW6VIl8Qcq+UPcelvNuQ3+ 9hobOV0rvkpo5xrhbwTLY1fmJUfr2sL57ddH7ZPg= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.19]) by sourceware.org (Postfix) with ESMTPS id AE8333858017; Thu, 9 Dec 2021 22:05:54 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org AE8333858017 X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from gluon.fritz.box ([79.251.10.96]) by mail.gmx.net (mrgmx005 [212.227.17.190]) with ESMTPSA (Nemesis) id 1MfHAH-1mJsnc2oSR-00gp99; Thu, 09 Dec 2021 23:05:51 +0100 Subject: [PATCH, v2] PR fortran/103418 - random_number() does not accept pointer, intent(in) array argument To: Mikael Morin , fortran , gcc-patches Newsgroups: gmane.comp.gcc.fortran,gmane.comp.gcc.patches References: <65b5dd1c-ed9f-374f-8c42-00e981d9a491@gmx.de> <85f28771-40da-43fc-91dd-ab9f283e8b33@orange.fr> Message-ID: Date: Thu, 9 Dec 2021 23:05:49 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.12.0 MIME-Version: 1.0 In-Reply-To: <85f28771-40da-43fc-91dd-ab9f283e8b33@orange.fr> Content-Language: en-US X-Provags-ID: V03:K1:EJgpjrFce/JpOV0mKCvUue6VMSEA63a5yt1Hwd0TZJPo6xpuNM6 0X2SkbbOmCxajwoIAHtY9eDwTVw6gZ2t/gDWBoicy4r7sad0IhF7Zr1nzQ0RNttBQa3JPYL Ts8VeQW1lSpEYlFhUBohzceCYI/+A6+2M+B1dQ0FgpWLbJL/PcjU9iqm3VaeatToRSJQ7dx aXr/ZkWLZMRyM5hU87eHQ== X-UI-Out-Filterresults: notjunk:1;V03:K0:wJEWesjafsk=:w3ft8Dvt/zFf8s0IJJSKAb Czsl+PxlObIfV+yOv56NsxdGAgAUtx0eLIPINm8KYwdTFDO6EW4Trx1H+NIx6mnvceK2NPhhD 6YptlLoJp7hEfKWftllrKuRsuKw4dTMSLEZdPCLTM4xwfLun3VnhZxXWwiJoVI32eomEyqE8g WwOKAz4e7dHTq30+Glq8i6Jhl8GH0vklvrNNQwTLEuPAydLISIPHbuGa4olUioHS7dhBrFV48 ja4ItN7lRS/S27ltel9zmcLhyHknID8c53KShDuRtRhpk85e7FZPmnBF2F/qKisYajfuCyFRX GPGAgio/dDPZAPrOSVGHgzL8MleEJETS+PONtpljY0519UrqjknslgPrr9zdvaezVZNSUJFh+ 4jDY8bD0Gfr7joZgmdAkclLzPpHO1MnV9uI1hgyc0EJnsAnnjp6hpaSaJO/3BVGF03Hkjv/Za FNDt69KR1AVLoSSjH7i1rNaOpH72a+3IgejjPyXqLuzeTUtY61dhT+XQILnAVGQ6vYrbDGGfQ U5k26cDglhQuhB+rsnU5hr+RzrUVBZdA5aC9BPHzZEHY7P66O8px9YziS5kvRtEAeugKleshW K81D83/bQHepVBDrD4p+gZRAudO+xWCpp1ZBPNCIExob5ErVhyjLTTTGrhTmVY0I10xLfrsgR Ab6tO3bbI1FtvEmja+LJ13g47+XiCXyRkm9f2p9j/ol9naowszo3CxDdLuRK9xiRumPH9RGiE 9X7EQqVGBZY7uJsMNkfH+/1iVMpJCjjppOpKUrb8FLfnWnvc23Te4nz7GgUzejOkwTySRkpO4 g3xYsG4VjDfts+XQWhBDGUQ/qKng776DiE5sup2b3iOUfI5AzbnZY3dpVIFvDw1if+tWiHeJx RHEboZwXfAQnzVsx9ysYrIFTParL21DvE9QBHmGIQgo1x3y7WQz6zpotb78dq+u0ZzxQ/Ir5P 21iNmkKJibGSEWlM4ixTCQzqh/vnm/Z7ON9ko6q32YaZ1lA+yZU9qjrNu35IcYaNvw3ivVCP2 Z0SdJArMDByvquQgDeVWytSSk5mKSUWt9Oux6RNBA9lvX6zRqeVNtwAqjbyJQ+40tI+dn1Fq4 aIxZH0kGhWopJk= X-Spam-Status: No, score=-12.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi Mikael, Am 08.12.21 um 10:32 schrieb Mikael Morin: > On 07/12/2021 21:46, Harald Anlauf wrote: >> Hi Mikael, >> >> Am 07.12.21 um 21:17 schrieb Mikael Morin: >>> The existing code looks dubious to me (or at least difficult to >>> understand), and your patch doesn’t make that any better. >>> I would rather try to remove the whole block, and fix the fallout on >>> move_alloc by adding calls to gfc_check_vardef_context in >>> gfc_check_move_alloc. >>> Can you try that instead? >> >> I hadn't thought that far but will think about a possibly better >> solution. >> > Hello, > > I thought about it some more over night, and it is probably a poor > suggestion to restrict the check to move_alloc only.  The existing code > was added for move_alloc, but it has a broader scope.  Still, > gfc_check_vardef_context has the correct checks and is the one to be used. I have played a little, and it took some time to understand the fallout. Your suggestion to rely on gfc_check_vardef_context actually helped to uncover another bug: a bad check for CLASS pointer. See attached for an updated patch and the extended testcase. Regtested again. OK now? Thanks, Harald From dec60c90d47211d55048e7034e95f3e6fb10a2d4 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Thu, 9 Dec 2021 22:57:13 +0100 Subject: [PATCH] Fortran: fix check for pointer dummy arguments with INTENT(IN) gcc/fortran/ChangeLog: PR fortran/103418 * check.c (variable_check): Replace previous check of procedure dummy arguments with INTENT(IN) attribute when passed to intrinsic procedures by gfc_check_vardef_context. * expr.c (gfc_check_vardef_context): Correct check of INTENT(IN) dummy arguments for the case of sub-components of a CLASS pointer. gcc/testsuite/ChangeLog: PR fortran/103418 * gfortran.dg/move_alloc_8.f90: Adjust error messages. * gfortran.dg/pointer_intent_9.f90: New test. --- gcc/fortran/check.c | 32 ++++-------------- gcc/fortran/expr.c | 9 +++-- gcc/testsuite/gfortran.dg/move_alloc_8.f90 | 4 +-- .../gfortran.dg/pointer_intent_9.f90 | 33 +++++++++++++++++++ 4 files changed, 47 insertions(+), 31 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_9.f90 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index ee3a51ee253..3934336df2e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1011,33 +1011,13 @@ variable_check (gfc_expr *e, int n, bool allow_proc) if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.intent == INTENT_IN && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT - || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)) + || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT) + && !gfc_check_vardef_context (e, false, true, false, NULL)) { - 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 ("%qs argument of %qs intrinsic at %L cannot be " - "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } + gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; } if (e->expr_type == EXPR_VARIABLE diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 87089321a3b..b874607db1d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -6254,10 +6254,13 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, { if (ptr_component && ref->type == REF_COMPONENT) check_intentin = false; - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + if (ref->type == REF_COMPONENT) { - ptr_component = true; - if (!pointer) + gfc_component *comp = ref->u.c.component; + ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok) + ? CLASS_DATA (comp)->attr.class_pointer + : comp->attr.pointer; + if (ptr_component && !pointer) check_intentin = false; } if (ref->type == REF_INQUIRY diff --git a/gcc/testsuite/gfortran.dg/move_alloc_8.f90 b/gcc/testsuite/gfortran.dg/move_alloc_8.f90 index f624b703cc9..d968ea0e5cd 100644 --- a/gcc/testsuite/gfortran.dg/move_alloc_8.f90 +++ b/gcc/testsuite/gfortran.dg/move_alloc_8.f90 @@ -60,7 +60,7 @@ subroutine test2 (x, px) integer, allocatable :: a type(t2), pointer :: ta - call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" } 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) @@ -84,7 +84,7 @@ subroutine test3 (x, px) integer, allocatable :: a class(t2), pointer :: ta - call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" } 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) diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_9.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_9.f90 new file mode 100644 index 00000000000..30ddd028359 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_intent_9.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/103418 +! Validate checks for dummy arguments with INTENT(IN), pointer attribute + +module m + type t + real, pointer :: a, b(:) + end type t +contains + subroutine s1 (a, b, c, d, e) + real, pointer, intent(in) :: a, b(:) + type(t), intent(in) :: c + class(t), intent(in) :: d + type(t), pointer, intent(in) :: e + real, pointer :: pa, pb(:) + call random_number (a) ! legal + call random_number (b) + call cpu_time (a) + call system_clock (count_rate=a) + call random_number (c% a) + call random_number (c% b) + call random_number (d% a) + call random_number (d% b) + call random_number (e% a) + call random_number (e% b) + call move_alloc (a, pa) ! { dg-error "must be ALLOCATABLE" } + call move_alloc (b, pb) ! { dg-error "must be ALLOCATABLE" } + allocate (a) ! { dg-error "pointer association context" } + allocate (b(10)) ! { dg-error "pointer association context" } + allocate (c% a) ! { dg-error "pointer association context" } + allocate (c% b(10)) ! { dg-error "pointer association context" } + end subroutine s1 +end module -- 2.26.2