&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
+ gfc_symbol *def_sym;
+
/* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
}
}
+ def_sym = gsym->ns->proc_name;
+ if (def_sym->attr.entry_master)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
+
/* Differences in constant character lengths. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
long int l1 = 0, l2 = 0;
gfc_charlen *cl1 = sym->ts.u.cl;
- gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
+ gfc_charlen *cl2 = def_sym->ts.u.cl;
if (cl1 != NULL
&& cl1->length != NULL
/* Type mismatch of function return type and expected type. */
if (sym->attr.function
- && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
+ && !gfc_compare_types (&sym->ts, &def_sym->ts))
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
- gfc_typename (&gsym->ns->proc_name->ts));
+ gfc_typename (&def_sym->ts));
- if (gsym->ns->proc_name->formal)
+ if (def_sym->formal)
{
- gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
+ gfc_formal_arglist *arg = def_sym->formal;
for ( ; arg; arg = arg->next)
if (!arg->sym)
continue;
}
}
- if (gsym->ns->proc_name->attr.function)
+ if (def_sym->attr.function)
{
/* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
- if (gsym->ns->proc_name->as
- && gsym->ns->proc_name->as->rank
- && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
+ if (def_sym->as && def_sym->as->rank
+ && (!sym->as || sym->as->rank != def_sym->as->rank))
gfc_error ("The reference to function '%s' at %L either needs an "
"explicit INTERFACE or the rank is incorrect", sym->name,
where);
/* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
- if (gsym->ns->proc_name->result->attr.pointer
- || gsym->ns->proc_name->result->attr.allocatable)
+ if (def_sym->result->attr.pointer
+ || def_sym->result->attr.allocatable)
gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
"result must have an explicit interface", sym->name,
where);
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
if (sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
}
/* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
- if (gsym->ns->proc_name->attr.elemental)
+ if (def_sym->attr.elemental)
{
gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
"interface", sym->name, &sym->declared_at);
}
/* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
- if (gsym->ns->proc_name->attr.is_bind_c)
+ if (def_sym->attr.is_bind_c)
{
gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
"an explicit interface", sym->name, &sym->declared_at);
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
- gfc_procedure_use (gsym->ns->proc_name, actual, where);
+ gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
}
gfc_symtree *st;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = e->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = e->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && e->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : e->value.function.esym->name;
+ e->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (e, "$vptr");
+ gfc_add_component_ref (e, name);
+ e->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_compcall (e, NULL);
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = code->expr1->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = code->expr1->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && code->expr1->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : code->expr1->value.function.esym->name;
+ code->expr1->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, name);
+ code->expr1->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_typebound_call (code, NULL);
OSDN Git Service
