Re: [PATCH v3 2/2] fortran: Fix specification expression error with dummy procedures [PR111781]

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 14132 bytes --]

Hi Mikael,

This is very good. I am pleased to see global variables disappear and I
like the new helper functions.

As before, OK for mainline and, if you wish, 13-branch.

Thanks

Paul


On Tue, 19 Mar 2024 at 15:49, Mikael Morin <mikael@gcc.gnu.org> wrote:

> 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  <
> rasmus.vikhamar-sandberg@uit.no>
> +
> +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
> --
> 2.43.0
>
>