gfc_current_ns = old_ns;
*proc_if = st->n.sym;
- /* Various interface checks. */
if (*proc_if)
{
(*proc_if)->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
- invalid per C1212. */
+ invalid per F08:C1216 (cf. resolve_procedure_interface). */
while ((*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
- if ((*proc_if)->generic)
- {
- gfc_error ("Interface '%s' at %C may not be generic",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Interface '%s' at %C may not be a statement function",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- /* Handle intrinsic procedures. */
- if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
- || (*proc_if)->attr.if_source == IFSRC_IFBODY)
- && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
- || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
- (*proc_if)->attr.intrinsic = 1;
- if ((*proc_if)->attr.intrinsic
- && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
- {
- gfc_error ("Intrinsic procedure '%s' not allowed "
- "in PROCEDURE statement at %C", (*proc_if)->name);
- return MATCH_ERROR;
- }
+ if ((*proc_if)->attr.flavor == FL_UNKNOWN
+ && (*proc_if)->ts.type == BT_UNKNOWN
+ && gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
+ (*proc_if)->name, NULL) == FAILURE)
+ return MATCH_ERROR;
}
got_ts:
}
-/* Given a symbol, find out if it is (and is to be treated) an intrinsic. If
- it's name refers to an intrinsic but this intrinsic is not included in the
- selected standard, this returns FALSE and sets the symbol's external
+/* Given a symbol, find out if it is (and is to be treated as) an intrinsic.
+ If its name refers to an intrinsic, but this intrinsic is not included in
+ the selected standard, this returns FALSE and sets the symbol's external
attribute. */
bool
gfc_intrinsic_sym* isym;
const char* symstd;
- /* If INTRINSIC/EXTERNAL state is already known, return. */
+ /* If INTRINSIC attribute is already known, return. */
if (sym->attr.intrinsic)
return true;
- if (sym->attr.external)
+
+ /* Check for attributes which prevent the symbol from being INTRINSIC. */
+ if (sym->attr.external || sym->attr.contained
+ || sym->attr.if_source == IFSRC_IFBODY)
return false;
if (subroutine_flag)
static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
- if (sym->ts.interface == sym)
+ 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 (sym->ts.interface->attr.procedure)
+ if (ifc->attr.procedure)
{
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
- "in a later PROCEDURE statement", sym->ts.interface->name,
+ "in a later PROCEDURE statement", ifc->name,
sym->name, &sym->declared_at);
return FAILURE;
}
+ if (ifc->generic)
+ {
+ /* For generic interfaces, check if there is
+ a specific procedure with the same name. */
+ gfc_interface *gen = ifc->generic;
+ while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+ gen = gen->next;
+ if (!gen)
+ {
+ gfc_error ("Interface '%s' at %L may not be generic",
+ ifc->name, &sym->declared_at);
+ 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);
+ return FAILURE;
+ }
+ if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
+ || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
+ ifc->attr.intrinsic = 1;
+ 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);
+ return FAILURE;
+ }
/* Get the attributes from the interface (now resolved). */
- if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+ if (ifc->attr.if_source || ifc->attr.intrinsic)
{
- gfc_symbol *ifc = sym->ts.interface;
resolve_symbol (ifc);
if (ifc->attr.intrinsic)
return FAILURE;
}
}
- else if (sym->ts.interface->name[0] != '\0')
+ else if (ifc->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
- sym->ts.interface->name, sym->name, &sym->declared_at);
+ ifc->name, sym->name, &sym->declared_at);
return FAILURE;
}
&proc->declared_at);
continue;
}
- else if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL)
- resolve_procedure_interface (sym);
+ else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
+ && resolve_procedure_interface (sym) == FAILURE)
+ return;
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
- if (!sym->attr.intrinsic
- && !(sym->attr.external || sym->attr.use_assoc
- || sym->attr.if_source == IFSRC_IFBODY)
- && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
+ if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
is_external_proc (gfc_symbol *sym)
{
if (!sym->attr.dummy && !sym->attr.contained
- && !(sym->attr.intrinsic
- || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
+ && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.proc_pointer
&& !sym->attr.use_assoc
if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
- if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL
+ if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
&& resolve_procedure_interface (sym) == FAILURE)
return;