re PR fortran/54147 ([F03] Interface checks for PPCs & deferred TBPs)

2012-08-02  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54147
	* resolve.c (check_proc_interface): New routine for PROCEDURE interface
	checks.
	(resolve_procedure_interface,resolve_typebound_procedure,
	resolve_fl_derived0): Call it.

2012-08-02  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54147
	* gfortran.dg/abstract_type_6.f03: Modified.
	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
	* gfortran.dg/proc_ptr_comp_35.f90: New.
	* gfortran.dg/typebound_proc_9.f03: Modified.
	* gfortran.dg/typebound_proc_26.f90: New.

From-SVN: r190069

2 files changed, 71 insertions, 59 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a2b69d4..5ed954a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2012-08-02  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54147
+	* resolve.c (check_proc_interface): New routine for PROCEDURE interface
+	checks.
+	(resolve_procedure_interface,resolve_typebound_procedure,
+	resolve_fl_derived0): Call it.
+
 2012-08-01  Thomas König  <tkoenig@gcc.gnu.org>
 
 	PR fortran/54033
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a6dd0da..c5810b2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -138,31 +138,14 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
 }
 
 
-static void resolve_symbol (gfc_symbol *sym);
-
-
-/* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
-
 static gfc_try
-resolve_procedure_interface (gfc_symbol *sym)
+check_proc_interface (gfc_symbol *ifc, locus *where)
 {
-  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 (ifc->attr.procedure)
     {
-      gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
-		 "in a later PROCEDURE statement", ifc->name,
-		 sym->name, &sym->declared_at);
+      gfc_error ("Interface '%s' at %L is declared "
+		 "in a later PROCEDURE statement", ifc->name, where);
       return FAILURE;
     }
   if (ifc->generic)
@@ -175,14 +158,14 @@ resolve_procedure_interface (gfc_symbol *sym)
       if (!gen)
 	{
 	  gfc_error ("Interface '%s' at %L may not be generic",
-		     ifc->name, &sym->declared_at);
+		     ifc->name, where);
 	  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);
+		 ifc->name, where);
       return FAILURE;
     }
   if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
@@ -191,15 +174,44 @@ resolve_procedure_interface (gfc_symbol *sym)
   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);
+		 "PROCEDURE statement at %L", ifc->name, where);
+      return FAILURE;
+    }
+  if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+    {
+      gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
       return FAILURE;
     }
+  return SUCCESS;
+}
+
+
+static void resolve_symbol (gfc_symbol *sym);
+
+
+/* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
+
+static gfc_try
+resolve_procedure_interface (gfc_symbol *sym)
+{
+  gfc_symbol *ifc = sym->ts.interface;
+
+  if (!ifc)
+    return SUCCESS;
+
+  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 (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
+    return FAILURE;
 
-  /* Get the attributes from the interface (now resolved).  */
   if (ifc->attr.if_source || ifc->attr.intrinsic)
     {
+      /* Resolve interface and copy attributes.  */
       resolve_symbol (ifc);
-
       if (ifc->attr.intrinsic)
 	gfc_resolve_intrinsic (ifc, &ifc->declared_at);
 
@@ -246,12 +258,6 @@ resolve_procedure_interface (gfc_symbol *sym)
 	    return FAILURE;
 	}
     }
-  else if (ifc->name[0] != '\0')
-    {
-      gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
-		 ifc->name, sym->name, &sym->declared_at);
-      return FAILURE;
-    }
 
   return SUCCESS;
 }
@@ -11565,17 +11571,25 @@ resolve_typebound_procedure (gfc_symtree* stree)
   /* Default access should already be resolved from the parser.  */
   gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
 
-  /* It should be a module procedure or an external procedure with explicit
-     interface.  For DEFERRED bindings, abstract interfaces are ok as well.  */
-  if ((!proc->attr.subroutine && !proc->attr.function)
-      || (proc->attr.proc != PROC_MODULE
-	  && proc->attr.if_source != IFSRC_IFBODY)
-      || (proc->attr.abstract && !stree->n.tb->deferred))
+  if (stree->n.tb->deferred)
     {
-      gfc_error ("'%s' must be a module procedure or an external procedure with"
-		 " an explicit interface at %L", proc->name, &where);
-      goto error;
+      if (check_proc_interface (proc, &where) == FAILURE)
+	goto error;
+    }
+  else
+    {
+      /* Check for F08:C465.  */
+      if ((!proc->attr.subroutine && !proc->attr.function)
+	  || (proc->attr.proc != PROC_MODULE
+	      && proc->attr.if_source != IFSRC_IFBODY)
+	  || proc->attr.abstract)
+	{
+	  gfc_error ("'%s' must be a module procedure or an external procedure with"
+		    " an explicit interface at %L", proc->name, &where);
+	  goto error;
+	}
     }
+
   stree->n.tb->subroutine = proc->attr.subroutine;
   stree->n.tb->function = proc->attr.function;
 
@@ -11928,20 +11942,17 @@ resolve_fl_derived0 (gfc_symbol *sym)
 
       if (c->attr.proc_pointer && c->ts.interface)
 	{
-	  if (c->ts.interface->attr.procedure && !sym->attr.vtype)
-	    gfc_error ("Interface '%s', used by procedure pointer component "
-		       "'%s' at %L, is declared in a later PROCEDURE statement",
-		       c->ts.interface->name, c->name, &c->loc);
+	  gfc_symbol *ifc = c->ts.interface;
 
-	  /* Get the attributes from the interface (now resolved).  */
-	  if (c->ts.interface->attr.if_source
-	      || c->ts.interface->attr.intrinsic)
-	    {
-	      gfc_symbol *ifc = c->ts.interface;
+	  if (!sym->attr.vtype
+	      && check_proc_interface (ifc, &c->loc) == FAILURE)
+	    return FAILURE;
 
+	  if (ifc->attr.if_source || ifc->attr.intrinsic)
+	    {
+	      /* Resolve interface and copy attributes.  */
 	      if (ifc->formal && !ifc->formal_ns)
 		resolve_symbol (ifc);
-
 	      if (ifc->attr.intrinsic)
 		gfc_resolve_intrinsic (ifc, &ifc->declared_at);
 
@@ -11980,25 +11991,18 @@ resolve_fl_derived0 (gfc_symbol *sym)
 		      gfc_expr_replace_comp (c->as->lower[i], c);
 		      gfc_expr_replace_comp (c->as->upper[i], c);
 		    }
-	        }
+		}
 	      /* Copy char length.  */
 	      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
 		{
 		  gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
 		  gfc_expr_replace_comp (cl->length, c);
 		  if (cl->length && !cl->resolved
-		        && gfc_resolve_expr (cl->length) == FAILURE)
+			&& gfc_resolve_expr (cl->length) == FAILURE)
 		    return FAILURE;
 		  c->ts.u.cl = cl;
 		}
 	    }
-	  else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
-	    {
-	      gfc_error ("Interface '%s' of procedure pointer component "
-			 "'%s' at %L must be explicit", c->ts.interface->name,
-			 c->name, &c->loc);
-	      return FAILURE;
- 	    }
 	}
       else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
 	{