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