[Patch, Fortran] PR 39996: Double typing of function results not detected

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is my patch for PR 39996, which fixes some problems concerning
the detection of double typing in certain cases.

Moreover (and this is probably the more controversial part of the
patch), it rejects double typing of function results. Although this is
clearly invalid, we allowed it up to now with -std=gnu. For more
discussion please see PR16943 and PR30239.

In my opinion it is hard enough to build a compiler which is able to
check pedantically if a given program is valid with respect to F95,
F2003 and/or F2008. So there is need for us to invent yet another
(GNU) version of the standard, and we should really avoid this!

Furthermore, in the case at hand it is really easy for people to fix
their code to conform to the standard. And IMHO this solution is
clearly preferable to inventing another standard, such that people
don't have to fix their code. Besides, most other compilers *do*
reject double typing of function results (I verified that ifort and
g95 do).

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus



2009-05-09  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-09  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.

Index: gcc/testsuite/gfortran.dg/duplicate_type_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/duplicate_type_2.f90	(revision 147317)
+++ gcc/testsuite/gfortran.dg/duplicate_type_2.f90	(working copy)
@@ -7,14 +7,14 @@
 
 INTEGER FUNCTION foo ()
   IMPLICIT NONE
-  INTEGER :: foo ! { dg-warning "basic type of" }
-  INTEGER :: foo ! { dg-warning "basic type of" }
+  INTEGER :: foo ! { dg-error "basic type of" }
+  INTEGER :: foo ! { dg-error "basic type of" }
   foo = 42
 END FUNCTION foo
 
 INTEGER FUNCTION bar () RESULT (x)
   IMPLICIT NONE
-  INTEGER :: x ! { dg-warning "basic type of" }
+  INTEGER :: x ! { dg-error "basic type of" }
 
   INTEGER :: y
   INTEGER :: y ! { dg-error "basic type of" }
Index: gcc/testsuite/gfortran.dg/func_decl_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/func_decl_2.f90	(revision 147317)
+++ gcc/testsuite/gfortran.dg/func_decl_2.f90	(working copy)
@@ -1,8 +1,6 @@
 ! { dg-do compile }
 ! Test fix for PR16943 in which the double typing of
-! N caused an error.  This is a common extension to the
-! F95 standard, so the error is only thrown for -std=f95
-! or -pedantic.
+! N caused an error.
 !
 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
 !
@@ -14,7 +12,7 @@
 
     integer function bugf(M) result (N) 
       integer, intent (in) :: M 
-      integer :: N ! { dg-warning "already has basic type of INTEGER" }
+      integer :: N ! { dg-error "already has basic type of INTEGER" }
       N = M 
       return 
     end function bugf
Index: gcc/testsuite/gfortran.dg/duplicate_type_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/duplicate_type_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/duplicate_type_3.f90	(revision 0)
@@ -0,0 +1,48 @@
+! { dg-do compile }
+!
+! PR 39996: Double typing of function results not detected
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  interface
+    real function A ()
+    end function
+  end interface
+  real :: A  ! { dg-error "already has basic type of" }
+
+  real :: B
+  interface
+    real function B ()  ! { dg-error "already has basic type of" }
+    end function
+  end interface
+
+  interface
+    function C ()
+      real :: C
+    end function
+  end interface
+  real :: C  ! { dg-error "already has basic type of" }
+
+  real :: D
+  interface
+    function D ()
+      real :: D  ! { dg-error "already has basic type of" }
+    end function
+  end interface
+
+  interface
+    function E () result (s)
+      real ::s
+    end function
+  end interface
+  real :: E  ! { dg-error "already has basic type of" }
+
+  real :: F
+  interface
+    function F () result (s)
+      real ::s  ! { dg-error "already has basic type of" }
+    end function F
+  end interface
+
+end
+
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 147317)
+++ gcc/fortran/symbol.c	(working copy)
@@ -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;
     }
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 147317)
+++ gcc/fortran/decl.c	(working copy)
@@ -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;
 	}