re PR fortran/30668 (-fwhole-file should catch function of wrong type)

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.

From-SVN: r159838

gcc/fortran/ChangeLog

+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.

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);

gcc/testsuite/ChangeLog

+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>
 

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 )

gcc/testsuite/gfortran.dg/whole_file_16.f90

+! { 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

gcc/testsuite/gfortran.dg/whole_file_17.f90

+! { 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

gcc/testsuite/gfortran.dg/whole_file_18.f90

+! { 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

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" } }

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" } }