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
|
! { dg-do run }
!
! Test that pr78395 is fixed.
! Contributed by Chris MacMackin and Janus Weil
module types_mod
implicit none
type, public :: t1
integer :: a
contains
procedure :: get_t2
end type
type, public :: t2
integer :: b
contains
procedure, pass(rhs) :: mul2
procedure :: assign
generic :: operator(*) => mul2
generic :: assignment(=) => assign
end type
contains
function get_t2(this)
class(t1), intent(in) :: this
class(t2), allocatable :: get_t2
type(t2), allocatable :: local
allocate(local)
local%b = this%a
call move_alloc(local, get_t2)
end function
function mul2(lhs, rhs)
class(t2), intent(in) :: rhs
integer, intent(in) :: lhs
class(t2), allocatable :: mul2
type(t2), allocatable :: local
allocate(local)
local%b = rhs%b*lhs
call move_alloc(local, mul2)
end function
subroutine assign(this, rhs)
class(t2), intent(out) :: this
class(t2), intent(in) :: rhs
select type(rhs)
type is(t2)
this%b = rhs%b
class default
error stop
end select
end subroutine
end module
program minimal
use types_mod
implicit none
class(t1), allocatable :: v4
class(t2), allocatable :: v6
allocate(v4, source=t1(4))
allocate(v6)
v6 = 3 * v4%get_t2()
select type (v6)
type is (t2)
if (v6%b /= 12) error stop
class default
error stop
end select
deallocate(v4, v6)
end
|