gcc/testsuite/gfortran.dg/pdt_14.f03

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR82375. This is the allocatable version of pdt_13.f03.
   4 !
   5 ! Based on contribution by Ian Chivers  <ian@rhymneyconsulting.co.uk>
   6 !
   7 module precision_module
   8   implicit none
   9   integer, parameter :: sp = selected_real_kind(6, 37)
  10   integer, parameter :: dp = selected_real_kind(15, 307)
  11   integer, parameter :: qp = selected_real_kind( 30, 291)
  12 end module precision_module
  13
  14 module link_module
  15   use precision_module
  16
  17   type link(real_kind)
  18     integer, kind :: real_kind
  19     real (kind=real_kind) :: n
  20     type (link(real_kind)), allocatable :: next
  21   end type link
  22
  23 contains
  24
  25   function push_8 (self, arg) result(current)
  26     real(dp) :: arg
  27     type (link(real_kind=dp)), allocatable, target :: self
  28     type (link(real_kind=dp)), pointer :: current
  29
  30     if (allocated (self)) then
  31       current => self
  32       do while (allocated (current%next))
  33         current => current%next
  34       end do
  35
  36       allocate (current%next)
  37       current => current%next
  38     else
  39       allocate (self)
  40       current => self
  41     end if
  42
  43     current%n = arg
  44
  45   end function push_8
  46
  47   function pop_8 (self) result(res)
  48     type (link(real_kind=dp)), allocatable, target :: self
  49     type (link(real_kind=dp)), pointer:: current
  50     type (link(real_kind=dp)), pointer :: previous
  51     real(dp) :: res
  52
  53     res = 0.0_8
  54     if (allocated (self)) then
  55       current => self
  56       previous => self
  57       do while (allocated (current%next))
  58          previous => current
  59          current => current%next
  60       end do
  61       res = current%n
  62       if (.not.allocated (previous%next)) then
  63         deallocate (self)
  64       else
  65         deallocate (previous%next)
  66       end if
  67
  68     end if
  69   end function pop_8
  70
  71 end module link_module
  72
  73 program ch2701
  74   use precision_module
  75   use link_module
  76   implicit none
  77   integer, parameter :: wp = dp
  78   type (link(real_kind=wp)), allocatable :: root
  79   type (link(real_kind=wp)), pointer :: current
  80
  81   current => push_8 (root, 1.0_8)
  82   current => push_8 (root, 2.0_8)
  83   current => push_8 (root, 3.0_8)
  84
  85   if (int (pop_8 (root)) .ne. 3) call abort
  86   if (int (pop_8 (root)) .ne. 2) call abort
  87   if (int (pop_8 (root)) .ne. 1) call abort
  88   if (int (pop_8 (root)) .ne. 0) call abort
  89
  90 end program ch2701