3 ! Test the fix for pr88735.
5 ! Contributed by Martin Stein <mscfd@gmx.net>
10 integer, pointer :: i => NULL ()
11 character :: myname = 'z'
12 character :: alloc = 'n'
14 procedure, public :: set
15 generic, public :: assignment(=) => set
18 integer, public :: assoc_in_final = 0
19 integer, public :: calls_to_final = 0
20 character, public :: myname1, myname2
24 subroutine set(self, x)
25 class(t), intent(out) :: self
26 class(t), intent(in) :: x
27 if (associated(self%i)) then
28 stop 1 ! Default init for INTENT(OUT)
30 if (associated(x%i)) then
37 subroutine finalise(self)
38 type(t), intent(inout) :: self
39 calls_to_final = calls_to_final + 1
41 if (associated(self%i)) then
42 assoc_in_final = assoc_in_final + 1
43 if (self%alloc .eq. 'y') deallocate (self%i)
45 end subroutine finalise
49 program finalise_assign
66 if (assoc_in_final /= 0) stop 2 ! b%x%i not associated before finalization
67 if (calls_to_final /= 2) stop 3 ! One finalization call
68 if (myname1 .ne. 'b') stop 4 ! Finalization before intent out become undefined
69 if (myname2 .ne. 'z') stop 5 ! Intent out now default initialized
70 if (.not.associated (b%x%i, a%x%i)) stop 6
72 allocate (c%i, source = 789)
75 if (assoc_in_final /= 1) stop 6 ! c%i is allocated prior to the assignment
76 if (calls_to_final /= 3) stop 7 ! One finalization call for the assignment
77 if (myname1 .ne. 'c') stop 8 ! Finalization before intent out become undefined
78 if (myname2 .ne. 'z') stop 9 ! Intent out now default initialized
81 if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
82 if (calls_to_final /= 5) stop 11 ! One finalization call for the assignment
83 if (myname1 .ne. 'z') stop 12 ! b%x%myname was default initialized in earlier assignment
84 if (myname2 .ne. 'z') stop 13 ! Intent out now default initialized
85 if (b%x%i .ne. 126) stop 14 ! Three assignments with self%x%i pointing to same target
87 if (.not.associated (b%x%i, c%i)) then
89 b%x%i =>NULL () ! Although not needed here, clean up
92 end program finalise_assign