1! { dg-do compile }
2! { dg-options "-fdump-tree-original" }
3!
4! Test the fix for PR82375. This is a wrinkle on the the allocatable
5! version of pdt_13.f03, pdt_14.f03, whereby 'root' is now declared
6! in a subroutine so that it should be cleaned up automatically. This
7! is best tested with valgrind or its like.
8! In addition, the field 'n' has now become a parameterized length
9! array to verify that the combination of allocatable components and
10! parameterization works correctly.
11!
12! Based on contribution by Ian Chivers  <ian@rhymneyconsulting.co.uk>
13!
14module precision_module
15  implicit none
16  integer, parameter :: sp = selected_real_kind(6, 37)
17  integer, parameter :: dp = selected_real_kind(15, 307)
18  integer, parameter :: qp = selected_real_kind( 30, 291)
19end module precision_module
20
21module link_module
22  use precision_module
23
24  type link(real_kind, mat_len)
25    integer, kind :: real_kind
26    integer, len :: mat_len
27    real (kind=real_kind) :: n(mat_len)
28    type (link(real_kind, :)), allocatable :: next
29  end type link
30
31contains
32
33  function push_8 (self, arg) result(current)
34    real(dp) :: arg
35    type (link(real_kind=dp, mat_len=:)), allocatable, target :: self
36    type (link(real_kind=dp, mat_len=:)), pointer :: current
37
38    if (allocated (self)) then
39      current => self
40      do while (allocated (current%next))
41        current => current%next
42      end do
43
44      allocate (link(real_kind=dp, mat_len=1) :: current%next)
45      current => current%next
46    else
47      allocate (link(real_kind=dp, mat_len=1) :: self)
48      current => self
49    end if
50
51    current%n(1) = arg
52
53  end function push_8
54
55  function pop_8 (self) result(res)
56    type (link(real_kind=dp, mat_len=:)), allocatable, target :: self
57    type (link(real_kind=dp, mat_len=:)), pointer:: current => NULL()
58    type (link(real_kind=dp, mat_len=:)), pointer :: previous => NULL()
59    real(dp) :: res
60
61    res = 0.0_8
62    if (allocated (self)) then
63      current => self
64      previous => self
65      do while (allocated (current%next))
66         previous => current
67         current => current%next
68      end do
69      res = current%n(1)
70      if (.not.allocated (previous%next)) then
71        deallocate (self)
72      else
73        deallocate (previous%next)
74      end if
75
76    end if
77  end function pop_8
78
79end module link_module
80
81program ch2701
82  use precision_module
83  use link_module
84  implicit none
85  integer, parameter :: wp = dp
86
87  call foo
88contains
89
90  subroutine foo
91    type (link(real_kind=wp, mat_len=:)), allocatable :: root
92    type (link(real_kind=wp, mat_len=:)), pointer :: current => NULL()
93
94    current => push_8 (root, 1.0_8)
95    current => push_8 (root, 2.0_8)
96    current => push_8 (root, 3.0_8)
97
98    if (int (pop_8 (root)) .ne. 3) STOP 1
99    if (int (pop_8 (root)) .ne. 2) STOP 2
100    if (int (pop_8 (root)) .ne. 1) STOP 3
101!    if (int (pop_8 (root)) .ne. 0) STOP 4
102  end subroutine
103end program ch2701
104! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
105! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } }
106! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
107