re PR fortran/45516 ([F08] allocatable compontents of recursive type)

2016-10-25  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/45516
	* class.c (gfc_find_derived_vtab): Detect recursive allocatable
	derived type components. If present, add '_deallocate' field to
	the vtable and build the '__deallocate' function.
	* decl.c (build_struct): Allow recursive allocatable derived
	type components for -std=f2008 or more.
	(gfc_match_data_decl): Accept these derived types.
	* expr.c (gfc_has_default_initializer): Ditto.
	* resolve.c (resolve_component): Make sure that the vtable is
	built for these derived types.
	* trans-array.c(structure_alloc_comps) : Use the '__deallocate'
	function for the automatic deallocation of these types.
	* trans-expr.c : Generate the deallocate accessor.
	* trans.h : Add its prototype.
	* trans-types.c (gfc_get_derived_type): Treat the recursive
	allocatable components in the same way as the corresponding
	pointer components.

2016-10-25  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/45516
	* gfortran.dg/class_2.f03: Set -std=f2003.
	* gfortran.dg/finalize_21.f90: Modify tree-dump.
	* gfortran.dg/recursive_alloc_comp_1.f08: New test.
	* gfortran.dg/recursive_alloc_comp_2.f08: New test.
	* gfortran.dg/recursive_alloc_comp_3.f08: New test.
	* gfortran.dg/recursive_alloc_comp_4.f08: New test.

From-SVN: r241539

6 files changed, 244 insertions, 1 deletions

diff --git a/gcc/testsuite/gfortran.dg/class_2.f03 b/gcc/testsuite/gfortran.dg/class_2.f03
index 3a75d55..58b0b4a 100644
--- a/gcc/testsuite/gfortran.dg/class_2.f03
+++ b/gcc/testsuite/gfortran.dg/class_2.f03
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=f2003" }
 !
 ! PR 40940: CLASS statement
 !
diff --git a/gcc/testsuite/gfortran.dg/finalize_21.f90 b/gcc/testsuite/gfortran.dg/finalize_21.f90
index 6df1f31..5a8fec3 100644
--- a/gcc/testsuite/gfortran.dg/finalize_21.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_21.f90
@@ -8,4 +8,4 @@
 class(*), allocatable :: var
 end
 
-! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B};" "original" } }
+! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B, ._deallocate=0B};" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08
new file mode 100644
index 0000000..383eff4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08
@@ -0,0 +1,70 @@
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+  type :: recurses
+    type(recurses), allocatable :: c
+    integer, allocatable :: ia
+  end type
+
+  type(recurses), allocatable, target :: a, d
+  type(recurses), pointer :: b
+
+  integer :: total = 0
+
+! Check chained allocation.
+  allocate(a)
+  a%ia = 1
+  allocate (a%c)
+  a%c%ia = 2
+
+! Check move_alloc.
+  allocate (d)
+  d%ia = 3
+  call move_alloc (d, a%c%c)
+
+  if (a%ia .ne. 1)  call abort
+  if (a%c%ia .ne. 2)  call abort
+  if (a%c%c%ia .ne. 3)  call abort
+
+! Check that we can point anywhere in the chain
+  b => a%c%c
+  if (b%ia .ne. 3) call abort
+  b => a%c
+  if (b%ia .ne. 2) call abort
+
+! Check that the pointer can be used as if it were an element in the chain.
+  if (.not.allocated (b%c)) call abort
+  b => a%c%c
+  if (.not.allocated (b%c)) allocate (b%c)
+  b%c%ia = 4
+  if (a%c%c%c%ia .ne. 4) call abort
+
+! A rudimentary iterator.
+  b => a
+  do while (associated (b))
+    total = total + b%ia
+    b => b%c
+  end do
+  if (total .ne. 10) call abort
+
+! Take one element out of the chain.
+  call move_alloc (a%c%c, d)
+  call move_alloc (d%c, a%c%c)
+  if (d%ia .ne. 3) call abort
+  deallocate (d)
+
+! Checkcount of remaining chain.
+  total = 0
+  b => a
+  do while (associated (b))
+    total = total + b%ia
+    b => b%c
+  end do
+  if (total .ne. 7) call abort
+
+! Deallocate to check that there are no memory leaks.
+  deallocate (a%c%c)
+  deallocate (a%c)
+  deallocate (a)
+end
diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08
new file mode 100644
index 0000000..85ab14b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+module m
+  type :: recurses
+    type(recurses), allocatable :: left
+    type(recurses), allocatable :: right
+    integer, allocatable :: ia
+  end type
+contains
+! Obtain checksum from "keys".
+  recursive function foo (this) result (res)
+    type(recurses) :: this
+    integer :: res
+    res = this%ia
+    if (allocated (this%left)) res = res + foo (this%left)
+    if (allocated (this%right)) res = res + foo (this%right)
+  end function
+! Return pointer to member of binary tree matching "key", null otherwise.
+  recursive function bar (this, key) result (res)
+    type(recurses), target :: this
+    type(recurses), pointer :: res
+    integer :: key
+    if (key .eq. this%ia) then
+      res => this
+      return
+    else
+      res => NULL ()
+    end if
+    if (allocated (this%left)) res => bar (this%left, key)
+    if (associated (res)) return
+    if (allocated (this%right)) res => bar (this%right, key)
+  end function
+end module
+
+  use m
+  type(recurses), allocatable, target :: a
+  type(recurses), pointer :: b => NULL ()
+
+! Check chained allocation.
+  allocate(a)
+  a%ia = 1
+  allocate (a%left)
+  a%left%ia = 2
+  allocate (a%left%left)
+  a%left%left%ia = 3
+  allocate (a%left%right)
+  a%left%right%ia = 4
+  allocate (a%right)
+  a%right%ia = 5
+
+! Checksum OK?
+  if (foo(a) .ne. 15) call abort
+
+! Return pointer to tree item that is present.
+  b => bar (a, 3)
+  if (.not.associated (b) .or. (b%ia .ne. 3)) call abort
+! Return NULL to tree item that is not present.
+  b => bar (a, 6)
+  if (associated (b)) call abort
+
+! Deallocate to check that there are no memory leaks.
+  deallocate (a)
+end
diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08
new file mode 100644
index 0000000..d7f8f66
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08
@@ -0,0 +1,61 @@
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+module m
+  type :: stack
+    integer :: value
+    integer :: index
+    type(stack), allocatable :: next
+  end type stack
+end module
+
+  use m
+! Here is how to add a new entry at the top of the stack:
+  type (stack), allocatable :: top, temp, dum
+
+  call poke (1)
+  call poke (2)
+  call poke (3)
+  if (top%index .ne. 3) call abort
+  call output (top)
+  call pop
+  if (top%index .ne. 2) call abort
+  call output (top)
+  deallocate (top)
+contains
+  subroutine output (arg)
+    type(stack), target, allocatable :: arg
+    type(stack), pointer :: ptr
+
+    if (.not.allocated (arg)) then
+      print *, "empty stack"
+      return
+    end if
+
+    print *, "        idx           value"
+    ptr => arg
+    do while (associated (ptr))
+      print *, ptr%index, "   ", ptr%value
+      ptr => ptr%next
+    end do
+  end subroutine
+  subroutine poke(arg)
+    integer :: arg
+    integer :: idx
+    if (allocated (top)) then
+      idx = top%index + 1
+    else
+      idx = 1
+    end if
+    allocate (temp)
+    temp%value = arg
+    temp%index = idx
+    call move_alloc(top,temp%next)
+    call move_alloc(temp,top)
+  end subroutine
+  subroutine pop
+    call move_alloc(top%next,temp)
+    call move_alloc(temp,top)
+  end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08
new file mode 100644
index 0000000..75fd8b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08
@@ -0,0 +1,46 @@
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+! Here the recursive components are arrays, unlike the first three testcases.
+! Notice that array components are fiendishly difficult to use :-(
+!
+module m
+  type :: recurses
+    type(recurses), allocatable :: c(:)
+    integer, allocatable :: ia
+  end type
+end module
+
+  use m
+  type(recurses), allocatable, target :: a, d(:)
+  type(recurses), pointer :: b1
+
+  integer :: total = 0
+
+! Check chained allocation.
+  allocate(a)
+  a%ia = 1
+  allocate (a%c(2))
+  b1 => a%c(1)
+  b1%ia = 2
+
+! Check move_alloc.
+  allocate (d(2))
+  d(1)%ia = 3
+  d(2)%ia = 4
+  b1 => d(2)
+  allocate (b1%c(1))
+  b1  => b1%c(1)
+  b1%ia = 5
+  call move_alloc (d, a%c(2)%c)
+
+  if (a%ia .ne. 1) call abort
+  if (a%c(1)%ia .ne. 2) call abort
+  if (a%c(2)%c(1)%ia .ne. 3) call abort
+  if (a%c(2)%c(2)%ia .ne. 4) call abort
+  if (a%c(2)%c(2)%c(1)%ia .ne. 5) call abort
+
+  if (allocated (a)) deallocate (a)
+  if (allocated (d)) deallocate (d)
+
+end