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

gcc/fortran/ChangeLog

+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

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)
 	{

gcc/testsuite/ChangeLog

+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.
+
 2012-08-02  Richard Guenther  <rguenther@suse.de>
 
 	* gcc.dg/torture/pta-callused-1.c: Adjust.

gcc/testsuite/gfortran.dg/abstract_type_6.f03

@@ -10,7 +10,7 @@
 module m
 TYPE, ABSTRACT :: top
 CONTAINS
-   PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be a module procedure" }
+   PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be explicit" }
    ! some useful default behaviour
    PROCEDURE :: proc_c => top_c ! { dg-error "must be a module procedure" }
 END TYPE top

gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90

@@ -24,10 +24,13 @@ type :: t
   procedure, pointer, nopass :: ptr6             ! { dg-error "Syntax error" }
   procedure(), nopass :: ptr8                    ! { dg-error "POINTER attribute is required" }
   procedure(pp), pointer, nopass :: ptr9         ! { dg-error "declared in a later PROCEDURE statement" }
-  procedure(aaargh), pointer, nopass :: ptr10    ! { dg-error "must be explicit" }
   real :: y
 end type t
 
+type :: t2
+  procedure(aaargh), pointer, nopass :: ptr10    ! { dg-error "must be explicit" }
+end type
+
 type,bind(c) :: bct                   ! { dg-error "BIND.C. derived type" }
   procedure(), pointer,nopass :: ptr  ! { dg-error "cannot be a member of|may not be C interoperable" }
 end type bct
@@ -47,4 +50,3 @@ print *,x%ptr3()  ! { dg-error "attribute conflicts with" }
 call x%y          ! { dg-error "Expected type-bound procedure or procedure pointer component" }
 
 end
-

gcc/testsuite/gfortran.dg/proc_ptr_comp_35.f90

+! { dg-do compile }
+!
+! PR 54147: [F03] Interface checks for PPCs & deferred TBPs
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  interface gen
+    procedure gen
+  end interface
+
+  type t1
+    procedure(gen),pointer,nopass  :: p1
+    procedure(gen2),pointer,nopass :: p2  ! { dg-error "may not be generic" }
+  end type
+
+  type t2
+    procedure(sf),pointer,nopass   :: p3  ! { dg-error "may not be a statement function" }
+  end type
+
+  type t3
+    procedure(char),pointer,nopass :: p4  ! { dg-error "Intrinsic procedure" }
+  end type
+
+  interface gen2
+    procedure gen
+  end interface
+
+  sf(x) = x**2  ! { dg-warning "Obsolescent feature" }
+
+contains
+
+  subroutine gen
+  end subroutine
+
+end

gcc/testsuite/gfortran.dg/typebound_proc_26.f90

+! { dg-do compile }
+!
+! PR 54147: [F03] Interface checks for PPCs & deferred TBPs
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  interface gen
+    procedure gen
+  end interface
+
+  type, abstract :: t1
+  contains
+    procedure(gen),deferred,nopass  :: p1
+    procedure(gen2),deferred,nopass :: p2  ! { dg-error "may not be generic" }
+  end type
+
+  type, abstract :: t2
+  contains
+    procedure(sf),deferred,nopass   :: p3  ! { dg-error "may not be a statement function" }
+  end type
+
+  type, abstract :: t3
+  contains
+    procedure(char),deferred,nopass :: p4  ! { dg-error "Intrinsic procedure" }
+  end type
+
+  interface gen2
+    procedure gen
+  end interface
+
+  sf(x) = x**2  ! { dg-warning "Obsolescent feature" }
+
+contains
+
+  subroutine gen
+  end subroutine
+
+end

gcc/testsuite/gfortran.dg/typebound_proc_9.f03

@@ -21,7 +21,7 @@ MODULE testmod
     PROCEDURE, DEFERRED :: p2 ! { dg-error "Interface must be specified" }
     PROCEDURE(intf), NOPASS :: p3 ! { dg-error "should be declared DEFERRED" }
     PROCEDURE(intf), DEFERRED, NON_OVERRIDABLE :: p4 ! { dg-error "can't both" }
-    PROCEDURE(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|module procedure" }
+    PROCEDURE(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|must be explicit" }
     PROCEDURE(intf), DEFERRED, DEFERRED :: p6 ! { dg-error "Duplicate DEFERRED" }
     PROCEDURE(intf), DEFERRED :: p6 => proc ! { dg-error "is invalid for DEFERRED" }
     PROCEDURE(), DEFERRED :: p7 ! { dg-error "Interface-name expected" }