Skip to content

R
riscv-gcc-1
Commit 1b1a6626 by Daniel Franke Committed by Daniel Franke
Options

resolve.c (resolve_global_procedure): Improved checking if an explicit interface is required. 

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.

From-SVN: r160663
parent 57e215e4
Showing with 130 additions and 29 deletions
gcc/fortran/ChangeLog
2010-06-12 Daniel Franke <franke.daniel@gmail.com>
* resolve.c (resolve_global_procedure): Improved checking if an
explicit interface is required.
2010-06-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* trans-decl.c (gfc_build_intrinsic_function_decls): Fix
......
gcc/fortran/resolve.c
......@@ -1858,29 +1858,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
}
}
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 *sym, locus *where,
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
......
gcc/testsuite/ChangeLog
2010-06-12 Daniel Franke <franke.daniel@gmail.com>
* gfortran.dg/whole_file_20.f03: New.
2010-06-12 Jan Hubicka <jh@suse.cz>
* gcc.c-torture/compile/pc44485.c: New testcase.
......
gcc/testsuite/gfortran.dg/whole_file_20.f03 0 → 100644
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment