From patchwork Tue Mar 19 15:49:16 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1913694 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=oZVrGKza; dkim=pass (2048-bit key; unprotected) header.d=wanadoo.fr header.i=@wanadoo.fr header.a=rsa-sha256 header.s=t20230301 header.b=IIABNWcY; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4Tzbpj1mhjz1yWn for ; Wed, 20 Mar 2024 02:53:01 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 41EC03858427 for ; Tue, 19 Mar 2024 15:52:59 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 41EC03858427 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1710863579; bh=NdrRki1FXZSQfdcTS3mzOgcj8ieQC7qgVW5HB5xrj9o=; h=From:To:Subject:Date:In-Reply-To:References:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:List-Subscribe: From; b=oZVrGKzaeVukffY0iidQJogr02J+eRNKFLVIf4O/LLgLW3/EbW/sVHXu2piJEs75j bHgNbzvgEuHA5qeQdvrbHGo6S5dk7v/3gWxf5fA0n8AZ2UUaxvioZ0chiDnS1eJLlt owBtBrxpMwhMINsm2gap9Y5H+zONvyGemYLkJKXw= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-208.smtpout.orange.fr [193.252.23.208]) by sourceware.org (Postfix) with ESMTPS id 1870C3858C35; Tue, 19 Mar 2024 15:49:24 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1870C3858C35 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 1870C3858C35 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.208 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710863366; cv=none; b=SL26M/WmGmbK/GobfK5PVKhhWWzXFseJVwC+C/XGG8PcyEU6CM5cZpwFMb7IF/g6N89DRQtUbRk6LtqpfmNHKw8qfPJ9VGtgDiRBaqj96ZC8TMDe7NgqLnVHZDy3xw1fjamngXtwO49dyWXGj/v83eDziCTwcqUcvNNtiF2CSXA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710863366; c=relaxed/simple; bh=UoFGMchFjj0mx5AqNpyJWM/MZ3DODXB63oa6rxePTxk=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=RCxDmPxhbi+qA6QIuTNcju2c8rm4I1UzTfmkINbZOX0ed4rNhSRYQjEtoPBKu+bmn+XCuaKn2mrnNAWU98W4HwY5ChpXvgKvGiA554MRFbOq1+Qo1b6Lc/kt1DXAHrDyiTe/wamQajyvpk79kOZAUrejeo5qPIy++Ei1vbGaGJo= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id mbiGrBQnQMNzSmbiMr9FMj; Tue, 19 Mar 2024 16:49:23 +0100 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1710863363; bh=NdrRki1FXZSQfdcTS3mzOgcj8ieQC7qgVW5HB5xrj9o=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=IIABNWcYabcKt5ECeJmGHH9YOVvnl8D6SmzjEeoQTXdXJIVUcMrWkmeKT6Kdi263y S2+pfbcTY104Rjrnlvc/lC356yiE/a0zPmAROl5vOu2cwV7cmM3AJRYDdry8QxKldP efPK0huTgwObHMumLsKup0iuOP5wOcjKCyKgUXDYisadsZ2mZddguEqmRltRZ/huTF iVKh0HgIdF/nFmaRAeVXSjjHosvrKj+NR0n08xTRk45fYtxm+Z0MqHuoqlSNplVG3m lDnnYPsHL+0mTzZP/YDD++1QvnqhZZIKYnnDavI0N6/zQMzoPlMCKI4xJDvUR/Am/X gnNLcXjMLeQzA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Tue, 19 Mar 2024 16:49:23 +0100 X-ME-IP: 86.215.161.51 From: Mikael Morin To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH v3 2/2] fortran: Fix specification expression error with dummy procedures [PR111781] Date: Tue, 19 Mar 2024 16:49:16 +0100 Message-ID: <20240319154918.272178-3-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240319154918.272178-1-mikael@gcc.gnu.org> References: <20240319154918.272178-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-10.8 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+incoming=patchwork.ozlabs.org@gcc.gnu.org This fixes a spurious invalid variable in specification expression error. The error was caused on the testcase from the PR by two different bugs. First, the call to is_parent_of_current_ns was unable to recognize correct host association and returned false. Second, an ad-hoc condition coming next was using a global variable previously improperly restored to false (instead of restoring it to its initial value). The latter happened on the testcase because one dummy argument was a procedure, and checking that argument what causing a check of all its arguments with the (improper) reset of the flag at the end, and that preceded the check of the next argument. For the first bug, the wrong result of is_parent_of_current_ns is fixed by correcting the namespaces that function deals with, both the one passed as argument and the current one tracked in the gfc_current_ns global. Two new functions are introduced to select the right namespace. Regarding the second bug, the problematic condition is removed, together with the formal_arg_flag associated with it. Indeed, that condition was (wrongly) allowing local variables to be used in array bounds of dummy arguments. 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 special case allowing local variable in dummy argument bound expressions. 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 | 58 +++++++++++++++++ gcc/testsuite/gfortran.dg/spec_expr_8.f90 | 24 +++++++ gcc/testsuite/gfortran.dg/spec_expr_9.f90 | 19 ++++++ 6 files changed, 140 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 e4b1e8307e3..9a042cd7040 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -3514,19 +3514,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 c7039730fad..26aa56b3358 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3612,6 +3612,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; @@ -3821,7 +3824,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 c5ae826bd6e..50d51b06c92 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; } @@ -16206,6 +16200,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. */ @@ -16220,7 +16234,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; @@ -16385,16 +16398,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'. */ @@ -16961,18 +16965,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 16adb2a7efb..3a3b6de5cec 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5408,3 +5408,61 @@ 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); + /* Generic and intrinsic functions can have a null result. */ + else if (sym->result != nullptr) + 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..77e14156497 --- /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 Rasmus 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