re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound character functions with constant length.)

2011-08-07  Janus Weil  <janus@gcc.gnu.org>
	    Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/49638
	* dependency.c (are_identical_variables): For dummy arguments only
	check for equal names, not equal symbols.
	* interface.c (gfc_check_typebound_override): Add checking for rank
	and character length.

2011-08-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/49638
	* gfortran.dg/typebound_override_1.f90: New.

Co-Authored-By: Thomas Koenig <tkoenig@gcc.gnu.org>

From-SVN: r177550

1 files changed, 32 insertions, 4 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 8998072..0ea244d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3556,15 +3556,43 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 	}
 
       /* FIXME:  Do more comprehensive checking (including, for instance, the
-	 rank and array-shape).  */
+	 array-shape).  */
       gcc_assert (proc_target->result && old_target->result);
-      if (!gfc_compare_types (&proc_target->result->ts,
-			      &old_target->result->ts))
+      if (!compare_type_rank (proc_target->result, old_target->result))
 	{
 	  gfc_error ("'%s' at %L and the overridden FUNCTION should have"
-		     " matching result types", proc->name, &where);
+		     " matching result types and ranks", proc->name, &where);
 	  return FAILURE;
 	}
+	
+      /* Check string length.  */
+      if (proc_target->result->ts.type == BT_CHARACTER
+	  && proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
+	{
+	  int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
+					      old_target->result->ts.u.cl->length);
+	  switch (compval)
+	  {
+	    case -1:
+	    case 1:
+	      gfc_error ("Character length mismatch between '%s' at '%L' and "
+			 "overridden FUNCTION", proc->name, &where);
+	      return FAILURE;
+
+	    case -2:
+	      gfc_warning ("Possible character length mismatch between '%s' at"
+			   " '%L' and overridden FUNCTION", proc->name, &where);
+	      break;
+
+	    case 0:
+	      break;
+
+	    default:
+	      gfc_internal_error ("gfc_check_typebound_override: Unexpected "
+				  "result %i of gfc_dep_compare_expr", compval);
+	      break;
+	  }
+	}
     }
 
   /* If the overridden binding is PUBLIC, the overriding one must not be