gcc/testsuite/gfortran.dg/typebound_operator_15.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/53255
   4 !
   5 ! Contributed by Reinhold Bader.
   6 !
   7 ! Before TYPE(ext)'s .tr. wrongly called the base type's trace
   8 ! instead of ext's trace_ext.
   9 !
  10 module mod_base
  11   implicit none
  12   private
  13   integer, public :: base_cnt = 0
  14   type, public :: base
  15      private
  16      real :: r(2,2) = reshape( (/ 1.0, 2.0, 3.0, 4.0 /), (/ 2, 2 /))
  17    contains
  18      procedure, private :: trace
  19      generic :: operator(.tr.) => trace
  20   end type base
  21 contains
  22   complex function trace(this)
  23     class(base), intent(in) :: this
  24     base_cnt = base_cnt + 1
  25 !    write(*,*) 'executing base'
  26     trace = this%r(1,1) + this%r(2,2)
  27   end function trace
  28 end module mod_base
  29
  30 module mod_ext
  31   use mod_base
  32   implicit none
  33   private
  34   integer, public :: ext_cnt = 0
  35   public :: base, base_cnt
  36   type, public, extends(base) :: ext
  37      private
  38      real :: i(2,2) = reshape( (/ 1.0, 1.0, 1.0, 1.5 /), (/ 2, 2 /))
  39    contains
  40      procedure, private :: trace => trace_ext
  41   end type ext
  42 contains
  43    complex function trace_ext(this)
  44     class(ext), intent(in) :: this
  45
  46 !   the following should be executed through invoking .tr. p below
  47 !    write(*,*) 'executing override'
  48     ext_cnt = ext_cnt + 1
  49     trace_ext = .tr. this%base + (0.0, 1.0) * ( this%i(1,1) + this%i(2,2) )
  50   end function trace_ext
  51
  52 end module mod_ext
  53 program test_override
  54   use mod_ext
  55   implicit none
  56   type(base) :: o
  57   type(ext) :: p
  58   real :: r
  59
  60   ! Note: ext's ".tr." (trace_ext) calls also base's "trace"
  61
  62 !  write(*,*) .tr. o
  63 !  write(*,*) .tr. p
  64   if (base_cnt /= 0 .or. ext_cnt /= 0) STOP 1
  65   r = .tr. o
  66   if (base_cnt /= 1 .or. ext_cnt /= 0) STOP 2
  67   r = .tr. p
  68   if (base_cnt /= 2 .or. ext_cnt /= 1) STOP 3
  69
  70   if (abs(.tr. o - 5.0 ) < 1.0e-6  .and. abs( .tr. p - (5.0,2.5)) < 1.0e-6) &
  71   then
  72     if (base_cnt /= 4 .or. ext_cnt /= 2) STOP 4
  73 !     write(*,*) 'OK'
  74   else
  75     STOP 5
  76 !     write(*,*) 'FAIL'
  77   end if
  78 end program test_override