OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

backport: re PR fortran/53255 ([OOP] With TYPE, wrong type-bound operator used: of parent instead of overridden one) 

2012-05-07  Tobias Burnus  <burnus@net-b.de>

        Backport from mainline:
        2012-05-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/53255
        * resolve.c (resolve_typebound_static): Fix handling
        of overridden specific to generic operator.

2012-05-07  Tobias Burnus  <burnus@net-b.de>

        Backport from mainline:
        2012-05-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/53255
        * gfortran.dg/typebound_operator_15.f90: New.

From-SVN: r187232
This commit is contained in:
Tobias Burnus 2012-05-07 13:50:04 +02:00 committed by Tobias Burnus
parent a18c30343d
commit 6c90dfa867
4 changed files with 100 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -1,3 +1,12 @@
2012-05-07 Tobias Burnus <burnus@net-b.de>
Backport from mainline:
2012-05-07 Tobias Burnus <burnus@net-b.de>
PR fortran/53255
* resolve.c (resolve_typebound_static): Fix handling
of overridden specific to generic operator.
2012-05-05 Tobias Burnus <burnus@net-b.de>
Backport from mainline:

11
gcc/fortran/resolve.c
View File

@ -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;

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2012-05-07 Tobias Burnus <burnus@net-b.de>
Backport from mainline:
2012-05-07 Tobias Burnus <burnus@net-b.de>
PR fortran/53255
* gfortran.dg/typebound_operator_15.f90: New.
2012-05-05 Tobias Burnus <burnus@net-b.de>
Backport from mainline:

78
gcc/testsuite/gfortran.dg/typebound_operator_15.f90 Normal file
View File

@ -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