===================================================================
@@ -1858,29 +1858,6 @@ resolve_global_procedure (gfc_symbol *sy
}
}
- if (gsym->ns->proc_name->attr.function
- && gsym->ns->proc_name->as
- && gsym->ns->proc_name->as->rank
- && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
- gfc_error ("The reference to function '%s' at %L either needs an "
- "explicit INTERFACE or the rank is incorrect", sym->name,
- where);
-
- /* Non-assumed length character functions. */
- if (sym->attr.function && sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
- {
- gfc_charlen *cl = sym->ts.u.cl;
-
- if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Nonconstant character-length function '%s' at %L "
- "must have an explicit interface", sym->name,
- &sym->declared_at);
- }
- }
-
/* Differences in constant character lengths. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
@@ -1911,26 +1888,108 @@ resolve_global_procedure (gfc_symbol *sy
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&gsym->ns->proc_name->ts));
- /* Assumed shape arrays as dummy arguments. */
if (gsym->ns->proc_name->formal)
{
gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
for ( ; arg; arg = arg->next)
- if (arg->sym && arg->sym->as
- && arg->sym->as->type == AS_ASSUMED_SHAPE)
+ if (!arg->sym)
+ continue;
+ /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
+ else if (arg->sym->attr.allocatable
+ || arg->sym->attr.asynchronous
+ || arg->sym->attr.optional
+ || arg->sym->attr.pointer
+ || arg->sym->attr.target
+ || arg->sym->attr.value
+ || arg->sym->attr.volatile_)
+ {
+ gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
+ "has an attribute that requires an explicit "
+ "interface for this procedure", arg->sym->name,
+ sym->name, &sym->declared_at);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
- "'%s' argument must have an explicit interface",
+ "argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
- else if (arg->sym && arg->sym->attr.optional)
+ /* F2008, 12.4.2.2 (2c) */
+ else if (arg->sym->attr.codimension)
{
- gfc_error ("Procedure '%s' at %L with optional dummy argument "
+ gfc_error ("Procedure '%s' at %L with coarray dummy argument "
"'%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
+ else if (false) /* TODO: is a parametrized derived type */
+ {
+ gfc_error ("Procedure '%s' at %L with parametrized derived "
+ "type argument '%s' must have an explicit "
+ "interface", sym->name, &sym->declared_at,
+ arg->sym->name);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
+ else if (arg->sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("Procedure '%s' at %L with polymorphic dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
+ }
+
+ if (gsym->ns->proc_name->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))
+ 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)
+ 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)
+ {
+ gfc_charlen *cl = sym->ts.u.cl;
+
+ if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Nonconstant character-length function '%s' at %L "
+ "must have an explicit interface", sym->name,
+ &sym->declared_at);
+ }
+ }
+ }
+
+ /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
+ if (gsym->ns->proc_name->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)
+ {
+ gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
+ "an explicit interface", sym->name, &sym->declared_at);
}
if (gfc_option.flag_whole_file == 1
Hi all. Thanks to Tobias B., here's the full patch to does the checks for required explicit interfaces more systematically. Only one testcase for the new branches, the rest is mostly checked already. gcc/fortran/: 2010-06-12 Daniel Franke <franke.daniel@gmail.com> * resolve.c (resolve_global_procedure): Improved checking if an explicit interface is required. gcc/testsuite/: 2010-06-12 Daniel Franke <franke.daniel@gmail.com> * gfortran.dg/whole_file_20.f03: New. Regression tested on i686-pc-linux-gnu. Ok for trunk and 4.5? Daniel ! { dg-do "compile" } ! { dg-options "-fwhole-file -fcoarray=single" } ! ! Procedures with dummy arguments that are coarrays or polymorphic ! must have an explicit interface in the calling routine. ! MODULE classtype type :: t integer :: comp end type END MODULE PROGRAM main USE classtype CLASS(t), POINTER :: tt INTEGER :: coarr[*] CALL coarray(coarr) ! { dg-error " must have an explicit interface" } CALL polymorph(tt) ! { dg-error " must have an explicit interface" } END PROGRAM SUBROUTINE coarray(a) INTEGER :: a[*] END SUBROUTINE SUBROUTINE polymorph(b) USE classtype CLASS(t) :: b END SUBROUTINE ! { dg-final { cleanup-modules "classtype" } }