From patchwork Mon Sep 20 04:01:33 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 45168 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 A59C3385800B for ; Mon, 20 Sep 2021 04:02:05 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 55FDB3858408; Mon, 20 Sep 2021 04:01:40 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 55FDB3858408 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: MTRV4G3a35NIrJhtLQphIB0hK9OoEIUsUWXPc7/+bvUXTjwnPDLhzoSszczLES+chtJooWH11b v3I9lbOKUuFxZ4MwKXJhZlgp/D2lP1b2CLSoT1+1xd/4DwVDyPbLu8kE/2EP2n/OClNJQowr2n F2EQN1uov63DR1SuD1MXVHXakFs/fPeHfPr8hytSvDwwEAps3mRHzpzEydEMBTQMlP7Kp4f3ub Ih+j/BADkyWtm0jKO5JVdTzlaTvHtmHDW810Ubo8lOzvJp2SqstXvPZKUtRXyTp14089hcDFcL bY7/BnG7dCijNMWK90BD3qOU X-IronPort-AV: E=Sophos;i="5.85,307,1624348800"; d="scan'208";a="68549235" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 19 Sep 2021 20:01:40 -0800 IronPort-SDR: NsH8ZN69niLmkgcJWAN5+9lOp10e09pX23PmCNAp1jPGkmdWCQZxuuF3EyTS8uWv+BxV45uO1E NHQUIncbxNZFQfBFmY/kLdmnM3vTCBhFXSvUXox3d0mdrNz4txtmIbtQtOWj5XdeTZNh4Rj2aZ OHZYhYWAZf0dND5sc7tUUN38K/ISFnP2ym2CJbvKfkQnYLsnrlOKRKh7wBCjLTbdCvilx/ual1 5ZOIe47brH1vdEmreR78rmMZ9Pl0bn1uGi9sDzGGSc8pT5tmVbngJkryFU2GwFqBavO/nriFxj zkU= To: "gcc-patches@gcc.gnu.org" , "fortran@gcc.gnu.org" From: Sandra Loosemore Subject: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334) Message-ID: Date: Sun, 19 Sep 2021 22:01:33 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-05.mgc.mentorg.com (147.34.90.205) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-9.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch fixes some bugs in handling of assumed-rank arguments revealed by the TS29113 testsuite, allowing xfails to be removed from those testcases. It was previously failing to diagnose an error when passing an assumed-rank argument to a procedure via a non-assumed-rank dummy, and giving a bogus error when passing one as the first argument to the ASSOCIATED intrinsic. Both fixes turned out to be 1-liners. OK to commit? -Sandra commit b967fe5f88a5245163f235cfa6a5808aa41e88f4 Author: Sandra Loosemore Date: Sun Sep 19 17:32:03 2021 -0700 Fortran: Fixes for F2018 C838 (PR fortran/101334) The compiler was failing to diagnose the error required by F2018 C838 when passing an assumed-rank array argument to a non-assumed-rank dummy. It was also incorrectly giving an error for calls to the 2-argument form of the ASSOCIATED intrinsic, which is supposed to be permitted by C838. 2021-09-19 Sandra Loosemore PR fortran/101334 gcc/fortran/ * check.c (gfc_check_associated): Allow an assumed-rank array for the pointer argument. * interface.c (compare_parameter): Also give rank mismatch error on assumed-rank array. gcc/testsuite/ * testsuite/gfortran.dg/c-interop/c535b-2.f90: Remove xfails. * testsuite/gfortran.dg/c-interop/c535b-3.f90: Likewise. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 851af1b..f31ad68 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1520,7 +1520,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) t = true; if (!same_type_check (pointer, 0, target, 1, true)) t = false; - if (!rank_check (target, 0, pointer->rank)) + /* F2018 C838 explicitly allows an assumed-rank variable as the first + argument of intrinsic inquiry functions. */ + if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) t = false; if (target->rank > 0) { diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9e3e8aa..f9a7c9c 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2634,7 +2634,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && formal->as->type == AS_ASSUMED_SHAPE)) && actual->expr_type != EXPR_NULL) || (actual->rank == 0 && formal->attr.dimension - && gfc_is_coindexed (actual))) + && gfc_is_coindexed (actual)) + /* Assumed-rank actual argument; F2018 C838. */ + || actual->rank == -1) { if (where && (!formal->attr.artificial || (!formal->maybe_array diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 index 7bff14f..2dafd44 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 @@ -61,15 +61,14 @@ subroutine test_calls (x, y) ! assumed-rank dummies call g (x, y) ! OK ! assumed-size dummies - call h (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } } + call h (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" } y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} } ! assumed-shape dummies call i (x, & ! { dg-error "(A|a)ssumed.rank" } y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} } ! fixed-size array dummies - call j (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } } + call j (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" } y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} } - ! { dg-bogus "Actual argument contains too few elements" "pr101334" { xfail *-*-* } .-2 } end subroutine ! Check that you can't use an assumed-rank array variable in an array diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 index 6427bd6..23862e5 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 @@ -29,7 +29,7 @@ function test_associated3 (a, b) integer, target :: b logical :: test_associated3 - test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } } + test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } end function function test_associated4 (a, b) @@ -38,7 +38,7 @@ function test_associated4 (a, b) integer, target :: b(:) logical :: test_associated4 - test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } } + test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } end function function test_associated5 (a, b) @@ -47,7 +47,7 @@ function test_associated5 (a, b) integer, target :: b(20) logical :: test_associated5 - test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } } + test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } end function function test_associated6 (a, b) @@ -65,7 +65,7 @@ function test_associated7 (a, b) integer, pointer :: b logical :: test_associated7 - test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } } + test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } end function function test_associated8 (a, b) @@ -74,6 +74,6 @@ function test_associated8 (a, b) integer, pointer :: b(:) logical :: test_associated8 - test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } } + test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } end function