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
|
! { dg-do run }
!
! Test the fix for PR67444 in which the finalization of a polymorphic 'var'
! was not being finalized before assignment. (STOP 3)
!
! Contributed by Balint Aradi <baladi@gmail.com>
!
module classes
implicit none
integer :: ivalue = 0
integer :: icall = 0
integer :: fvalue = 0
type :: Basic
integer :: ii = -1
contains
procedure :: assignBasic
generic :: assignment(=) => assignBasic
final :: destructBasic
end type Basic
interface Basic
module procedure initBasic
end interface Basic
contains
function initBasic(initValue) result(this)
integer, intent(in) :: initValue
type(Basic) :: this
this%ii = initValue
icall = icall + 1
end function initBasic
subroutine assignBasic(this, other)
class(Basic), intent(out) :: this
type(Basic), intent(in) :: other
this%ii = other%ii + 1
icall = other%ii
end subroutine assignBasic
subroutine destructBasic(this)
type(Basic), intent(inout) :: this
fvalue = fvalue + 1
select case (fvalue)
case (1)
if (this%ii /= -1) stop 1 ! First finalization before assignment to 'var'
if (icall /= 1) stop 2 ! and before evaluation of 'expr'.
case(2)
if (this%ii /= ivalue) stop 3 ! Finalization of intent(out) in 'assignBasic'
if (icall /= 42) stop 4 ! and after evaluation of 'expr'.
case(3)
if (this%ii /= ivalue + 1) stop 5 ! Finalization of 'expr' (function!) after assignment.
case default
stop 6 ! Too many or no finalizations
end select
end subroutine destructBasic
end module classes
module usage
use classes
implicit none
contains
subroutine useBasic()
type(Basic) :: bas
ivalue = 42
bas = Basic(ivalue)
end subroutine useBasic
end module usage
program test
use usage
implicit none
call useBasic()
if (fvalue /= 3) stop 7 ! 3 finalizations mandated.
end program test
|
