gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08

   1 ! { dg-do run }
   2 !
   3 ! Tests functionality of recursive allocatable derived types.
   4 !
   5   type :: recurses
   6     type(recurses), allocatable :: c
   7     integer, allocatable :: ia
   8   end type
   9
  10   type(recurses), allocatable, target :: a, d
  11   type(recurses), pointer :: b
  12
  13   integer :: total = 0
  14
  15 ! Check chained allocation.
  16   allocate(a)
  17   a%ia = 1
  18   allocate (a%c)
  19   a%c%ia = 2
  20
  21 ! Check move_alloc.
  22   allocate (d)
  23   d%ia = 3
  24   call move_alloc (d, a%c%c)
  25
  26   if (a%ia .ne. 1)  STOP 1
  27   if (a%c%ia .ne. 2)  STOP 2
  28   if (a%c%c%ia .ne. 3)  STOP 3
  29
  30 ! Check that we can point anywhere in the chain
  31   b => a%c%c
  32   if (b%ia .ne. 3) STOP 4
  33   b => a%c
  34   if (b%ia .ne. 2) STOP 5
  35
  36 ! Check that the pointer can be used as if it were an element in the chain.
  37   if (.not.allocated (b%c)) STOP 6
  38   b => a%c%c
  39   if (.not.allocated (b%c)) allocate (b%c)
  40   b%c%ia = 4
  41   if (a%c%c%c%ia .ne. 4) STOP 7
  42
  43 ! A rudimentary iterator.
  44   b => a
  45   do while (associated (b))
  46     total = total + b%ia
  47     b => b%c
  48   end do
  49   if (total .ne. 10) STOP 8
  50
  51 ! Take one element out of the chain.
  52   call move_alloc (a%c%c, d)
  53   call move_alloc (d%c, a%c%c)
  54   if (d%ia .ne. 3) STOP 9
  55   deallocate (d)
  56
  57 ! Checkcount of remaining chain.
  58   total = 0
  59   b => a
  60   do while (associated (b))
  61     total = total + b%ia
  62     b => b%c
  63   end do
  64   if (total .ne. 7) STOP 10
  65
  66 ! Deallocate to check that there are no memory leaks.
  67   deallocate (a%c%c)
  68   deallocate (a%c)
  69   deallocate (a)
  70 end