gcc/fortran/:

2010-05-25  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/30668
	PR fortran/31346
	PR fortran/34260
	* resolve.c (resolve_global_procedure): Add check for global
	procedures with implicit interfaces and assumed-shape or optional
	dummy arguments. Verify that function return type, kind and string
	lengths match.

gcc/testsuite/:
2010-05-25  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/30668
	PR fortran/31346
	PR fortran/34260
	* gfortran.dg/pr40999.f: Fix function type.
	* gfortran.dg/whole_file_5.f90: Likewise.
	* gfortran.dg/whole_file_6.f90: Likewise.
	* gfortran.dg/whole_file_16.f90: New.
	* gfortran.dg/whole_file_17.f90: New.
	* gfortran.dg/whole_file_18.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5597c0361d8475bdc7a29a42a6ed3cc704c0341c..a28bb25f817895dbebeccb38db7ade301911e254 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2010-05-25  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/30668
+       PR fortran/31346
+       PR fortran/34260
+       * resolve.c (resolve_global_procedure): Add check for global
+       procedures with implicit interfaces and assumed-shape or optional
+       dummy arguments. Verify that function return type, kind and string
+       lengths match.
+
 2010-05-21  Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.h: Do not include system.h.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f4c236789a50592b28106a93f16fc7e7765fd09..f2c24409cc81f22ac0524a30d5d574a686d1ec53 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1864,7 +1864,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
        gfc_error ("The reference to function '%s' at %L either needs an "
                   "explicit INTERFACE or the rank is incorrect", sym->name,
                   where);
-     
+
       /* Non-assumed length character functions.  */
       if (sym->attr.function && sym->ts.type == BT_CHARACTER
          && gsym->ns->proc_name->ts.u.cl->length != NULL)
@@ -1872,18 +1872,69 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
          gfc_charlen *cl = sym->ts.u.cl;
 
          if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
-              && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+             && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
            {
-              gfc_error ("Nonconstant character-length function '%s' at %L "
+             gfc_error ("Nonconstant character-length function '%s' at %L "
                         "must have an explicit interface", sym->name,
                         &sym->declared_at);
            }
        }
 
+      /* Differences in constant character lengths.  */
+      if (sym->attr.function && sym->ts.type == BT_CHARACTER)
+       {
+         long int l1 = 0, l2 = 0;
+         gfc_charlen *cl1 = sym->ts.u.cl;
+         gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
+
+         if (cl1 != NULL
+             && cl1->length != NULL
+             && cl1->length->expr_type == EXPR_CONSTANT)
+           l1 = mpz_get_si (cl1->length->value.integer);
+
+         if (cl2 != NULL
+             && cl2->length != NULL
+             && cl2->length->expr_type == EXPR_CONSTANT)
+           l2 = mpz_get_si (cl2->length->value.integer);
+
+         if (l1 && l2 && l1 != l2)
+           gfc_error ("Character length mismatch in return type of "
+                      "function '%s' at %L (%ld/%ld)", sym->name,
+                      &sym->declared_at, l1, l2);
+       }
+
+     /* Type mismatch of function return type and expected type.  */
+     if (sym->attr.function
+        && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
+       gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
+                  sym->name, &sym->declared_at, gfc_typename (&sym->ts),
+                  gfc_typename (&gsym->ns->proc_name->ts));
+
+      /* Assumed shape arrays as dummy arguments.  */
+      if (gsym->ns->proc_name->formal)
+       {
+         gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
+         for ( ; arg; arg = arg->next)
+           if (arg->sym && arg->sym->as
+               && arg->sym->as->type == AS_ASSUMED_SHAPE)
+             {
+               gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
+                          "'%s' argument must have an explicit interface",
+                          sym->name, &sym->declared_at, arg->sym->name);
+               break;
+             }
+           else if (arg->sym && arg->sym->attr.optional)
+             {
+               gfc_error ("Procedure '%s' at %L with optional dummy argument "
+                          "'%s' must have an explicit interface",
+                          sym->name, &sym->declared_at, arg->sym->name);
+               break;
+             }
+       }
+
       if (gfc_option.flag_whole_file == 1
-           || ((gfc_option.warn_std & GFC_STD_LEGACY)
-                 &&
-              !(gfc_option.warn_std & GFC_STD_GNU)))
+         || ((gfc_option.warn_std & GFC_STD_LEGACY)
+             && !(gfc_option.warn_std & GFC_STD_GNU)))
        gfc_errors_to_warnings (1);
 
       gfc_procedure_use (gsym->ns->proc_name, actual, where);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f3c534e5a8840a9447fb8c4d4dda432c25e58fe9..08d1136281bbc5c9d3f73ebfd38bd7b43156002c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2010-05-25  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/30668
+       PR fortran/31346
+       PR fortran/34260
+       * gfortran.dg/pr40999.f: Fix function type.
+       * gfortran.dg/whole_file_5.f90: Likewise.
+       * gfortran.dg/whole_file_6.f90: Likewise.
+       * gfortran.dg/whole_file_16.f90: New.
+       * gfortran.dg/whole_file_17.f90: New.
+       * gfortran.dg/whole_file_18.f90: New.
+
 2010-05-25  Jack Howarth <howarth@bromo.med.uc.edu>
            Iain Sandoe  <iains@gcc.gnu.org>
 

diff --git a/gcc/testsuite/gfortran.dg/pr40999.f b/gcc/testsuite/gfortran.dg/pr40999.f
index 0d93069c5928e9676d87d150c59bacf9db7e3849..b6fa85ad5b188f62e08927590d2360fcbfcf78d3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr40999.f
+++ b/gcc/testsuite/gfortran.dg/pr40999.f
@@ -2,6 +2,7 @@
 ! { dg-options "-O3 -fwhole-file" }
 
       SUBROUTINE ZLARFG( ALPHA )
+        COMPLEX*16 ZLADIV
         ALPHA = ZLADIV( DCMPLX( 1.0D+0 ) )
       END
       COMPLEX*16 FUNCTION ZLADIV( X )

diff --git a/gcc/testsuite/gfortran.dg/whole_file_16.f90 b/gcc/testsuite/gfortran.dg/whole_file_16.f90
new file mode 100644 (file)
index 0000000..2a17d0b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_16.f90
@@ -0,0 +1,13 @@
+! { dg-do "compile" }
+! { dg-options "-fwhole-file" }
+!
+! PR fortran/31346
+!
+program main
+  real, dimension(2) :: a
+  call foo(a)                ! { dg-error "must have an explicit interface" }
+end program main
+
+subroutine foo(a)
+  real, dimension(:) :: a
+end subroutine foo

diff --git a/gcc/testsuite/gfortran.dg/whole_file_17.f90 b/gcc/testsuite/gfortran.dg/whole_file_17.f90
new file mode 100644 (file)
index 0000000..deaddf9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_17.f90
@@ -0,0 +1,22 @@
+! { dg-do "compile" }
+! { dg-options "-fwhole-file" }
+!
+! PR fortran/30668
+!
+
+integer(8) function two()
+  two = 2
+end function two
+
+CHARACTER(len=8) function string()
+  string = "gfortran"
+end function string
+
+
+program xx
+  INTEGER :: a
+  CHARACTER(len=4) :: s, string   ! { dg-error "Character length mismatch" }
+
+  a = two()                       ! { dg-error "Return type mismatch" }
+  s = string()
+end program xx

diff --git a/gcc/testsuite/gfortran.dg/whole_file_18.f90 b/gcc/testsuite/gfortran.dg/whole_file_18.f90
new file mode 100644 (file)
index 0000000..dbff185
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_18.f90
@@ -0,0 +1,14 @@
+! { dg-do "compile" }
+! { dg-options "-fwhole-file -Wno-unused-dummy-argument" }
+!
+! PR fortran/34260
+!
+      PROGRAM MAIN
+      REAL A
+      CALL SUB(A)             ! { dg-error "must have an explicit interface" }
+      END PROGRAM
+
+      SUBROUTINE SUB(A,I)
+      REAL :: A
+      INTEGER, OPTIONAL :: I
+      END SUBROUTINE

diff --git a/gcc/testsuite/gfortran.dg/whole_file_5.f90 b/gcc/testsuite/gfortran.dg/whole_file_5.f90
index c6ad9e1b448ec8cde570e38347ea6925155d0399..0ba8ffe21401d2747ea042e87e271708772ca431 100644 (file)
--- a/gcc/testsuite/gfortran.dg/whole_file_5.f90
+++ b/gcc/testsuite/gfortran.dg/whole_file_5.f90
@@ -11,9 +11,9 @@ INTEGER FUNCTION f()
 END FUNCTION
 
 PROGRAM main
-  INTEGER :: a
+  INTEGER :: a, f
   a = f()
-  print *, a
+  print *, a, f()
 END PROGRAM
 
 ! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } }

diff --git a/gcc/testsuite/gfortran.dg/whole_file_6.f90 b/gcc/testsuite/gfortran.dg/whole_file_6.f90
index 274b8a99c6c8802b40966571c36e1002372d7b11..266c289f541219dce74b6fedbe1beb8cf8e2001e 100644 (file)
--- a/gcc/testsuite/gfortran.dg/whole_file_6.f90
+++ b/gcc/testsuite/gfortran.dg/whole_file_6.f90
@@ -7,13 +7,13 @@
 !
 
 PROGRAM main
-  INTEGER :: a(3)
+  INTEGER :: a(3), f
   a = f()
   print *, a
 END PROGRAM
 
 INTEGER FUNCTION f()
-  f = 42.0
+  f = 42
 END FUNCTION
 
 ! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } }