From patchwork Sun Mar 17 12:35:24 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 87291 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 A495D385828E for ; Sun, 17 Mar 2024 12:36:25 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org A495D385828E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1710678985; bh=aEgFWYU/seXrPQR+JhILi2H3bnwyLaGD1mtj1FUr0to=; h=From:To:Subject:Date:In-Reply-To:References:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:List-Subscribe: From; b=te0CTY+R6fD/KkLFGzhqV1kN5xf+HpT052ERlJA77dqJ4UUUKyqN8f6C4cUjdBJbc KnDqCNo0NQqJQNWBAtqos2l0oDKF7ohv4M2FaOACc1w0KSK6GHGkc6ValpjTlsBUT7 JU/IT8yZ4Ke1qRfq1AjjJ1ve4SvPYT3c5Q5afMqM= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-209.smtpout.orange.fr [193.252.23.209]) by sourceware.org (Postfix) with ESMTPS id 7A6853858C50; Sun, 17 Mar 2024 12:35:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7A6853858C50 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: sourceware.org; spf=fail smtp.mailfrom=gcc.gnu.org ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 7A6853858C50 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.209 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710678936; cv=none; b=a1cKzgLUJ12WUgbLYbl1KrxcI286Ze3yVJbkDsUenBSDE+G7F78IEhGxbHHiMl2AAZFEpchY233lDNROzYqoyDtFJuZIOsDl0gYL7TJiaPPGXkNXBfsTIWOHu78OiiPFvm49AyaTDujclUdDGPiBejWx1WPIy1rAn1YL/gjdxAI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710678936; c=relaxed/simple; bh=470IZ2YY6CqhN+uflK3woD8ek0FV1gmbERl4eubTJAk=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=hF7TNUksgfKen9UmZUCX0UKTpZRLOkc8JvKE6w2mAohvVHUWCC+eUU5s+VOECMK5UP32BBaG0rwQPD7HfV9hQoDOAhnn2knrI/1wtsfrzzMdXlVxfNeH/XTcnkwPhpSqGx6+a/1DoFyrERPwm6PhuSinUTftYLXD0+Mpdb3Hfgc= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id lpjarxkqytc5ilpjhrEG43; Sun, 17 Mar 2024 13:35:33 +0100 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1710678933; bh=aEgFWYU/seXrPQR+JhILi2H3bnwyLaGD1mtj1FUr0to=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=jdXmqNxhlsA7yOQNSeRZsHY/HthPQyJDuCKq3Pr2ZGgyUS6Vaadjnieqq23qqzf89 xLI+yViiIBnTbxS7ssD92iSmjaXx/Ouw6CvpUyd3BN6P4vtpMjTq9Aut2W9r0tjOAB VKlz8NYH8v+O+13bybOSI54UiYP0hjia4Lac0U/W0SahMpnYBXMIEt6mISwPkHKyjs OtE39KKcV/dzViRDO7P5PSsoF4zyJSyc7uFLE3PN1ORbjFQfWSk+eABsBxYwwAdzvL mCiEH4vHk5t3becyXPplmajygVyqrohCpN98RbrTZ7RMeseNDPE3M9RXYj5mxd7Yyj uyN39R08GJBTg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Sun, 17 Mar 2024 13:35:33 +0100 X-ME-IP: 86.215.161.51 From: Mikael Morin To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 1/2] testsuite: Declare fortran array bound variables Date: Sun, 17 Mar 2024 13:35:24 +0100 Message-ID: <20240317123527.999399-2-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240317123527.999399-1-mikael@gcc.gnu.org> References: <20240317123527.999399-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-10.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, RCVD_IN_DNSWL_NONE, SPF_HELO_PASS, SPF_NEUTRAL, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 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 This fixes invalid undeclared fortran array bound variables in the testsuite. gcc/testsuite/ChangeLog: * gfortran.dg/graphite/pr107865.f90: Declare array bound variable(s) as dummy argument(s). * gfortran.dg/pr101267.f90: Likewise. * gfortran.dg/pr112404.f90: Likewise. * gfortran.dg/pr78061.f: Likewise. * gfortran.dg/pr79315.f90: Likewise. * gfortran.dg/vect/pr90681.f: Likewise. * gfortran.dg/vect/pr97761.f90: Likewise. * gfortran.dg/vect/pr99746.f90: Likewise. --- gcc/testsuite/gfortran.dg/graphite/pr107865.f90 | 2 +- gcc/testsuite/gfortran.dg/pr101267.f90 | 2 +- gcc/testsuite/gfortran.dg/pr112404.f90 | 2 +- gcc/testsuite/gfortran.dg/pr78061.f | 2 +- gcc/testsuite/gfortran.dg/pr79315.f90 | 6 +++++- gcc/testsuite/gfortran.dg/vect/pr90681.f | 2 +- gcc/testsuite/gfortran.dg/vect/pr97761.f90 | 2 +- gcc/testsuite/gfortran.dg/vect/pr99746.f90 | 2 +- 8 files changed, 12 insertions(+), 8 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/graphite/pr107865.f90 b/gcc/testsuite/gfortran.dg/graphite/pr107865.f90 index 6bddb17a1be..323d8092ad2 100644 --- a/gcc/testsuite/gfortran.dg/graphite/pr107865.f90 +++ b/gcc/testsuite/gfortran.dg/graphite/pr107865.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-options "-O1 -floop-parallelize-all -ftree-parallelize-loops=2" } - SUBROUTINE FNC (F) + SUBROUTINE FNC (F,N) IMPLICIT REAL (A-H) DIMENSION F(N) diff --git a/gcc/testsuite/gfortran.dg/pr101267.f90 b/gcc/testsuite/gfortran.dg/pr101267.f90 index 12723cf9c22..99a6dcfa342 100644 --- a/gcc/testsuite/gfortran.dg/pr101267.f90 +++ b/gcc/testsuite/gfortran.dg/pr101267.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-options "-Ofast" } ! { dg-additional-options "-march=znver2" { target x86_64-*-* i?86-*-* } } - SUBROUTINE sfddagd( regime, znt,ite ,jte ) + SUBROUTINE sfddagd( regime, znt,ite ,jte, ime, IN ) REAL, DIMENSION( ime, IN) :: regime, znt REAL, DIMENSION( ite, jte) :: wndcor_u LOGICAL wrf_dm_on_monitor diff --git a/gcc/testsuite/gfortran.dg/pr112404.f90 b/gcc/testsuite/gfortran.dg/pr112404.f90 index 573fa28164a..4508bbc8738 100644 --- a/gcc/testsuite/gfortran.dg/pr112404.f90 +++ b/gcc/testsuite/gfortran.dg/pr112404.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-options "-Ofast" } ! { dg-additional-options "-mavx2" { target avx2 } } - SUBROUTINE sfddagd( regime, znt, ite, jte ) + SUBROUTINE sfddagd( regime, znt, ite, jte, ime, IN ) REAL, DIMENSION( ime, IN) :: regime, znt REAL, DIMENSION( ite, jte) :: wndcor_u LOGICAL wrf_dm_on_monitor diff --git a/gcc/testsuite/gfortran.dg/pr78061.f b/gcc/testsuite/gfortran.dg/pr78061.f index 7e4dd3de8b5..9061dea74da 100644 --- a/gcc/testsuite/gfortran.dg/pr78061.f +++ b/gcc/testsuite/gfortran.dg/pr78061.f @@ -1,6 +1,6 @@ ! { dg-do compile } ! { dg-options "-O3 -fsplit-loops" } - SUBROUTINE SSYMM(C) + SUBROUTINE SSYMM(C,LDC) REAL C(LDC,*) LOGICAL LSAME LOGICAL UPPER diff --git a/gcc/testsuite/gfortran.dg/pr79315.f90 b/gcc/testsuite/gfortran.dg/pr79315.f90 index 8cd89691ce9..b754a2b3274 100644 --- a/gcc/testsuite/gfortran.dg/pr79315.f90 +++ b/gcc/testsuite/gfortran.dg/pr79315.f90 @@ -10,7 +10,11 @@ SUBROUTINE wsm32D(t, & its,& ite, & kts, & - kte & + kte, & + ims, & + ime, & + kms, & + kme & ) REAL, DIMENSION( its:ite , kts:kte ), & INTENT(INOUT) :: & diff --git a/gcc/testsuite/gfortran.dg/vect/pr90681.f b/gcc/testsuite/gfortran.dg/vect/pr90681.f index 03d3987b146..49f1d50ab8f 100644 --- a/gcc/testsuite/gfortran.dg/vect/pr90681.f +++ b/gcc/testsuite/gfortran.dg/vect/pr90681.f @@ -1,6 +1,6 @@ C { dg-do compile } C { dg-additional-options "-march=armv8.2-a+sve" { target { aarch64*-*-* } } } - SUBROUTINE HMU (H1) + SUBROUTINE HMU (H1,NORBS) COMMON DD(107) DIMENSION H1(NORBS,*) DO 70 J1 = IA,I1 diff --git a/gcc/testsuite/gfortran.dg/vect/pr97761.f90 b/gcc/testsuite/gfortran.dg/vect/pr97761.f90 index 250e2bf016e..401ef06e422 100644 --- a/gcc/testsuite/gfortran.dg/vect/pr97761.f90 +++ b/gcc/testsuite/gfortran.dg/vect/pr97761.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-additional-options "-O1" } -subroutine ni (ps) +subroutine ni (ps, inout) type vector real x, y end type diff --git a/gcc/testsuite/gfortran.dg/vect/pr99746.f90 b/gcc/testsuite/gfortran.dg/vect/pr99746.f90 index fe947ae7ccf..121d67d564d 100644 --- a/gcc/testsuite/gfortran.dg/vect/pr99746.f90 +++ b/gcc/testsuite/gfortran.dg/vect/pr99746.f90 @@ -1,6 +1,6 @@ ! { dg-do compile } ! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } -SUBROUTINE CLAREF(A, WANTZ, Z, ICOL1, ITMP1, ITMP2, T1, T2, V2) +SUBROUTINE CLAREF(A, WANTZ, Z, ICOL1, ITMP1, ITMP2, T1, T2, V2, LDA) LOGICAL BLOCK, WANTZ COMPLEX T1, T2, V2 COMPLEX A(LDA, *), VECS, Z(LDA, *) From patchwork Sun Mar 17 12:35:25 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 87292 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 9B5F03858425 for ; Sun, 17 Mar 2024 12:36:51 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9B5F03858425 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1710679011; bh=gxwEhFnBsRdF1HOQl/Xk0dRr6C5RzWfzEQya+rAa7XU=; h=From:To:Subject:Date:In-Reply-To:References:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:List-Subscribe: From; b=xf5ddEpoRDhS41Jlyx1kZTxUX6Za7fOCBxpBIwj794FjAdXLH1YL1JVG0O1CXj4B5 BnN1M//jrAkn+03Y7EAPCE5xPYEEbXRMyakvR9MZpwfj6cPTpHOiOr9kEdQmS9t94D iKMOwim78QyuwuEHqawchaMEThYBJwvYrRFrEugs= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id 6AAA63858CD1; Sun, 17 Mar 2024 12:35:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 6AAA63858CD1 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: sourceware.org; spf=fail smtp.mailfrom=gcc.gnu.org ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 6AAA63858CD1 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.14 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710678936; cv=none; b=HapSEebl9y4GCAPdPlozgIE5rp0QpS1bAPf6ckUh6/0vewWHFRkjVbCGCRIFYhaAT6S2lY9OrcRaKlPyQ77iOglNzc+WUtMx7yHYKkycypIhZmCLGwEXFNCHA04ENwbe6pYE/Ttt9vuEw4p4PUFyYLWVr47bhy+MyamsvRQjVUE= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710678936; c=relaxed/simple; bh=cM0sGwLIKNep32Ky6mcexiJwGHMtEzYkGGGdq/jxuOc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=a+uxtvhkiqLw4WLWbNx/fJAAsxLXItVoB4TePxzL08PlabgfJRoxbGBX2nt9dBSFRz5Sdkn0BFm6dJDkvEvERtjUFYrXcxKAtTWmO8L8S1Mw44kxzJhabK8cNH7Tejbw/9pIq4EaUlizTJOrhOA3nXmNLy2IrbpVPVOGozsTeiI= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id lpjarxkqytc5ilpjhrEG44; Sun, 17 Mar 2024 13:35:33 +0100 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1710678933; bh=gxwEhFnBsRdF1HOQl/Xk0dRr6C5RzWfzEQya+rAa7XU=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=sHX1/r8wqvFRmLheARCL8KvAHJJivyCM59vpWDtQy+B9vopVwGQSprd3BTUT0+ZFI 7LklTzLBpm5q8jH5OMmzEZ7vleMfo72nWmnYTz0PL62Z0md/9yo2eyo2xXZvZO6qf+ AKB/GuQPU5v9+/wVlxesY8Je0yPi8TGAO+cYoCYXrih4ghrQ1kxbThPbu9g5W7kEuN ZrIVcwa6ATOSgHTa18sRBeGk/+f/s6wVIODlHJUhonC7ybPYm1WhZdLJS14XKmN7OH 1flIH6allBJ92z9strKnp6yRaesQaZZM3KVy7HzYTG0kYoNShtOmTkcDnf+DCKDX3j Nzz/uHX2UGjWA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Sun, 17 Mar 2024 13:35:33 +0100 X-ME-IP: 86.215.161.51 From: Mikael Morin To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 2/2] fortran: Fix specification expression error with dummy procedures [PR111781] Date: Sun, 17 Mar 2024 13:35:25 +0100 Message-ID: <20240317123527.999399-3-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240317123527.999399-1-mikael@gcc.gnu.org> References: <20240317123527.999399-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-10.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_NEUTRAL, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 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 This fixes a spurious invalid variable in specification expression error. The problem is caused by improper restoration of formal_arg_flag to false (instead of restoring it to its previous value). This happens with the testcase from the PR where a dummy argument is itself a procedure with dummy arguments. At the time that dummy procedure has been resolved, its dummy arguments have been resolved and the flag has been reset to false. The condition checking that flag when resolving the array spec expressions of the next dummy then triggers the error. The fix removes a condition disabling proper check of specification expressions, together with the formal_arg_flag global variable associated with it. As the specification expression checking code is dependent on the current namespace, the latter is set before array spec resolution (and restored after). Two new functions are introduced to select the right namespace for that. PR fortran/111781 gcc/fortran/ChangeLog: * symbol.cc (gfc_get_procedure_ns, gfc_get_spec_ns): New functions. * gfortran.h (gfc_get_procedure_ns, gfc_get_spec ns): Declare them. (gfc_is_formal_arg): Remove. * expr.cc (check_restricted): Remove the case where symbol is dummy and declared in the current ns. Use gfc_get_spec_ns to get the right namespace. * resolve.cc (gfc_is_formal_arg, formal_arg_flag): Remove. (gfc_resolve_formal_arglist): Set gfc_current_ns. Quit loop and restore gfc_current_ns instead of early returning. (resolve_symbol): Factor common array spec resolution code to... (resolve_symbol_array_spec): ... this new function. Additionnally set and restore gfc_current_ns. gcc/testsuite/ChangeLog: * gfortran.dg/spec_expr_8.f90: New test. * gfortran.dg/spec_expr_9.f90: New test. --- gcc/fortran/expr.cc | 8 +-- gcc/fortran/gfortran.h | 4 +- gcc/fortran/resolve.cc | 77 +++++++++++------------ gcc/fortran/symbol.cc | 57 +++++++++++++++++ gcc/testsuite/gfortran.dg/spec_expr_8.f90 | 24 +++++++ gcc/testsuite/gfortran.dg/spec_expr_9.f90 | 19 ++++++ 6 files changed, 139 insertions(+), 50 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/spec_expr_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/spec_expr_9.f90 diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 82a642b01f7..0852bc5f493 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -3509,19 +3509,13 @@ check_restricted (gfc_expr *e) if (!check_references (e->ref, &check_restricted)) break; - /* gfc_is_formal_arg broadcasts that a formal argument list is being - processed in resolve.cc(resolve_formal_arglist). This is done so - that host associated dummy array indices are accepted (PR23446). - This mechanism also does the same for the specification expressions - of array-valued functions. */ if (e->error || sym->attr.in_common || sym->attr.use_assoc || sym->attr.dummy || sym->attr.implied_index || sym->attr.flavor == FL_PARAMETER - || is_parent_of_current_ns (sym->ns) - || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) + || is_parent_of_current_ns (gfc_get_spec_ns (sym))) { t = true; break; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 32b792f85fb..f954b7a8802 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3605,6 +3605,9 @@ bool gfc_is_associate_pointer (gfc_symbol*); gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *); gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *); +gfc_namespace * gfc_get_procedure_ns (gfc_symbol *); +gfc_namespace * gfc_get_spec_ns (gfc_symbol *); + /* intrinsic.cc -- true if working in an init-expr, false otherwise. */ extern bool gfc_init_expr_flag; @@ -3813,7 +3816,6 @@ bool gfc_resolve_iterator (gfc_iterator *, bool, bool); bool find_forall_index (gfc_expr *, gfc_symbol *, int); bool gfc_resolve_index (gfc_expr *, int); bool gfc_resolve_dim_arg (gfc_expr *); -bool gfc_is_formal_arg (void); bool gfc_resolve_substring (gfc_ref *, bool *); void gfc_resolve_substring_charlen (gfc_expr *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 02acc4aef31..6bdb56038bb 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -72,9 +72,6 @@ static bool first_actual_arg = false; static int omp_workshare_flag; -/* True if we are processing a formal arglist. The corresponding function - resets the flag each time that it is read. */ -static bool formal_arg_flag = false; /* True if we are resolving a specification expression. */ static bool specification_expr = false; @@ -89,12 +86,6 @@ static bitmap_obstack labels_obstack; static bool inquiry_argument = false; -bool -gfc_is_formal_arg (void) -{ - return formal_arg_flag; -} - /* Is the symbol host associated? */ static bool is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) @@ -285,7 +276,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) sym->attr.always_explicit = 1; } - formal_arg_flag = true; + gfc_namespace *orig_current_ns = gfc_current_ns; + gfc_current_ns = gfc_get_procedure_ns (proc); for (f = proc->formal; f; f = f->next) { @@ -306,17 +298,18 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) &proc->declared_at); continue; } - else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL + + if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL && !resolve_procedure_interface (sym)) - return; + break; if (strcmp (proc->name, sym->name) == 0) - { - gfc_error ("Self-referential argument " - "%qs at %L is not allowed", sym->name, - &proc->declared_at); - return; - } + { + gfc_error ("Self-referential argument " + "%qs at %L is not allowed", sym->name, + &proc->declared_at); + break; + } if (sym->attr.if_source != IFSRC_UNKNOWN) gfc_resolve_formal_arglist (sym); @@ -533,7 +526,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) } } } - formal_arg_flag = false; + + gfc_current_ns = orig_current_ns; } @@ -15968,6 +15962,26 @@ resolve_pdt (gfc_symbol* sym) } +/* Resolve the symbol's array spec. */ + +static bool +resolve_symbol_array_spec (gfc_symbol *sym, int check_constant) +{ + gfc_namespace *orig_current_ns = gfc_current_ns; + gfc_current_ns = gfc_get_spec_ns (sym); + + bool saved_specification_expr = specification_expr; + specification_expr = true; + + bool result = gfc_resolve_array_spec (sym->as, check_constant); + + specification_expr = saved_specification_expr; + gfc_current_ns = orig_current_ns; + + return result; +} + + /* Do anything necessary to resolve a symbol. Right now, we just assume that an otherwise unknown symbol is a variable. This sort of thing commonly happens for symbols in module. */ @@ -15982,7 +15996,6 @@ resolve_symbol (gfc_symbol *sym) gfc_component *c; symbol_attribute class_attr; gfc_array_spec *as; - bool saved_specification_expr; if (sym->resolve_symbol_called >= 1) return; @@ -16147,16 +16160,7 @@ resolve_symbol (gfc_symbol *sym) } } else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) - { - bool saved_specification_expr = specification_expr; - bool saved_formal_arg_flag = formal_arg_flag; - - specification_expr = true; - formal_arg_flag = true; - gfc_resolve_array_spec (sym->result->as, false); - formal_arg_flag = saved_formal_arg_flag; - specification_expr = saved_specification_expr; - } + resolve_symbol_array_spec (sym->result, false); /* For a CLASS-valued function with a result variable, affirm that it has been resolved also when looking at the symbol 'sym'. */ @@ -16723,18 +16727,7 @@ resolve_symbol (gfc_symbol *sym) check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error; - /* Set the formal_arg_flag so that check_conflict will not throw - an error for host associated variables in the specification - expression for an array_valued function. */ - if ((sym->attr.function || sym->attr.result) && sym->as) - formal_arg_flag = true; - - saved_specification_expr = specification_expr; - specification_expr = true; - gfc_resolve_array_spec (sym->as, check_constant); - specification_expr = saved_specification_expr; - - formal_arg_flag = false; + resolve_symbol_array_spec (sym, check_constant); /* Resolve formal namespaces. */ if (sym->formal_ns && sym->formal_ns != gfc_current_ns diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 5d9852c79e0..2ad14aa30c5 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5334,3 +5334,60 @@ gfc_sym_get_dummy_args (gfc_symbol *sym) return dummies; } + + +/* Given a procedure, returns the associated namespace. + The resulting NS should match the condition NS->PROC_NAME == SYM. */ + +gfc_namespace * +gfc_get_procedure_ns (gfc_symbol *sym) +{ + if (sym->formal_ns + && sym->formal_ns->proc_name == sym) + return sym->formal_ns; + + /* The above should have worked in most cases. If it hasn't, try some other + heuristics, eventually returning SYM->NS. */ + if (gfc_current_ns->proc_name == sym) + return gfc_current_ns; + + /* For contained procedures, the symbol's NS field is the + hosting namespace, not the procedure namespace. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.contained) + for (gfc_namespace *ns = sym->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name == sym) + return ns; + + if (sym->formal) + for (gfc_formal_arglist *f = sym->formal; f != nullptr; f = f->next) + if (f->sym) + { + gfc_namespace *ns = f->sym->ns; + if (ns && ns->proc_name == sym) + return ns; + } + + return sym->ns; +} + + +/* Given a symbol, returns the namespace in which the symbol is specified. + In most cases, it is the namespace hosting the symbol. This is the case + for variables. For functions, however, it is the function namespace + itself. This specification namespace is used to check conformance of + array spec bound expressions. */ + +gfc_namespace * +gfc_get_spec_ns (gfc_symbol *sym) +{ + if (sym->attr.flavor == FL_PROCEDURE + && sym->attr.function) + { + if (sym->result == sym) + return gfc_get_procedure_ns (sym); + else if (!sym->attr.generic) + return sym->result->ns; + } + + return sym->ns; +} diff --git a/gcc/testsuite/gfortran.dg/spec_expr_8.f90 b/gcc/testsuite/gfortran.dg/spec_expr_8.f90 new file mode 100644 index 00000000000..5885810d421 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/spec_expr_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/111781 +! We used to reject the example below because the dummy procedure g was +! setting the current namespace without properly restoring it, which broke +! the specification expression check for the dimension of A later on. +! +! Contributed by Markus Vikhamar-Sandberg + +program example + implicit none + integer :: n + +contains + + subroutine f(g,A) + real, intent(out) :: A(n) + interface + pure real(8) function g(x) + real(8), intent(in) :: x + end function + end interface + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/spec_expr_9.f90 b/gcc/testsuite/gfortran.dg/spec_expr_9.f90 new file mode 100644 index 00000000000..9024909b4e9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/spec_expr_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/111781 +! Used to fail with Error: Variable ‘n’ cannot appear in the +! expression at (1) for line 16. +! +program is_it_valid + dimension y(3) + integer :: n = 3 + interface + function func(x) + import + dimension func(n) + end function + end interface + y=func(1.0) + print *, y + stop +end