From 2240d1cfe860cc718e00b8a48c89316cdd1ceb88 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 7 Aug 2011 22:59:16 +0200 Subject: [PATCH] re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound character functions with constant length.) 2011-08-07 Janus Weil Thomas Koenig 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 PR fortran/49638 * gfortran.dg/typebound_override_1.f90: New. Co-Authored-By: Thomas Koenig From-SVN: r177550 --- gcc/fortran/ChangeLog | 9 ++ gcc/fortran/dependency.c | 14 +- gcc/fortran/interface.c | 36 ++++- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/typebound_override_1.f90 | 125 ++++++++++++++++++ 5 files changed, 183 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_override_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0c38317ed5d..a86afc6728d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2011-08-07 Janus Weil + Thomas Koenig + + 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 PR fortran/49638 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index b49cf5424ca..5238c861381 100644 --- 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 899807231a2..0ea244de32a 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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2931dd2320c..afd84c5d701 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-08-07 Janus Weil + + PR fortran/49638 + * gfortran.dg/typebound_override_1.f90: New. + 2011-08-07 Kai Tietz * 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 index 00000000000..37939d9a17c --- /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 + +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" } } -- 2.30.2