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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index db5f373..c768fed 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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;
     }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28ed5fc..f22bcce 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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.
+
 2009-05-14  Laurent GUERBY  <laurent@guerby.net>
        
         * ada/acats/tests/c3/c38202a.ada: Use Impdef.

diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_2.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_2.f90
index 5b86dc6..0fd9258 100644 (file)
--- a/gcc/testsuite/gfortran.dg/duplicate_type_2.f90
+++ b/gcc/testsuite/gfortran.dg/duplicate_type_2.f90
@@ -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" }

diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_3.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_3.f90
new file mode 100644 (file)
index 0000000..802029d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/duplicate_type_3.f90
@@ -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  ! { dg-error "Expecting END INTERFACE statement" }
+  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
+

diff --git a/gcc/testsuite/gfortran.dg/func_decl_2.f90 b/gcc/testsuite/gfortran.dg/func_decl_2.f90
index c2cc440..658883e 100644 (file)
--- a/gcc/testsuite/gfortran.dg/func_decl_2.f90
+++ b/gcc/testsuite/gfortran.dg/func_decl_2.f90
@@ -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