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;
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 *);
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;
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)
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)
{
&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);
}
}
}
- formal_arg_flag = false;
+
+ gfc_current_ns = orig_current_ns;
}
}
+/* 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. */
gfc_component *c;
symbol_attribute class_attr;
gfc_array_spec *as;
- bool saved_specification_expr;
if (sym->resolve_symbol_called >= 1)
return;
}
}
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'. */
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
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;
+}
projects / thirdparty / gcc.git / commitdiff
