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
|
! { dg-do run }
!
! Test the fix for pr88735.
!
! Contributed by Martin Stein <mscfd@gmx.net>
!
module mod
implicit none
type, public :: t
integer, pointer :: i => NULL ()
character :: myname = 'z'
character :: alloc = 'n'
contains
procedure, public :: set
generic, public :: assignment(=) => set
final :: finalise
end type t
integer, public :: assoc_in_final = 0
integer, public :: calls_to_final = 0
character, public :: myname1, myname2
contains
subroutine set(self, x)
class(t), intent(out) :: self
class(t), intent(in) :: x
if (associated(self%i)) then
stop 1 ! Default init for INTENT(OUT)
endif
if (associated(x%i)) then
myname2 = self%myname
self%i => x%i
self%i = self%i + 1
end if
end subroutine set
subroutine finalise(self)
type(t), intent(inout) :: self
calls_to_final = calls_to_final + 1
myname1 = self%myname
if (associated(self%i)) then
assoc_in_final = assoc_in_final + 1
if (self%alloc .eq. 'y') deallocate (self%i)
end if
end subroutine finalise
end module mod
program finalise_assign
use mod
implicit none
type :: s
integer :: i = 0
type(t) :: x
end type s
type(s) :: a, b
type(t) :: c
a%x%myname = 'a'
b%x%myname = 'b'
c%myname = 'c'
allocate (a%x%i)
a%x%i = 123
a%x%alloc = 'y'
b = a
if (assoc_in_final /= 0) stop 2 ! b%x%i not associated before finalization
if (calls_to_final /= 2) stop 3 ! One finalization call
if (myname1 .ne. 'b') stop 4 ! Finalization before intent out become undefined
if (myname2 .ne. 'z') stop 5 ! Intent out now default initialized
if (.not.associated (b%x%i, a%x%i)) stop 6
allocate (c%i, source = 789)
c%alloc = 'y'
c = a%x
if (assoc_in_final /= 1) stop 6 ! c%i is allocated prior to the assignment
if (calls_to_final /= 3) stop 7 ! One finalization call for the assignment
if (myname1 .ne. 'c') stop 8 ! Finalization before intent out become undefined
if (myname2 .ne. 'z') stop 9 ! Intent out now default initialized
b = a
if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
if (calls_to_final /= 5) stop 11 ! One finalization call for the assignment
if (myname1 .ne. 'z') stop 12 ! b%x%myname was default initialized in earlier assignment
if (myname2 .ne. 'z') stop 13 ! Intent out now default initialized
if (b%x%i .ne. 126) stop 14 ! Three assignments with self%x%i pointing to same target
deallocate (a%x%i)
if (.not.associated (b%x%i, c%i)) then
stop 15 ! ditto
b%x%i =>NULL () ! Although not needed here, clean up
c%i => NULL ()
endif
end program finalise_assign
|
