re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0c38317ed5d5de2d03950afb6b49e3ff4ac5c631..a86afc6728d14cab1beb9afa1fc972cb99ab829e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index b49cf5424cad37f8cbe4e5c7d9a16e632f41ce58..5238c861381952ee6ffe985f2f21f3b05680791f 100644 (file)
--- a/gcc/fortran/dependency.c
+++ b/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.  */
 

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 899807231a276a29ab43abe35a73a3dea2383de6..0ea244de32a9676f449d2dca5b6aa4640bd685c7 100644 (file)
--- 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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2931dd2320c3ccbb46cd18eb08a36efb3798d387..afd84c5d701db2c5b087cc72bb5fa7992fee8753 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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

diff --git a/gcc/testsuite/gfortran.dg/typebound_override_1.f90 b/gcc/testsuite/gfortran.dg/typebound_override_1.f90
new file mode 100644 (file)
index 0000000..37939d9
--- /dev/null
+++ b/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" } }