re PR fortran/40117 ([OOP][F2008] Type-bound procedure: allow list after PROCEDURE)

2010-06-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40117
	* decl.c (match_procedure_in_type): Allow procedure lists (F08).


2010-06-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40117
	* gfortran.dg/typebound_proc_4.f03: Modified error message.
	* gfortran.dg/typebound_proc_14.f03: New.
	* gfortran.dg/typebound_proc_15.f03: New.

From-SVN: r160646

gcc/fortran/ChangeLog

@@ -1,3 +1,8 @@
+2010-06-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40117
+	* decl.c (match_procedure_in_type): Allow procedure lists (F08).
+
 2010-06-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment.

gcc/fortran/decl.c

@@ -7542,7 +7542,7 @@ match_procedure_in_type (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char target_buf[GFC_MAX_SYMBOL_LEN + 1];
-  char* target = NULL;
+  char* target = NULL, *ifc = NULL;
   gfc_typebound_proc* tb;
   bool seen_colons;
   bool seen_attrs;
@@ -7550,6 +7550,7 @@ match_procedure_in_type (void)
   gfc_symtree* stree;
   gfc_namespace* ns;
   gfc_symbol* block;
+  int num;
 
   /* Check current state.  */
   gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
@@ -7574,7 +7575,7 @@ match_procedure_in_type (void)
 	  return MATCH_ERROR;
 	}
 
-      target = target_buf;
+      ifc = target_buf;
     }
 
   /* Construct the data structure.  */
@@ -7588,14 +7589,13 @@ match_procedure_in_type (void)
     return m;
   seen_attrs = (m == MATCH_YES);
 
-  /* Check that attribute DEFERRED is given iff an interface is specified, which
+  /* Check that attribute DEFERRED is given if an interface is specified.  */
-     means target != NULL.  */
+  if (tb->deferred && !ifc)
-  if (tb->deferred && !target)
     {
       gfc_error ("Interface must be specified for DEFERRED binding at %C");
       return MATCH_ERROR;
     }
-  if (target && !tb->deferred)
+  if (ifc && !tb->deferred)
     {
       gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
       return MATCH_ERROR;
@@ -7612,7 +7612,9 @@ match_procedure_in_type (void)
       return MATCH_ERROR;
     }
 
-  /* Match the binding name.  */ 
+  /* Match the binding names.  */ 
+  for(num=1;;num++)
+    {
       m = gfc_match_name (name);
       if (m == MATCH_ERROR)
 	return m;
@@ -7622,7 +7624,12 @@ match_procedure_in_type (void)
 	  return MATCH_ERROR;
 	}
 
+      if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+				   " at %C") == FAILURE)
+	return MATCH_ERROR;
+
       /* Try to match the '=> target', if it's there.  */
+      target = ifc;
       m = gfc_match (" =>");
       if (m == MATCH_ERROR)
 	return m;
@@ -7652,16 +7659,6 @@ match_procedure_in_type (void)
 	  target = target_buf;
 	}
 
-  /* Now we should have the end.  */
-  m = gfc_match_eos ();
-  if (m == MATCH_ERROR)
-    return m;
-  if (m == MATCH_NO)
-    {
-      gfc_error ("Junk after PROCEDURE declaration at %C");
-      return MATCH_ERROR;
-    }
-
       /* If no target was found, it has the same name as the binding.  */
       if (!target)
 	target = name;
@@ -7673,19 +7670,19 @@ match_procedure_in_type (void)
       /* If the binding is DEFERRED, check that the containing type is ABSTRACT.  */
       if (tb->deferred && !block->attr.abstract)
 	{
-      gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
+	  gfc_error ("Type '%s' containing DEFERRED binding at %C "
-		 block->name);
+		     "is not ABSTRACT", block->name);
 	  return MATCH_ERROR;
 	}
 
-  /* See if we already have a binding with this name in the symtree which would
+      /* See if we already have a binding with this name in the symtree which
-     be an error.  If a GENERIC already targetted this binding, it may be
+	 would be an error.  If a GENERIC already targetted this binding, it may
-     already there but then typebound is still NULL.  */
+	 be already there but then typebound is still NULL.  */
       stree = gfc_find_symtree (ns->tb_sym_root, name);
       if (stree && stree->n.tb)
 	{
-      gfc_error ("There's already a procedure with binding name '%s' for the"
+	  gfc_error ("There is already a procedure with binding name '%s' for "
-		 " derived type '%s' at %C", name, block->name);
+		     "the derived type '%s' at %C", name, block->name);
 	  return MATCH_ERROR;
 	}
 
@@ -7702,7 +7699,15 @@ match_procedure_in_type (void)
 	return MATCH_ERROR;
       gfc_set_sym_referenced (tb->u.specific->n.sym);
   
+      if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
 }
 
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2010-06-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40117
+	* gfortran.dg/typebound_proc_4.f03: Modified error message.
+	* gfortran.dg/typebound_proc_14.f03: New.
+	* gfortran.dg/typebound_proc_15.f03: New.
+
 2010-06-11  Joseph Myers  <joseph@codesourcery.com>
 
 	* gcc.dg/opts-1.c: New test.

gcc/testsuite/gfortran.dg/typebound_proc_14.f03

@@ -0,0 +1,33 @@
+! { dg-do compile }
+!
+! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+implicit none
+
+type :: t
+contains
+  procedure :: foo, bar, baz
+end type
+
+contains
+
+  subroutine foo (this)
+    class(t) :: this
+  end subroutine
+
+  real function bar (this)
+    class(t) :: this
+  end function
+
+  subroutine baz (this, par)
+    class(t) :: this
+    integer :: par
+  end subroutine
+
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/typebound_proc_15.f03

@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org> 
+
+module m
+
+implicit none
+
+type :: t
+contains
+  procedure :: foo
+  procedure :: bar, baz  { dg-error "PROCEDURE list" }
+end type
+
+contains
+
+  subroutine foo (this)
+    class(t) :: this
+  end subroutine
+
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/typebound_proc_4.f03

@@ -17,12 +17,12 @@ MODULE testmod
     PROCEDURE ? ! { dg-error "Expected binding name" }
     PROCEDURE :: p2 => ! { dg-error "Expected binding target" }
     PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" }
-    PROCEDURE p4, ! { dg-error "Junk after" }
+    PROCEDURE p4, ! { dg-error "Expected binding name" }
-    PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" }
+    PROCEDURE :: p5 => proc2, ! { dg-error "Expected binding name" }
     PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" }
     PROCEDURE, PASS p6 ! { dg-error "::" }
     PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" }
-    PROCEDURE PASS :: ! { dg-error "Junk after" }
+    PROCEDURE PASS :: ! { dg-error "Syntax error" }
     PROCEDURE, PASS (x ! { dg-error "Expected" }
     PROCEDURE, PASS () ! { dg-error "Expected" }
     PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" }