}
-static void resolve_symbol (gfc_symbol *sym);
-
-
-/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
-
static gfc_try
-resolve_procedure_interface (gfc_symbol *sym)
+check_proc_interface (gfc_symbol *ifc, locus *where)
{
- gfc_symbol *ifc = sym->ts.interface;
-
- if (!ifc)
- return SUCCESS;
-
/* Several checks for F08:C1216. */
- if (ifc == sym)
- {
- gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
- sym->name, &sym->declared_at);
- return FAILURE;
- }
if (ifc->attr.procedure)
{
- gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
- "in a later PROCEDURE statement", ifc->name,
- sym->name, &sym->declared_at);
+ gfc_error ("Interface '%s' at %L is declared "
+ "in a later PROCEDURE statement", ifc->name, where);
return FAILURE;
}
if (ifc->generic)
if (!gen)
{
gfc_error ("Interface '%s' at %L may not be generic",
- ifc->name, &sym->declared_at);
+ ifc->name, where);
return FAILURE;
}
}
if (ifc->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface '%s' at %L may not be a statement function",
- ifc->name, &sym->declared_at);
+ ifc->name, where);
return FAILURE;
}
if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
{
gfc_error ("Intrinsic procedure '%s' not allowed in "
- "PROCEDURE statement at %L", ifc->name, &sym->declared_at);
+ "PROCEDURE statement at %L", ifc->name, where);
+ return FAILURE;
+ }
+ if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+ {
+ gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
return FAILURE;
}
+ return SUCCESS;
+}
+
+
+static void resolve_symbol (gfc_symbol *sym);
+
+
+/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
+
+static gfc_try
+resolve_procedure_interface (gfc_symbol *sym)
+{
+ gfc_symbol *ifc = sym->ts.interface;
+
+ if (!ifc)
+ return SUCCESS;
+
+ if (ifc == sym)
+ {
+ gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ if (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
+ return FAILURE;
- /* Get the attributes from the interface (now resolved). */
if (ifc->attr.if_source || ifc->attr.intrinsic)
{
+ /* Resolve interface and copy attributes. */
resolve_symbol (ifc);
-
if (ifc->attr.intrinsic)
gfc_resolve_intrinsic (ifc, &ifc->declared_at);
return FAILURE;
}
}
- else if (ifc->name[0] != '\0')
- {
- gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
- ifc->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
return SUCCESS;
}
/* Default access should already be resolved from the parser. */
gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
- /* It should be a module procedure or an external procedure with explicit
- interface. For DEFERRED bindings, abstract interfaces are ok as well. */
- if ((!proc->attr.subroutine && !proc->attr.function)
- || (proc->attr.proc != PROC_MODULE
- && proc->attr.if_source != IFSRC_IFBODY)
- || (proc->attr.abstract && !stree->n.tb->deferred))
+ if (stree->n.tb->deferred)
{
- gfc_error ("'%s' must be a module procedure or an external procedure with"
- " an explicit interface at %L", proc->name, &where);
- goto error;
+ if (check_proc_interface (proc, &where) == FAILURE)
+ goto error;
+ }
+ else
+ {
+ /* Check for F08:C465. */
+ if ((!proc->attr.subroutine && !proc->attr.function)
+ || (proc->attr.proc != PROC_MODULE
+ && proc->attr.if_source != IFSRC_IFBODY)
+ || proc->attr.abstract)
+ {
+ gfc_error ("'%s' must be a module procedure or an external procedure with"
+ " an explicit interface at %L", proc->name, &where);
+ goto error;
+ }
}
+
stree->n.tb->subroutine = proc->attr.subroutine;
stree->n.tb->function = proc->attr.function;
if (c->attr.proc_pointer && c->ts.interface)
{
- if (c->ts.interface->attr.procedure && !sym->attr.vtype)
- gfc_error ("Interface '%s', used by procedure pointer component "
- "'%s' at %L, is declared in a later PROCEDURE statement",
- c->ts.interface->name, c->name, &c->loc);
+ gfc_symbol *ifc = c->ts.interface;
- /* Get the attributes from the interface (now resolved). */
- if (c->ts.interface->attr.if_source
- || c->ts.interface->attr.intrinsic)
- {
- gfc_symbol *ifc = c->ts.interface;
+ if (!sym->attr.vtype
+ && check_proc_interface (ifc, &c->loc) == FAILURE)
+ return FAILURE;
+ if (ifc->attr.if_source || ifc->attr.intrinsic)
+ {
+ /* Resolve interface and copy attributes. */
if (ifc->formal && !ifc->formal_ns)
resolve_symbol (ifc);
-
if (ifc->attr.intrinsic)
gfc_resolve_intrinsic (ifc, &ifc->declared_at);
gfc_expr_replace_comp (c->as->lower[i], c);
gfc_expr_replace_comp (c->as->upper[i], c);
}
- }
+ }
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_comp (cl->length, c);
if (cl->length && !cl->resolved
- && gfc_resolve_expr (cl->length) == FAILURE)
+ && gfc_resolve_expr (cl->length) == FAILURE)
return FAILURE;
c->ts.u.cl = cl;
}
}
- else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
- {
- gfc_error ("Interface '%s' of procedure pointer component "
- "'%s' at %L must be explicit", c->ts.interface->name,
- c->name, &c->loc);
- return FAILURE;
- }
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
projects / thirdparty / gcc.git / commitdiff
