gcc/testsuite/gfortran.dg/pdt_13.f03

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR82375
   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)), pointer :: next => NULL()
  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)), pointer :: self
  28     type (link(real_kind=dp)), pointer :: current
  29
  30     if (associated (self)) then
  31       current => self
  32       do while (associated (current%next))
  33         current => current%next
  34       end do
  35
  36       allocate (current%next)
  37       current => current%next
  38     else
  39       allocate (current)
  40       self => current
  41     end if
  42
  43     current%n = arg
  44     current%next => NULL ()
  45   end function push_8
  46
  47   function pop_8 (self) result(res)
  48     type (link(real_kind=dp)), pointer :: self
  49     type (link(real_kind=dp)), pointer :: current => NULL()
  50     type (link(real_kind=dp)), pointer :: previous => NULL()
  51     real(dp) :: res
  52
  53     res = 0.0_8
  54     if (associated (self)) then
  55       current => self
  56       do while (associated (current) .and. associated (current%next))
  57          previous => current
  58          current => current%next
  59       end do
  60
  61       previous%next => NULL ()
  62
  63       res = current%n
  64       if (associated (self, current)) then
  65         deallocate (self)
  66       else
  67         deallocate (current)
  68       end if
  69
  70     end if
  71   end function pop_8
  72
  73 end module link_module
  74
  75 program ch2701
  76   use precision_module
  77   use link_module
  78   implicit none
  79   integer, parameter :: wp = dp
  80   type (link(real_kind=wp)), pointer :: root => NULL()
  81   type (link(real_kind=wp)), pointer :: current
  82
  83   current => push_8 (root, 1.0_8)
  84   current => push_8 (root, 2.0_8)
  85   current => push_8 (root, 3.0_8)
  86
  87   if (int (pop_8 (root)) .ne. 3) call abort
  88   if (int (pop_8 (root)) .ne. 2) call abort
  89   if (int (pop_8 (root)) .ne. 1) call abort
  90   if (int (pop_8 (root)) .ne. 0) call abort
  91
  92 end program ch2701