gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08

   1 ! { dg-do run }
   2 !
   3 ! Tests functionality of recursive allocatable derived types.
   4 !
   5 module m
   6   type :: stack
   7     integer :: value
   8     integer :: index
   9     type(stack), allocatable :: next
  10   end type stack
  11 end module
  12
  13   use m
  14 ! Here is how to add a new entry at the top of the stack:
  15   type (stack), allocatable :: top, temp, dum
  16
  17   call poke (1)
  18   call poke (2)
  19   call poke (3)
  20   if (top%index .ne. 3) call abort
  21   call output (top)
  22   call pop
  23   if (top%index .ne. 2) call abort
  24   call output (top)
  25   deallocate (top)
  26 contains
  27   subroutine output (arg)
  28     type(stack), target, allocatable :: arg
  29     type(stack), pointer :: ptr
  30
  31     if (.not.allocated (arg)) then
  32       print *, "empty stack"
  33       return
  34     end if
  35
  36     print *, "        idx           value"
  37     ptr => arg
  38     do while (associated (ptr))
  39       print *, ptr%index, "   ", ptr%value
  40       ptr => ptr%next
  41     end do
  42   end subroutine
  43   subroutine poke(arg)
  44     integer :: arg
  45     integer :: idx
  46     if (allocated (top)) then
  47       idx = top%index + 1
  48     else
  49       idx = 1
  50     end if
  51     allocate (temp)
  52     temp%value = arg
  53     temp%index = idx
  54     call move_alloc(top,temp%next)
  55     call move_alloc(temp,top)
  56   end subroutine
  57   subroutine pop
  58     call move_alloc(top%next,temp)
  59     call move_alloc(temp,top)
  60   end subroutine
  61 end