gcc/testsuite/gfortran.dg/typebound_operator_15.f90

! { 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) STOP 1
  r = .tr. o
  if (base_cnt /= 1 .or. ext_cnt /= 0) STOP 2
  r = .tr. p
  if (base_cnt /= 2 .or. ext_cnt /= 1) STOP 3

  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) STOP 4
!     write(*,*) 'OK'
  else
    STOP 5
!     write(*,*) 'FAIL'
  end if
end program test_override