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
93
94
95
96
97
98
99
100
101
102
103
104
105
|
! { dg-do run }
!
! Check that PR91316 is fixed. Note removal of recursive I/O.
!
! Contributed by Jose Rui Faustino de Sousa <jrfsousa@gcc.gnu.org>
!
! NAGFOR complains correctly about the finalization of an INTENT(OUT) dummy
! with an impure finalization subroutine, within a pure procedure.
! It also complains about the finalization of final_set, which does not seem
! to be correct (see finalize_50.f90).
! Both procedures have been made impure so that this testcase runs with both
! compilers.
!
module final_m
implicit none
private
public :: &
assignment(=)
public :: &
final_t
public :: &
final_init, &
final_set, &
final_get, &
final_end
type :: final_t
private
integer :: n = -1
contains
final :: final_end
end type final_t
interface assignment(=)
module procedure final_init
end interface assignment(=)
integer, public :: final_ctr = 0
integer, public :: final_res = 0
contains
impure elemental subroutine final_init(this, n)
type(final_t), intent(out) :: this
integer, intent(in) :: n
this%n = n
end subroutine final_init
impure elemental function final_set(n) result(this)
integer, intent(in) :: n
type(final_t) :: this
this%n = n
end function final_set
elemental function final_get(this) result(n)
type(final_t), intent(in) :: this
integer :: n
n = this%n
end function final_get
subroutine final_end(this)
type(final_t), intent(inout) :: this
! print *, "DESTROY: ", this%n !< generates illegal, recursive io in 'final_s4'
final_res = this%n
final_ctr = final_ctr + 1
this%n = -1
end subroutine final_end
end module final_m
program final_p
use final_m
implicit none
type(final_t) :: f0
! call final_init(f0, 0)
call final_s1()
call final_s2()
call final_s3()
call final_s4()
call final_end(f0)
contains
subroutine final_s1()
type(final_t) :: f
call final_init(f, 1)
print *, "f1: ", final_get(f)
if ((final_ctr .ne. 1) .or. (final_res .ne. -1)) stop 1
end subroutine final_s1
subroutine final_s2()
type(final_t) :: f
f = 2
print *, "f2: ", final_get(f)
if ((final_ctr .ne. 3) .or. (final_res .ne. -1)) stop 1
end subroutine final_s2
subroutine final_s3()
type(final_t) :: f
f = final_set(3)
print *, "f3: ", final_get(f)
if ((final_ctr .ne. 6) .or. (final_res .ne. 3)) stop 1
end subroutine final_s3
subroutine final_s4()
print *, "f4: ", final_get(final_set(4))
if ((final_ctr .ne. 8) .or. (final_res .ne. 4)) stop 1
end subroutine final_s4
end program final_p
|
