2011/8/7 Thomas Koenig <tkoe...@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 <ja...@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 <ja...@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 <boschm...@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" } }
