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
|
! { dg-do run }
! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR
! testcases run correctly, this checks that other requirements of the
! standard are satisfied.
!
module m0
implicit none
type component
integer :: i = 0
integer, allocatable :: j(:)
contains
procedure :: assign0
generic :: assignment(=)=>assign0
end type
type parent
type(component) :: foo1
end type
type, extends(parent) :: child
integer :: k = 1000
integer, allocatable :: l(:)
type(component) :: foo2
end type
contains
subroutine assign0(lhs,rhs)
class(component), intent(inout) :: lhs
class(component), intent(in) :: rhs
if (lhs%i .eq. 0) then
lhs%i = rhs%i
lhs%j = rhs%j
else
lhs%i = rhs%i*2
lhs%j = [rhs%j, rhs%j*2]
end if
end subroutine
type(child) function new_child()
new_child%parent%foo1%i = 20
new_child%foo2%i = 21
new_child%parent%foo1%j = [99,199]
new_child%foo2%j = [199,299]
new_child%l = [299,399]
new_child%k = 1001
end function
end module
program main
use m0
implicit none
type(child) :: infant0
! Check that the INTENT(INOUT) of assign0 is respected and that the
! correct thing is done with allocatable components.
infant0 = new_child()
if (infant0%parent%foo1%i .ne. 20) STOP 1
if (infant0%foo2%i .ne. 21) STOP 2
if (any (infant0%parent%foo1%j .ne. [99,199])) STOP 3
if (any (infant0%foo2%j .ne. [199,299])) STOP 4
if (infant0%foo2%i .ne. 21) STOP 5
if (any (infant0%l .ne. [299,399])) STOP 6
! Now, since the defined assignment depends on whether or not the 'i'
! component is the default initialization value, the result will be
! different.
infant0 = new_child()
if (infant0%parent%foo1%i .ne. 40) STOP 7
if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) STOP 8
if (any (infant0%foo2%j .ne. [199,299,398,598])) STOP 9
if (infant0%foo2%i .ne. 42) STOP 10
if (any (infant0%l .ne. [299,399])) STOP 11
! Finally, make sure that normal components of the declared type survive.
if (infant0%k .ne. 1001) STOP 12
end
|
