diff mbox

[fortran] further improve whole-file checks

Message ID 201006121415.55558.franke.daniel@gmail.com
State New
Headers show

Commit Message

Daniel Franke June 12, 2010, 12:15 p.m. UTC
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" } }

Comments

Tobias Burnus June 12, 2010, 1:03 p.m. UTC | #1
Daniel Franke wrote:
> here's the full patch to does the checks for required 
> explicit interfaces more systematically.
>
> Regression tested on i686-pc-linux-gnu.
> Ok for trunk and 4.5?
>   

OK for the trunk - I do not see a real need for the branch since it is
just diagnostics and the coarray check won't work. Thanks for the patch!

Tobias

> 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.
>
Daniel Franke June 12, 2010, 1:11 p.m. UTC | #2
On Saturday 12 June 2010 15:03:45 you wrote:
> Daniel Franke wrote:
> > here's the full patch to does the checks for required
> > explicit interfaces more systematically.
> > 
> > Regression tested on i686-pc-linux-gnu.
> > Ok for trunk and 4.5?
> 
> OK for the trunk - I do not see a real need for the branch since it is
> just diagnostics and the coarray check won't work. Thanks for the patch!

Thanks.

Paul suggested to apply (at least) the first version to 4.5 - I don't mind 
either way.

Cheers

        Daniel
diff mbox

Patch

Index: resolve.c
===================================================================
--- resolve.c	(revision 160638)
+++ resolve.c	(working copy)
@@ -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