gcc/testsuite/gfortran.dg/pdt_15.f03

   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 !
  14 module 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)
  19 end module precision_module
  20
  21 module 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
  31 contains
  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
  79 end module link_module
  80
  81 program ch2701
  82   use precision_module
  83   use link_module
  84   implicit none
  85   integer, parameter :: wp = dp
  86
  87   call foo
  88 contains
  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
 103 end 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" } }