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