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

gcc/fortran/ChangeLog

@@ -1,3 +1,12 @@
+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

gcc/fortran/dependency.c

@@ -123,8 +123,18 @@ are_identical_variables (gfc_expr *e1, gfc_expr *e2)
 {
   gfc_ref *r1, *r2;
 
-  if (e1->symtree->n.sym != e2->symtree->n.sym)
-    return false;
+  if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
+    {
+      /* Dummy arguments: Only check for equal names.  */
+      if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
+	return false;
+    }
+  else
+    {
+      /* Check for equal symbols.  */
+      if (e1->symtree->n.sym != e2->symtree->n.sym)
+	return false;
+    }
 
   /* Volatile variables should never compare equal to themselves.  */
 

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

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2011-08-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/49638
+	* gfortran.dg/typebound_override_1.f90: New.
+
 2011-08-07  Kai Tietz  <ktietz@redhat.com>
 
 	* gcc.dg/tree-ssa/pr23455.c: Adjust testcases for LLP64 for

gcc/testsuite/gfortran.dg/typebound_override_1.f90

@@ -0,0 +1,125 @@
+! { dg-do compile }
+!
+! PR 49638: [OOP] length parameter is ignored when overriding type bound character functions with constant length.
+!
+! Original test case contributed by Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
+
+module m
+
+  implicit none
+
+  type :: t1
+   contains
+     procedure, nopass :: a => a1
+     procedure, nopass :: b => b1
+     procedure, nopass :: c => c1
+     procedure, nopass :: d => d1
+     procedure, nopass :: e => e1
+  end type
+
+  type, extends(t1) :: t2
+   contains
+     procedure, nopass :: a => a2  ! { dg-error "Character length mismatch" }
+     procedure, nopass :: b => b2  ! { dg-error "should have matching result types and ranks" }
+     procedure, nopass :: c => c2  ! { dg-warning "Possible character length mismatch" }
+     procedure, nopass :: d => d2  ! valid, check for commutativity (+,*)
+     procedure, nopass :: e => e2  ! { dg-warning "Possible character length mismatch" }
+  end type
+
+contains
+
+  function a1 ()
+    character(len=6) :: a1
+  end function
+
+  function a2 ()
+    character(len=7) :: a2
+  end function
+
+  function b1 ()
+    integer :: b1
+  end function
+
+  function b2 ()
+    integer, dimension(2) :: b2
+  end function
+
+  function c1 (x)
+    integer, intent(in) :: x
+    character(2*x) :: c1
+  end function
+
+  function c2 (x)
+    integer, intent(in) :: x
+    character(3*x) :: c2
+  end function
+
+  function d1 (y)
+    integer, intent(in) :: y
+    character(2*y+1) :: d1
+  end function
+
+  function d2 (y)
+    integer, intent(in) :: y
+    character(1+y*2) :: d2
+  end function
+
+  function e1 (z)
+    integer, intent(in) :: z
+    character(3) :: e1
+  end function
+
+  function e2 (z)
+    integer, intent(in) :: z
+    character(z) :: e2
+  end function
+
+end module m
+
+
+
+
+module w1
+
+ implicit none
+
+ integer :: n = 1
+
+ type :: tt1
+ contains
+   procedure, nopass :: aa => aa1
+ end type
+
+contains
+
+ function aa1 (m)
+  integer, intent(in) :: m
+  character(n+m) :: aa1
+ end function
+
+end module w1
+
+
+module w2
+
+ use w1, only : tt1
+
+ implicit none
+
+ integer :: n = 2
+
+ type, extends(tt1) :: tt2
+ contains
+   procedure, nopass :: aa => aa2  ! { dg-warning "Possible character length mismatch" }
+ end type
+
+contains
+
+ function aa2 (m)
+  integer, intent(in) :: m
+  character(n+m) :: aa2
+ end function
+
+end module w2
+
+! { dg-final { cleanup-modules "m w1 w2" } }