[Patch, Fortran] PR 34421 - add error for -std=f* if ENTRY functions returns different string lengths

[Tobias Burnus <burnus at net-b dot de>]

The return value of an ENTRY function needs to have the same
characteristic as the one in the FUNCTION statement.

This includes also the string length. The patch does so.

Contrary to NAG f95 and ifort, I do not reject

function a(n,m)
   integer :: n,m
   character a(n)
   character a(m)
entry b(n,m)
end

for two reasons: (a) n and m can have the same value; (b) it is easier
to do.


The standard says:

"If the characteristics of the result of the function named in the ENTRY
statement are the same as the characteristics of the result of the function
named in the FUNCTION statement, their result variables identify the same
variable, although their names need not be the same. Otherwise, they are
storage associated and shall all be nonpointer, nonallocatable scalars of type
default integer, default real, double precision real, default complex, or
default logical."



Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

2007-12-19  Tobias Burnus  <burnus@net-b.de>

	PR fortran/34421
	* resolve.c (resolve_entries): Add standard error for functions
	returning characters with different length.

2007-12-19  Tobias Burnus  <burnus@net-b.de>

	PR fortran/34421
	* gfortran.dg/entry_17.f90: New.

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 131035)
+++ gcc/fortran/resolve.c	(working copy)
@@ -488,11 +488,28 @@ resolve_entries (gfc_namespace *ns)
 	      || (el->sym->result->attr.pointer
 		  != ns->entries->sym->result->attr.pointer))
 	    break;
-
 	  else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
-	    gfc_error ("Procedure %s at %L has entries with mismatched "
+	    gfc_error ("Function %s at %L has entries with mismatched "
 		       "array specifications", ns->entries->sym->name,
 		       &ns->entries->sym->declared_at);
+	  /* The characteristics need to match and thus both need to have
+	     the same string length, i.e. both len=*, or both len=4.
+	     Having both len=<variable> is also possible, but difficult to
+	     check at compile time.  */
+	  else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
+		   && (((ts->cl->length && !fts->cl->length)
+			||(!ts->cl->length && fts->cl->length))
+		       || (ts->cl->length
+			   && ts->cl->length->expr_type
+			      != fts->cl->length->expr_type)
+		       || (ts->cl->length
+			   && ts->cl->length->expr_type == EXPR_CONSTANT
+		           && mpz_cmp (ts->cl->length->value.integer,
+				       fts->cl->length->value.integer) != 0)))
+	    gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
+			    "entries returning variables of different "
+			    "string lengths", ns->entries->sym->name,
+			    &ns->entries->sym->declared_at);
 	}
 
       if (el == NULL)
@@ -5932,7 +5949,8 @@ resolve_ordinary_assign (gfc_code *code,
 		     "non-integer symbol '%s'", &code->loc,
 		     lhs->symtree->n.sym->name);
 
-      gfc_convert_boz (rhs, &lhs->ts);
+      if (!gfc_convert_boz (rhs, &lhs->ts))
+	return false;
       if ((rc = gfc_range_check (rhs)) != ARITH_OK)
 	{
 	  if (rc == ARITH_UNDERFLOW)
Index: gcc/testsuite/gfortran.dg/entry_17.f90
===================================================================
--- gcc/testsuite/gfortran.dg/entry_17.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/entry_17.f90	(revision 0)
@@ -0,0 +1,55 @@
+function test1(n)
+  integer  :: n
+  character(n) :: test1
+  character(n) :: bar1
+  test1 = ""
+  return
+entry bar1()
+  bar1 = ""
+end function test1
+
+function test2()
+  character(1) :: test2
+  character(1) :: bar2
+  test2 = ""
+  return
+entry bar2()
+  bar2 = ""
+end function test2
+
+function test3() ! { dg-warning "is obsolescent" }
+  character(*) :: test3
+  character(*) :: bar3 ! { dg-warning "is obsolescent" }
+  test3 = ""
+  return
+entry bar3()
+  bar3 = ""
+end function test3 ! { dg-warning "is obsolescent" }
+
+function test4(n) ! { dg-error "returning variables of different string lengths" }
+  integer  :: n
+  character(n) :: test4
+  character(*) :: bar4 ! { dg-warning "is obsolescent" }
+  test4 = ""
+  return
+entry bar4()
+  bar4 = ""
+end function test4
+
+function test5() ! { dg-error "returning variables of different string lengths" }
+  character(1) :: test5
+  character(2) :: bar5
+  test5 = ""
+  return
+entry bar5()
+  bar5 = ""
+end function test5
+
+function test6() ! { dg-warning "is obsolescent|returning variables of different string lengths" }
+  character(*) :: test6
+  character(2) :: bar6
+  test6 = ""
+  return
+entry bar6()
+  bar6 = ""
+end function test6 ! { dg-warning "is obsolescent" }