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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160663 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 911184b..02d6d4c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4b4c505..d5fa370 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5041fc5..b3129f1 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/whole_file_20.f03 b/gcc/testsuite/gfortran.dg/whole_file_20.f03
new file mode 100644 (file)
index 0000000..231a5aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_20.f03
@@ -0,0 +1,33 @@
+! { 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" } }