@@ -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;
@@ -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 *);
@@ -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
@@ -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;
+}
new file mode 100644
@@ -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 <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
new file mode 100644
@@ -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