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

1 files changed, 57 insertions, 6 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f4c236..f2c2440 100644
--- 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);