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.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2e27433..48dd521 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index e2de24f..f969383 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/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
-     means target != NULL.  */
-  if (tb->deferred && !target)
+  /* Check that attribute DEFERRED is given if an interface is specified.  */
+  if (tb->deferred && !ifc)
     {
       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,97 +7612,102 @@ match_procedure_in_type (void)
       return MATCH_ERROR;
     }
 
-  /* Match the binding name.  */ 
-  m = gfc_match_name (name);
-  if (m == MATCH_ERROR)
-    return m;
-  if (m == MATCH_NO)
-    {
-      gfc_error ("Expected binding name at %C");
-      return MATCH_ERROR;
-    }
-
-  /* Try to match the '=> target', if it's there.  */
-  m = gfc_match (" =>");
-  if (m == MATCH_ERROR)
-    return m;
-  if (m == MATCH_YES)
+  /* Match the binding names.  */ 
+  for(num=1;;num++)
     {
-      if (tb->deferred)
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+       return m;
+      if (m == MATCH_NO)
        {
-         gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+         gfc_error ("Expected binding name at %C");
          return MATCH_ERROR;
        }
 
-      if (!seen_colons)
-       {
-         gfc_error ("'::' needed in PROCEDURE binding with explicit target"
-                    " at %C");
-         return MATCH_ERROR;
-       }
+      if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+                                  " at %C") == FAILURE)
+       return MATCH_ERROR;
 
-      m = gfc_match_name (target_buf);
+      /* Try to match the '=> target', if it's there.  */
+      target = ifc;
+      m = gfc_match (" =>");
       if (m == MATCH_ERROR)
        return m;
-      if (m == MATCH_NO)
+      if (m == MATCH_YES)
        {
-         gfc_error ("Expected binding target after '=>' at %C");
-         return MATCH_ERROR;
+         if (tb->deferred)
+           {
+             gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+             return MATCH_ERROR;
+           }
+
+         if (!seen_colons)
+           {
+             gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+                        " at %C");
+             return MATCH_ERROR;
+           }
+
+         m = gfc_match_name (target_buf);
+         if (m == MATCH_ERROR)
+           return m;
+         if (m == MATCH_NO)
+           {
+             gfc_error ("Expected binding target after '=>' at %C");
+             return MATCH_ERROR;
+           }
+         target = target_buf;
        }
-      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;
 
-  /* If no target was found, it has the same name as the binding.  */
-  if (!target)
-    target = name;
+      /* Get the namespace to insert the symbols into.  */
+      ns = block->f2k_derived;
+      gcc_assert (ns);
 
-  /* Get the namespace to insert the symbols into.  */
-  ns = block->f2k_derived;
-  gcc_assert (ns);
+      /* 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", block->name);
+         return MATCH_ERROR;
+       }
 
-  /* 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",
-                block->name);
-      return MATCH_ERROR;
-    }
+      /* See if we already have a binding with this name in the symtree which
+        would be an error.  If a GENERIC already targetted this binding, it may
+        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 is already a procedure with binding name '%s' for "
+                    "the derived type '%s' at %C", name, block->name);
+         return MATCH_ERROR;
+       }
 
-  /* See if we already have a binding with this name in the symtree which would
-     be an error.  If a GENERIC already targetted this binding, it may 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"
-                " derived type '%s' at %C", name, block->name);
-      return MATCH_ERROR;
-    }
+      /* Insert it and set attributes.  */
 
-  /* Insert it and set attributes.  */
+      if (!stree)
+       {
+         stree = gfc_new_symtree (&ns->tb_sym_root, name);
+         gcc_assert (stree);
+       }
+      stree->n.tb = tb;
 
-  if (!stree)
-    {
-      stree = gfc_new_symtree (&ns->tb_sym_root, name);
-      gcc_assert (stree);
+      if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
+       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;
     }
-  stree->n.tb = tb;
-
-  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
-    return MATCH_ERROR;
-  gfc_set_sym_referenced (tb->u.specific->n.sym);
 
-  return MATCH_YES;
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4d2a83d..e56ac3a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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.

diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_14.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_14.f03
new file mode 100644 (file)
index 0000000..766a0ef
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_15.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_15.f03
new file mode 100644 (file)
index 0000000..a8a2ce7
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03
index 92adc1a..60aa728 100644 (file)
--- a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03
+++ b/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 :: p5 => proc2, ! { dg-error "Junk after" }
+    PROCEDURE p4, ! { dg-error "Expected binding name" }
+    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" }