1! { dg-do run } 2! Test the fix for PR42385, in which CLASS defined operators 3! compiled but were not correctly dynamically dispatched. 4! 5! Contributed by Janus Weil <janus@gcc.gnu.org> 6! 7module foo_module 8 implicit none 9 private 10 public :: foo 11 12 type :: foo 13 integer :: foo_x 14 contains 15 procedure :: times => times_foo 16 procedure :: assign => assign_foo 17 generic :: operator(*) => times 18 generic :: assignment(=) => assign 19 end type 20 21contains 22 23 function times_foo(this,factor) result(product) 24 class(foo) ,intent(in) :: this 25 class(foo) ,allocatable :: product 26 integer, intent(in) :: factor 27 allocate (product, source = this) 28 product%foo_x = -product%foo_x * factor 29 end function 30 31 subroutine assign_foo(lhs,rhs) 32 class(foo) ,intent(inout) :: lhs 33 class(foo) ,intent(in) :: rhs 34 lhs%foo_x = -rhs%foo_x 35 end subroutine 36 37end module 38 39module bar_module 40 use foo_module ,only : foo 41 implicit none 42 private 43 public :: bar 44 45 type ,extends(foo) :: bar 46 integer :: bar_x 47 contains 48 procedure :: times => times_bar 49 procedure :: assign => assign_bar 50 end type 51 52contains 53 subroutine assign_bar(lhs,rhs) 54 class(bar) ,intent(inout) :: lhs 55 class(foo) ,intent(in) :: rhs 56 select type(rhs) 57 type is (bar) 58 lhs%bar_x = rhs%bar_x 59 lhs%foo_x = -rhs%foo_x 60 end select 61 end subroutine 62 function times_bar(this,factor) result(product) 63 class(bar) ,intent(in) :: this 64 integer, intent(in) :: factor 65 class(foo), allocatable :: product 66 select type(this) 67 type is (bar) 68 allocate(product,source=this) 69 select type(product) 70 type is(bar) 71 product%bar_x = 2*this%bar_x*factor 72 end select 73 end select 74 end function 75end module 76 77program main 78 use foo_module ,only : foo 79 use bar_module ,only : bar 80 implicit none 81 type(foo) :: unitf 82 type(bar) :: unitb 83 84! foo's assign negates, whilst its '*' negates and mutliplies. 85 unitf%foo_x = 1 86 call rescale(unitf, 42) 87 if (unitf%foo_x .ne. 42) call abort 88 89! bar's assign negates foo_x, whilst its '*' copies foo_x 90! and does a multiply by twice factor. 91 unitb%foo_x = 1 92 unitb%bar_x = 2 93 call rescale(unitb, 3) 94 if (unitb%bar_x .ne. 12) call abort 95 if (unitb%foo_x .ne. -1) call abort 96contains 97 subroutine rescale(this,scale) 98 class(foo) ,intent(inout) :: this 99 integer, intent(in) :: scale 100 this = this*scale 101 end subroutine 102end program 103