gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08

   1 ! { dg-do run }
   2 !
   3 ! Tests functionality of recursive allocatable derived types.
   4 !
   5 module m
   6   type :: recurses
   7     type(recurses), allocatable :: left
   8     type(recurses), allocatable :: right
   9     integer, allocatable :: ia
  10   end type
  11 contains
  12 ! Obtain checksum from "keys".
  13   recursive function foo (this) result (res)
  14     type(recurses) :: this
  15     integer :: res
  16     res = this%ia
  17     if (allocated (this%left)) res = res + foo (this%left)
  18     if (allocated (this%right)) res = res + foo (this%right)
  19   end function
  20 ! Return pointer to member of binary tree matching "key", null otherwise.
  21   recursive function bar (this, key) result (res)
  22     type(recurses), target :: this
  23     type(recurses), pointer :: res
  24     integer :: key
  25     if (key .eq. this%ia) then
  26       res => this
  27       return
  28     else
  29       res => NULL ()
  30     end if
  31     if (allocated (this%left)) res => bar (this%left, key)
  32     if (associated (res)) return
  33     if (allocated (this%right)) res => bar (this%right, key)
  34   end function
  35 end module
  36
  37   use m
  38   type(recurses), allocatable, target :: a
  39   type(recurses), pointer :: b => NULL ()
  40
  41 ! Check chained allocation.
  42   allocate(a)
  43   a%ia = 1
  44   allocate (a%left)
  45   a%left%ia = 2
  46   allocate (a%left%left)
  47   a%left%left%ia = 3
  48   allocate (a%left%right)
  49   a%left%right%ia = 4
  50   allocate (a%right)
  51   a%right%ia = 5
  52
  53 ! Checksum OK?
  54   if (foo(a) .ne. 15) call abort
  55
  56 ! Return pointer to tree item that is present.
  57   b => bar (a, 3)
  58   if (.not.associated (b) .or. (b%ia .ne. 3)) call abort
  59 ! Return NULL to tree item that is not present.
  60   b => bar (a, 6)
  61   if (associated (b)) call abort
  62
  63 ! Deallocate to check that there are no memory leaks.
  64   deallocate (a)
  65 end