From 8271b407aec37dcfe4b062568ca720b7e8a797c7 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 7 May 2012 11:50:04 +0000 Subject: [PATCH] 2012-05-07 Tobias Burnus Backport from mainline: 2012-05-07 Tobias Burnus PR fortran/53255 * resolve.c (resolve_typebound_static): Fix handling of overridden specific to generic operator. 2012-05-07 Tobias Burnus Backport from mainline: 2012-05-07 Tobias Burnus PR fortran/53255 * gfortran.dg/typebound_operator_15.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_7-branch@187232 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/resolve.c | 11 ++- gcc/testsuite/ChangeLog | 8 +++ .../gfortran.dg/typebound_operator_15.f90 | 78 ++++++++++++++++++++++ 4 files changed, 100 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_15.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e853b68504a..f061f46439e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2012-05-07 Tobias Burnus + + Backport from mainline: + 2012-05-07 Tobias Burnus + + PR fortran/53255 + * resolve.c (resolve_typebound_static): Fix handling + of overridden specific to generic operator. + 2012-05-05 Tobias Burnus Backport from mainline: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 814416cb54d..9f34ce004b5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5624,12 +5624,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, e->value.compcall.actual = NULL; /* If we find a deferred typebound procedure, check for derived types - that an over-riding typebound procedure has not been missed. */ - if (e->value.compcall.tbp->deferred - && e->value.compcall.name - && !e->value.compcall.tbp->non_overridable - && e->value.compcall.base_object - && e->value.compcall.base_object->ts.type == BT_DERIVED) + that an overriding typebound procedure has not been missed. */ + if (e->value.compcall.name + && !e->value.compcall.tbp->non_overridable + && e->value.compcall.base_object + && e->value.compcall.base_object->ts.type == BT_DERIVED) { gfc_symtree *st; gfc_symbol *derived; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d052ada7dca..1a9bf6d1b9b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2012-05-07 Tobias Burnus + + Backport from mainline: + 2012-05-07 Tobias Burnus + + PR fortran/53255 + * gfortran.dg/typebound_operator_15.f90: New. + 2012-05-05 Tobias Burnus Backport from mainline: diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_15.f90 b/gcc/testsuite/gfortran.dg/typebound_operator_15.f90 new file mode 100644 index 00000000000..ca4d45c7017 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_15.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! PR fortran/53255 +! +! Contributed by Reinhold Bader. +! +! Before TYPE(ext)'s .tr. wrongly called the base type's trace +! instead of ext's trace_ext. +! +module mod_base + implicit none + private + integer, public :: base_cnt = 0 + type, public :: base + private + real :: r(2,2) = reshape( (/ 1.0, 2.0, 3.0, 4.0 /), (/ 2, 2 /)) + contains + procedure, private :: trace + generic :: operator(.tr.) => trace + end type base +contains + complex function trace(this) + class(base), intent(in) :: this + base_cnt = base_cnt + 1 +! write(*,*) 'executing base' + trace = this%r(1,1) + this%r(2,2) + end function trace +end module mod_base + +module mod_ext + use mod_base + implicit none + private + integer, public :: ext_cnt = 0 + public :: base, base_cnt + type, public, extends(base) :: ext + private + real :: i(2,2) = reshape( (/ 1.0, 1.0, 1.0, 1.5 /), (/ 2, 2 /)) + contains + procedure, private :: trace => trace_ext + end type ext +contains + complex function trace_ext(this) + class(ext), intent(in) :: this + +! the following should be executed through invoking .tr. p below +! write(*,*) 'executing override' + ext_cnt = ext_cnt + 1 + trace_ext = .tr. this%base + (0.0, 1.0) * ( this%i(1,1) + this%i(2,2) ) + end function trace_ext + +end module mod_ext +program test_override + use mod_ext + implicit none + type(base) :: o + type(ext) :: p + real :: r + + ! Note: ext's ".tr." (trace_ext) calls also base's "trace" + +! write(*,*) .tr. o +! write(*,*) .tr. p + if (base_cnt /= 0 .or. ext_cnt /= 0) call abort () + r = .tr. o + if (base_cnt /= 1 .or. ext_cnt /= 0) call abort () + r = .tr. p + if (base_cnt /= 2 .or. ext_cnt /= 1) call abort () + + if (abs(.tr. o - 5.0 ) < 1.0e-6 .and. abs( .tr. p - (5.0,2.5)) < 1.0e-6) & + then + if (base_cnt /= 4 .or. ext_cnt /= 2) call abort () +! write(*,*) 'OK' + else + call abort() +! write(*,*) 'FAIL' + end if +end program test_override -- 2.11.0