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! 10module 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 21contains 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 28end module mod_base 29 30module 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 42contains 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 52end module mod_ext 53program 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 78end program test_override 79