continue;
}
- if (e->expr_type == FL_VARIABLE
+ if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
{
gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
- gfc_symbol *csym;
+ gfc_symbol *csym, *sym;
bool no_formal_args;
csym = c->symtree ? c->symtree->n.sym : NULL;
return FAILURE;
}
+ if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
+ {
+ gfc_find_symbol (csym->name, gfc_current_ns, 1, &sym);
+ if (sym && csym != sym
+ && sym->ns == gfc_current_ns
+ && sym->attr.flavor == FL_PROCEDURE
+ && sym->attr.contained)
+ {
+ sym->refs++;
+ csym = sym;
+ c->symtree->n.sym = sym;
+ }
+ }
+
/* If external, check for usage. */
if (csym && is_external_proc (csym))
resolve_global_procedure (csym, &c->loc, 1);
t = SUCCESS;
if (c->resolved_sym == NULL)
- switch (procedure_kind (csym))
- {
- case PTYPE_GENERIC:
- t = resolve_generic_s (c);
- break;
+ {
+ c->resolved_isym = NULL;
+ switch (procedure_kind (csym))
+ {
+ case PTYPE_GENERIC:
+ t = resolve_generic_s (c);
+ break;
- case PTYPE_SPECIFIC:
- t = resolve_specific_s (c);
- break;
+ case PTYPE_SPECIFIC:
+ t = resolve_specific_s (c);
+ break;
- case PTYPE_UNKNOWN:
- t = resolve_unknown_s (c);
- break;
+ case PTYPE_UNKNOWN:
+ t = resolve_unknown_s (c);
+ break;
- default:
- gfc_internal_error ("resolve_subroutine(): bad function type");
- }
+ default:
+ gfc_internal_error ("resolve_subroutine(): bad function type");
+ }
+ }
/* Some checks of elemental subroutine actual arguments. */
if (resolve_elemental_actual (NULL, c) == FAILURE)
old_sym = e->symtree->n.sym;
- if (old_sym->attr.use_assoc)
- return retval;
-
if (gfc_current_ns->parent
&& old_sym->ns != gfc_current_ns)
{
gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
if (sym && old_sym != sym
+ && sym->ts.type == old_sym->ts.type
&& sym->attr.flavor == FL_PROCEDURE
&& sym->attr.contained)
{
else
{
/* If one of the FORALL index variables doesn't appear in the
- assignment target, then there will be a many-to-one
- assignment. */
+ assignment variable, then there could be a many-to-one
+ assignment. Emit a warning rather than an error because the
+ mask could be resolving this problem. */
if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
- gfc_error ("The FORALL with index '%s' cause more than one "
- "assignment to this object at %L",
- var_expr[n]->symtree->name, &code->expr->where);
+ gfc_warning ("The FORALL with index '%s' is not used on the "
+ "left side of the assignment at %L and so might "
+ "cause multiple assignment to this object",
+ var_expr[n]->symtree->name, &code->expr->where);
}
}
}
sym->attr.dimension = ifc->attr.dimension;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
- sym->as = gfc_copy_array_spec (ifc->as);
copy_formal_args (sym, ifc);
+ /* Copy array spec. */
+ sym->as = gfc_copy_array_spec (ifc->as);
+ if (sym->as)
+ {
+ int i;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ gfc_expr_replace_symbols (sym->as->lower[i], sym);
+ gfc_expr_replace_symbols (sym->as->upper[i], sym);
+ }
+ }
+ /* Copy char length. */
+ if (ifc->ts.cl)
+ {
+ sym->ts.cl = gfc_get_charlen();
+ sym->ts.cl->resolved = ifc->ts.cl->resolved;
+ sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+ gfc_expr_replace_symbols (sym->ts.cl->length, sym);
+ /* Add charlen to namespace. */
+ if (sym->formal_ns)
+ {
+ sym->ts.cl->next = sym->formal_ns->cl_list;
+ sym->formal_ns->cl_list = sym->ts.cl;
+ }
+ }
}
else if (sym->ts.interface->name[0] != '\0')
{