This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran, OOP] PR 49638: [OOP] length parameter is ignored when overriding type bound character functions with constant length.


2011/8/7 Thomas Koenig <tkoenig@netcologne.de>:
> Am 07.08.2011 12:56, schrieb Janus Weil:
>>
>> + ? ? ?/* Check string length. ?*/
>> + ? ? ?if (proc_target->result->ts.type == BT_CHARACTER
>> + ? ? ? && ?proc_target->result->ts.u.cl&& ?old_target->result->ts.u.cl
>> + ? ? ? && ?gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
>> + ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?old_target->result->ts.u.cl->length) !=
>> 0)
>> + ? ? ? {
>> + ? ? ? ? gfc_error ("Character length mismatch between '%s' at '%L' "
>> + ? ? ? ? ? ? ? ? ? ?"and overridden FUNCTION", proc->name,&where);
>> + ? ? ? ? return FAILURE;
>> + ? ? ? }
>> ? ? ?}
>
> Well, let's make this into (again, typing the patch directly into
> e-mail)
>
> ?[...]
>
> and then work on extending gfc_dep_compare_expr to return -3 for more cases.
> ?I can help with that.

Alright then. How about this: I'll commit the attached verision of the
patch (including your suggestions), and we start messing with the
return values afterwards? Patch is regtested on
x86_64-unknown-linux-gnu. I hope the test case is sufficient for a
start.

Cheers,
Janus


2011-08-07  Janus Weil  <janus@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.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 177545)
+++ gcc/fortran/interface.c	(working copy)
@@ -3556,15 +3556,43 @@ gfc_check_typebound_override (gfc_symtree* proc, g
 	}
 
       /* 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
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c	(revision 177545)
+++ gcc/fortran/dependency.c	(working copy)
@@ -123,8 +123,18 @@ are_identical_variables (gfc_expr *e1, gfc_expr *e
 {
   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.  */
 
! { 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" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]