blob: 2c5b837d67022b36b52ca68d0e2c19ceea5913b8 (
plain)
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
|
! { dg-do run }
!
! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call
!
! Contributed by John <jwmwalrus@gmail.com>
module mod1
implicit none
type :: itemType
contains
procedure :: the_assignment => assign_itemType
generic :: assignment(=) => the_assignment
end type
contains
subroutine assign_itemType(left, right)
class(itemType), intent(OUT) :: left
class(itemType), intent(IN) :: right
end subroutine
end module
module mod2
use mod1
implicit none
type, extends(itemType) :: myItem
character(3) :: name = ''
contains
procedure :: the_assignment => assign_myItem
end type
contains
subroutine assign_myItem(left, right)
class(myItem), intent(OUT) :: left
class(itemType), intent(IN) :: right
select type (right)
type is (myItem)
left%name = right%name
end select
end subroutine
end module
program test_assign
use mod2
implicit none
class(itemType), allocatable :: item1, item2
allocate (myItem :: item1)
select type (item1)
type is (myItem)
item1%name = 'abc'
end select
allocate (myItem :: item2)
item2 = item1
select type (item2)
type is (myItem)
if (item2%name /= 'abc') call abort()
class default
call abort()
end select
end
! { dg-final { cleanup-modules "mod1 mod2" } }
|
