re PR fortran/33117 (Improve error message for generic interface with subroutines & functions)

gcc/fortran/:
2011-01-06  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/33117
	PR fortran/46478
	* parse.c (parse_interface): Remove check for procedure types.
	* interface.c (check_interface0): Verify that procedures are
	either all SUBROUTINEs or all FUNCTIONs.

gcc/testsuite/:
2011-01-06  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/33117
	PR fortran/46478
	* gfortran.dg/interface_33.f90: New test.

From-SVN: r168542

5 files changed, 86 insertions, 40 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d00b9ed..3181e5e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2011-01-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/33117
+	PR fortran/46478
+	* parse.c (parse_interface): Remove check for procedure types.
+	* interface.c (check_interface0): Verify that procedures are
+	either all SUBROUTINEs or all FUNCTIONs.
+
 2011-01-05  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/47180
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index cf83557..1febb5d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1092,8 +1092,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 
 
 /* Given a pointer to an interface pointer, remove duplicate
-   interfaces and make sure that all symbols are either functions or
-   subroutines.  Returns nonzero if something goes wrong.  */
+   interfaces and make sure that all symbols are either functions
+   or subroutines, and all of the same kind.  Returns nonzero if
+   something goes wrong.  */
 
 static int
 check_interface0 (gfc_interface *p, const char *interface_name)
@@ -1101,21 +1102,32 @@ check_interface0 (gfc_interface *p, const char *interface_name)
   gfc_interface *psave, *q, *qlast;
 
   psave = p;
-  /* Make sure all symbols in the interface have been defined as
-     functions or subroutines.  */
   for (; p; p = p->next)
-    if ((!p->sym->attr.function && !p->sym->attr.subroutine)
-	|| !p->sym->attr.if_source)
-      {
-	if (p->sym->attr.external)
-	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
-		     p->sym->name, interface_name, &p->sym->declared_at);
-	else
-	  gfc_error ("Procedure '%s' in %s at %L is neither function nor "
-		     "subroutine", p->sym->name, interface_name,
-		     &p->sym->declared_at);
-	return 1;
-      }
+    {
+      /* Make sure all symbols in the interface have been defined as
+	 functions or subroutines.  */
+      if ((!p->sym->attr.function && !p->sym->attr.subroutine)
+	  || !p->sym->attr.if_source)
+	{
+	  if (p->sym->attr.external)
+	    gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+		       p->sym->name, interface_name, &p->sym->declared_at);
+	  else
+	    gfc_error ("Procedure '%s' in %s at %L is neither function nor "
+		       "subroutine", p->sym->name, interface_name,
+		      &p->sym->declared_at);
+	  return 1;
+	}
+
+      /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
+      if ((psave->sym->attr.function && !p->sym->attr.function)
+	  || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
+	{
+	  gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
+		     " or all FUNCTIONs", interface_name, &p->sym->declared_at);
+	  return 1;
+	}
+    }
   p = psave;
 
   /* Remove duplicate interfaces in this interface list.  */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index ea9667d..58d8b43 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2263,32 +2263,16 @@ loop:
     }
 
 
-  /* Make sure that a generic interface has only subroutines or
-     functions and that the generic name has the right attribute.  */
-  if (current_interface.type == INTERFACE_GENERIC)
+  /* Make sure that the generic name has the right attribute.  */
+  if (current_interface.type == INTERFACE_GENERIC
+      && current_state == COMP_NONE)
     {
-      if (current_state == COMP_NONE)
-	{
-	  if (new_state == COMP_FUNCTION && sym)
-	    gfc_add_function (&sym->attr, sym->name, NULL);
-	  else if (new_state == COMP_SUBROUTINE && sym)
-	    gfc_add_subroutine (&sym->attr, sym->name, NULL);
-
-	  current_state = new_state;
-	}
-      else
-	{
-	  if (new_state != current_state)
-	    {
-	      if (new_state == COMP_SUBROUTINE)
-		gfc_error ("SUBROUTINE at %C does not belong in a "
-			   "generic function interface");
+      if (new_state == COMP_FUNCTION && sym)
+	gfc_add_function (&sym->attr, sym->name, NULL);
+      else if (new_state == COMP_SUBROUTINE && sym)
+	gfc_add_subroutine (&sym->attr, sym->name, NULL);
 
-	      if (new_state == COMP_FUNCTION)
-		gfc_error ("FUNCTION at %C does not belong in a "
-			   "generic subroutine interface");
-	    }
-	}
+      current_state = new_state;
     }
 
   if (current_interface.type == INTERFACE_ABSTRACT)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3c63440..f6e4423 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2011-01-06  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/33117
+	PR fortran/46478
+	* gfortran.dg/interface_33.f90: New test.
+
 2011-01-06  Jakub Jelinek  <jakub@redhat.com>
 
 	PR c/47150
diff --git a/gcc/testsuite/gfortran.dg/interface_33.f90 b/gcc/testsuite/gfortran.dg/interface_33.f90
new file mode 100644
index 0000000..f1475b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_33.f90
@@ -0,0 +1,36 @@
+! { dg-do "compile" }
+!
+! PR fortran/33117, PR fortran/46478
+! Procedures of a generic interface must be either
+! all SUBROUTINEs or all FUNCTIONs.
+!
+
+!
+! PR fortran/33117
+!
+module m1
+  interface gen
+    subroutine sub()            ! dg-error { "all SUBROUTINEs or all FUNCTIONs" }
+    end subroutine sub
+    function bar()
+      real :: bar
+    end function bar
+  end interface gen
+end module
+
+!
+! PR fortran/46478
+!
+MODULE m2
+  INTERFACE new_name
+    MODULE PROCEDURE func_name
+    MODULE PROCEDURE subr_name
+  END INTERFACE
+CONTAINS
+   LOGICAL FUNCTION func_name()  ! dg-error { "all SUBROUTINEs or all FUNCTIONs" }
+   END FUNCTION
+   SUBROUTINE subr_name()
+   END SUBROUTINE
+END MODULE
+
+! { dg-final { cleanup-modules "m1 m2" } }