re PR fortran/39996 (Double typing of function results not detected)

2009-05-14  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39996
	* decl.c (gfc_match_function_decl): Use gfc_add_type.
	* symbol.c (gfc_add_type): Better checking for duplicate types in
	function declarations. And: Always give an error for duplicte types,
	not just a warning with -std=gnu.


2009-05-14  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39996
	* gfortran.dg/func_decl_2.f90: Modified (replacing warnings by errors).
	* gfortran.dg/duplicate_type_2.f90: Ditto.
	* gfortran.dg/duplicate_type_3.f90: New.

From-SVN: r147528

3 files changed, 30 insertions, 26 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index db5f373..c768fed 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2009-05-14  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39996
+	* decl.c (gfc_match_function_decl): Use gfc_add_type.
+	* symbol.c (gfc_add_type): Better checking for duplicate types in
+	function declarations. And: Always give an error for duplicte types,
+	not just a warning with -std=gnu.
+
 2009-05-14  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/39865
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 7aa550e..6c6fa45 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4708,14 +4708,6 @@ gfc_match_function_decl (void)
 	  || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
 	goto cleanup;
 
-      if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
-	  && !sym->attr.implicit_type)
-	{
-	  gfc_error ("Function '%s' at %C already has a type of %s", name,
-		     gfc_basic_typename (sym->ts.type));
-	  goto cleanup;
-	}
-
       /* Delay matching the function characteristics until after the
 	 specification block by signalling kind=-1.  */
       sym->declared_at = old_loc;
@@ -4726,12 +4718,17 @@ gfc_match_function_decl (void)
 
       if (result == NULL)
 	{
-	  sym->ts = current_ts;
+          if (current_ts.type != BT_UNKNOWN
+	      && gfc_add_type (sym, &current_ts, &gfc_current_locus) == FAILURE)
+	    goto cleanup;
 	  sym->result = sym;
 	}
       else
 	{
-	  result->ts = current_ts;
+          if (current_ts.type != BT_UNKNOWN
+	      && gfc_add_type (result, &current_ts, &gfc_current_locus)
+		 == FAILURE)
+	    goto cleanup;
 	  sym->result = result;
 	}
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 2160afa..67240ad 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1559,31 +1559,30 @@ gfc_try
 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
 {
   sym_flavor flavor;
+  bt type;
 
   if (where == NULL)
     where = &gfc_current_locus;
 
-  if (sym->ts.type != BT_UNKNOWN)
+  if (sym->result)
+    type = sym->result->ts.type;
+  else
+    type = sym->ts.type;
+
+  if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
+    type = sym->ns->proc_name->ts.type;
+
+  if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
     {
-      const char *msg = "Symbol '%s' at %L already has basic type of %s";
-      if (!(sym->ts.type == ts->type && sym->attr.result)
-	  || gfc_notification_std (GFC_STD_GNU) == ERROR
-	  || pedantic)
-	{
-	  gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
-	  return FAILURE;
-	}
-      if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
-	      		  gfc_basic_typename (sym->ts.type)) == FAILURE)
-	return FAILURE;
-      if (gfc_option.warn_surprising)
-	gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
+      gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+		 where, gfc_basic_typename (type));
+      return FAILURE;
     }
 
   if (sym->attr.procedure && sym->ts.interface)
     {
-      gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where,
-		 gfc_basic_typename (ts->type));
+      gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+		 sym->name, where, gfc_basic_typename (ts->type));
       return FAILURE;
     }