[PATCH 1/5] 2015-01-25 Paul Thomas <pault at gcc dot gnu dot org>

[tbsaunde+gcc at tbsaunde dot org]

From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>

	PR fortran/67171
	* trans-array.c (structure_alloc_comps): On deallocation of
	class components, reset the vptr to the declared type vtable
	and reset the _len field of unlimited polymorphic components.
	*trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on
	allocatable component references to the right of part reference
	with non-zero rank and return NULL.
	(gfc_reset_vptr): Simplify this function by using the function
	gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE.
	(gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns
	NULL return.
	* trans-stmt.c (gfc_trans_allocate): Rely on the use of
	gfc_trans_assignment if expr3 is a variable expression since
	this deals correctly with array sections.

2015-01-25  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/67171
	* gfortran.dg/allocate_with_source_12.f03: New test

	PR fortran/61819
	* gfortran.dg/allocate_with_source_13.f03: New test

	PR fortran/61830
	* gfortran.dg/allocate_with_source_14.f03: New test


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@229303 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/ChangeLog                              |  21 +-
 gcc/fortran/trans-array.c                          |  32 +++
 gcc/fortran/trans-expr.c                           |  70 ++++---
 gcc/fortran/trans-stmt.c                           |   9 +-
 gcc/testsuite/ChangeLog                            |  11 ++
 .../gfortran.dg/allocate_with_source_12.f03        |  38 ++++
 .../gfortran.dg/allocate_with_source_13.f03        | 220 +++++++++++++++++++++
 .../gfortran.dg/allocate_with_source_14.f03        | 214 ++++++++++++++++++++
 8 files changed, 579 insertions(+), 36 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_12.f03
 create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_13.f03
 create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_14.f03

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1a351be..668013d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,8 +1,25 @@
+2015-01-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/67171
+	* trans-array.c (structure_alloc_comps): On deallocation of
+	class components, reset the vptr to the declared type vtable
+	and reset the _len field of unlimited polymorphic components.
+	*trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on
+	allocatable component references to the right of part reference
+	with non-zero rank and return NULL.
+	(gfc_reset_vptr): Simplify this function by using the function
+	gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE.
+	(gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns
+	NULL return.
+	* trans-stmt.c (gfc_trans_allocate): Rely on the use of
+	gfc_trans_assignment if expr3 is a variable expression since
+	this deals correctly with array sections.
+
 2015-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>
 
 	PR fortran/66927
-	PR fortran/67044	
-	* trans-array.c (build_array_ref): Modified call to 
+	PR fortran/67044
+	* trans-array.c (build_array_ref): Modified call to
 	gfc_get_class_array_ref to adhere to new interface.
 	(gfc_conv_expr_descriptor): For one-based arrays that
 	are filled by a loop starting at one the start index of the
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 45c18a5..b726998 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8024,6 +8024,38 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					 build_int_cst (TREE_TYPE (comp), 0));
 		}
 	      gfc_add_expr_to_block (&tmpblock, tmp);
+
+	      /* Finally, reset the vptr to the declared type vtable and, if
+		 necessary reset the _len field.
+
+		 First recover the reference to the component and obtain
+		 the vptr.  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				     decl, cdecl, NULL_TREE);
+	      tmp = gfc_class_vptr_get (comp);
+
+	      if (UNLIMITED_POLY (c))
+		{
+		  /* Both vptr and _len field should be nulled.  */
+		  gfc_add_modify (&tmpblock, tmp,
+				  build_int_cst (TREE_TYPE (tmp), 0));
+		  tmp = gfc_class_len_get (comp);
+		  gfc_add_modify (&tmpblock, tmp,
+				  build_int_cst (TREE_TYPE (tmp), 0));
+		}
+	      else
+		{
+		  /* Build the vtable address and set the vptr with it.  */
+		  tree vtab;
+		  gfc_symbol *vtable;
+		  vtable = gfc_find_derived_vtab (c->ts.u.derived);
+		  vtab = vtable->backend_decl;
+		  if (vtab == NULL_TREE)
+		    vtab = gfc_get_symbol_decl (vtable);
+		  vtab = gfc_build_addr_expr (NULL, vtab);
+		  vtab = fold_convert (TREE_TYPE (tmp), vtab);
+		  gfc_add_modify (&tmpblock, tmp, vtab);
+		}
 	    }
 
 	  if (cmp_has_alloc_comps
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9585de6..f8ed0df 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -271,15 +271,29 @@ gfc_expr *
 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
 {
   gfc_expr *base_expr;
-  gfc_ref *ref, *class_ref, *tail;
+  gfc_ref *ref, *class_ref, *tail, *array_ref;
 
   /* Find the last class reference.  */
   class_ref = NULL;
+  array_ref = NULL;
   for (ref = e->ref; ref; ref = ref->next)
     {
+      if (ref->type == REF_ARRAY
+	  && ref->u.ar.type != AR_ELEMENT)
+	array_ref = ref;
+
       if (ref->type == REF_COMPONENT
 	  && ref->u.c.component->ts.type == BT_CLASS)
+	{
+	  /* Component to the right of a part reference with nonzero rank
+	     must not have the ALLOCATABLE attribute.  If attempts are
+	     made to reference such a component reference, an error results
+	     followed by anICE.  */
+	  if (array_ref
+	      && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+	    return NULL;
 	class_ref = ref;
+	}
 
       if (ref->next == NULL)
 	break;
@@ -320,47 +334,37 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
 void
 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
 {
-  gfc_expr *rhs, *lhs = gfc_copy_expr (e);
   gfc_symbol *vtab;
-  tree tmp;
-  gfc_ref *ref;
+  tree vptr;
+  tree vtable;
+  gfc_se se;
 
-  /* If we have a class array, we need go back to the class
-     container.  */
-  if (lhs->ref && lhs->ref->next && !lhs->ref->next->next
-      && lhs->ref->next->type == REF_ARRAY
-      && lhs->ref->next->u.ar.type == AR_FULL
-      && lhs->ref->type == REF_COMPONENT
-      && strcmp (lhs->ref->u.c.component->name, "_data") == 0)
-    {
-      gfc_free_ref_list (lhs->ref);
-      lhs->ref = NULL;
-    }
+  /* Evaluate the expression and obtain the vptr from it.  */
+  gfc_init_se (&se, NULL);
+  if (e->rank)
+    gfc_conv_expr_descriptor (&se, e);
   else
-    for (ref = lhs->ref; ref; ref = ref->next)
-      if (ref->next && ref->next->next && !ref->next->next->next
-	  && ref->next->next->type == REF_ARRAY
-	  && ref->next->next->u.ar.type == AR_FULL
-	  && ref->next->type == REF_COMPONENT
-	  && strcmp (ref->next->u.c.component->name, "_data") == 0)
-	{
-	  gfc_free_ref_list (ref->next);
-	  ref->next = NULL;
-	}
+    gfc_conv_expr (&se, e);
+  gfc_add_block_to_block (block, &se.pre);
+  vptr = gfc_get_vptr_from_expr (se.expr);
 
-  gfc_add_vptr_component (lhs);
+  /* If a vptr is not found, we can do nothing more.  */
+  if (vptr == NULL_TREE)
+    return;
 
   if (UNLIMITED_POLY (e))
-    rhs = gfc_get_null_expr (NULL);
+    gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
   else
     {
+      /* Return the vptr to the address of the declared type.  */
       vtab = gfc_find_derived_vtab (e->ts.u.derived);
-      rhs = gfc_lval_expr_from_sym (vtab);
+      vtable = vtab->backend_decl;
+      if (vtable == NULL_TREE)
+	vtable = gfc_get_symbol_decl (vtab);
+      vtable = gfc_build_addr_expr (NULL, vtable);
+      vtable = fold_convert (TREE_TYPE (vptr), vtable);
+      gfc_add_modify (block, vptr, vtable);
     }
-  tmp = gfc_trans_pointer_assignment (lhs, rhs);
-  gfc_add_expr_to_block (block, tmp);
-  gfc_free_expr (lhs);
-  gfc_free_expr (rhs);
 }
 
 
@@ -372,6 +376,8 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
   gfc_expr *e;
   gfc_se se_len;
   e = gfc_find_and_cut_at_last_class_ref (expr);
+  if (e == NULL)
+    return;
   gfc_add_len_component (e);
   gfc_init_se (&se_len, NULL);
   gfc_conv_expr (&se_len, e);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1bd131e..85558f0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5379,8 +5379,13 @@ gfc_trans_allocate (gfc_code * code)
 	     will benefit of every enhancements gfc_trans_assignment ()
 	     gets.
 	     No need to check whether e3_is is E3_UNSET, because that is
-	     done by expr3 != NULL_TREE.  */
-	  if (e3_is != E3_MOLD && expr3 != NULL_TREE
+	     done by expr3 != NULL_TREE.
+	     Exclude variables since the following block does not handle
+	     array sections. In any case, there is no harm in sending
+	     variables to gfc_trans_assignment because there is no
+	     evaluation of variables.  */
+	  if (code->expr3->expr_type != EXPR_VARIABLE
+	      && e3_is != E3_MOLD && expr3 != NULL_TREE
 	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
 	    {
 	      /* Build a temporary symtree and symbol.  Do not add it to
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8024273..8ecfd09 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2015-01-25  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/67171
+	* gfortran.dg/allocate_with_source_12.f03: New test
+
+	PR fortran/61819
+	* gfortran.dg/allocate_with_source_13.f03: New test
+
+	PR fortran/61830
+	* gfortran.dg/allocate_with_source_14.f03: New test
+
 2015-10-25  John David Anglin  <danglin@gcc.gnu.org>
 
 	* g++.dg/Wno-frame-address.C: Skip on hppa*-*-*.
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03
new file mode 100644
index 0000000..76deb61
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03
@@ -0,0 +1,38 @@
+! { dg-do run }
+!
+! Checks the fix for PR67171, where the second ALLOCATE with and array section
+! SOURCE produced a zero index based temporary, which threw the assignment.
+!
+! Contributed by Anton Shterenlikht  <mexas@bristol.ac.uk>
+!
+program z
+  implicit none
+  integer, parameter :: DIM1_SIZE = 10
+  real, allocatable :: d(:,:), tmp(:,:)
+  integer :: i, errstat
+
+  allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat )
+
+  d(:,1) = [( real (i), i=1,DIM1_SIZE)]
+  d(:,2) = [( real(2*i), i=1,DIM1_SIZE)]
+!  write (*,*) d(1, :)
+
+  call move_alloc (from = d, to = tmp)
+!  write (*,*) tmp( 1, :)
+
+  allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat)
+  if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) call abort
+  deallocate (d)
+
+  allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat)
+  if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) call abort
+
+  deallocate (tmp , d)
+
+contains
+  function foo (arg) result (res)
+    real :: arg(:,:)
+    real :: res(size (arg, 1), size (arg, 2))
+    res = arg
+  end function
+end program z
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03
new file mode 100644
index 0000000..27b5c17
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03
@@ -0,0 +1,220 @@
+! { dg-do compile }
+!
+! Tests the fix for PR61819.
+!
+! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
+!
+module foo_base_mod
+  integer, parameter :: foo_ipk_ = kind(1)
+  integer, parameter :: foo_dpk_ = kind(1.d0)
+  type foo_d_base_vect_type
+    real(foo_dpk_), allocatable :: v(:)
+  contains
+    procedure :: free     => d_base_free
+    procedure :: get_vect => d_base_get_vect
+    procedure :: allocate => d_base_allocate
+  end type foo_d_base_vect_type
+
+
+  type foo_d_vect_type
+    class(foo_d_base_vect_type), allocatable :: v
+  contains
+    procedure :: free     => d_vect_free
+    procedure :: get_vect => d_vect_get_vect
+  end type foo_d_vect_type
+
+  type foo_desc_type
+    integer(foo_ipk_) :: nl=-1
+  end type foo_desc_type
+
+
+contains
+
+  subroutine foo_init(ictxt)
+    integer :: ictxt
+  end subroutine foo_init
+
+
+  subroutine foo_exit(ictxt)
+    integer :: ictxt
+  end subroutine foo_exit
+
+  subroutine foo_info(ictxt,iam,np)
+    integer(foo_ipk_) :: ictxt,iam,np
+    iam = 0
+    np = 1
+  end subroutine foo_info
+
+  subroutine  foo_cdall(ictxt,map,info,nl)
+    integer(foo_ipk_) :: ictxt, info
+    type(foo_desc_type) :: map
+    integer(foo_ipk_), optional  :: nl
+
+    if (present(nl)) then
+      map%nl = nl
+    else
+      map%nl = 1
+    end if
+  end subroutine foo_cdall
+
+  subroutine  foo_cdasb(map,info)
+    integer(foo_ipk_) :: info
+    type(foo_desc_type) :: map
+    if (map%nl < 0) map%nl=1
+  end subroutine foo_cdasb
+
+
+  subroutine d_base_allocate(this,n)
+    class(foo_d_base_vect_type), intent(out) :: this
+
+    allocate(this%v(max(1,n)))
+
+  end subroutine d_base_allocate
+
+  subroutine d_base_free(this)
+    class(foo_d_base_vect_type), intent(inout) :: this
+    if (allocated(this%v)) &
+         & deallocate(this%v)
+  end subroutine d_base_free
+
+  function d_base_get_vect(this) result(res)
+    class(foo_d_base_vect_type), intent(inout) :: this
+    real(foo_dpk_), allocatable :: res(:)
+
+    if (allocated(this%v)) then
+      res = this%v
+    else
+      allocate(res(1))
+    end if
+  end function d_base_get_vect
+
+  subroutine d_vect_free(this)
+    class(foo_d_vect_type) :: this
+    if (allocated(this%v)) then
+      call this%v%free()
+      deallocate(this%v)
+    end if
+  end subroutine d_vect_free
+
+  function d_vect_get_vect(this) result(res)
+    class(foo_d_vect_type) :: this
+    real(foo_dpk_), allocatable :: res(:)
+
+    if (allocated(this%v)) then
+      res = this%v%get_vect()
+    else
+      allocate(res(1))
+    end if
+  end function d_vect_get_vect
+
+  subroutine foo_geall(v,map,info)
+    type(foo_d_vect_type), intent(out) :: v
+    type(foo_Desc_type) :: map
+    integer(foo_ipk_) :: info
+
+    allocate(foo_d_base_vect_type :: v%v,stat=info)
+    if (info == 0) call v%v%allocate(map%nl)
+  end subroutine foo_geall
+
+end module foo_base_mod
+
+
+module foo_scalar_field_mod
+  use foo_base_mod
+  implicit none
+
+  type scalar_field
+    type(foo_d_vect_type)        :: f
+    type(foo_desc_type), pointer :: map => null()
+  contains
+    procedure :: free
+  end type
+
+  integer(foo_ipk_), parameter :: nx=4,ny=nx, nz=nx
+  type(foo_desc_type), allocatable, save, target :: map
+  integer(foo_ipk_) ,save :: NumMy_xy_planes
+  integer(foo_ipk_) ,parameter :: NumGlobalElements = nx*ny*nz
+  integer(foo_ipk_) ,parameter :: NumGlobal_xy_planes = nz, Num_xy_points_per_plane = nx*ny
+
+contains
+  subroutine initialize_map(ictxt,NumMyElements,info)
+    integer(foo_ipk_) :: ictxt, NumMyElements, info
+    info = 0
+    if (allocated(map)) deallocate(map,stat=info)
+    if (info == 0) allocate(map,stat=info)
+    if (info == 0) call foo_cdall(ictxt,map,info,nl=NumMyElements)
+    if (info == 0) call foo_cdasb(map,info)
+  end subroutine initialize_map
+
+  function new_scalar_field(comm) result(this)
+    type(scalar_field)                          :: this
+    integer(foo_ipk_)              ,intent(in) :: comm
+    real(foo_dpk_) ,allocatable   :: f_v(:)
+    integer(foo_ipk_) :: i,j,k,NumMyElements, iam, np, info,ip
+    integer(foo_ipk_), allocatable :: idxs(:)
+    call foo_info(comm,iam,np)
+    NumMy_xy_planes = NumGlobal_xy_planes/np
+    NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane
+    if (.not. allocated(map)) call initialize_map(comm,NumMyElements,info)
+    this%map => map
+    call foo_geall(this%f,this%map,info)
+  end function
+
+  subroutine free(this)
+    class(scalar_field), intent(inout) :: this
+    integer(foo_ipk_) ::info
+    write(0,*) 'Freeing scalar_this%f'
+    call this%f%free()
+  end subroutine free
+
+end module foo_scalar_field_mod
+
+module foo_vector_field_mod
+  use foo_base_mod
+  use foo_scalar_field_mod, only : scalar_field,new_scalar_field
+  implicit none
+  type vector_field
+    type(scalar_field) :: u(1)
+  contains
+    procedure :: free
+  end type
+contains
+  function new_vector_field(comm_in) result(this)
+    type(vector_field) :: this
+    integer(foo_ipk_), intent(in) :: comm_in
+    this%u = [new_scalar_field(comm_in)] ! Removing this line eliminates the memory leak
+  end function
+
+  subroutine free(this)
+    class(vector_field), intent(inout) :: this
+    integer :: i
+    associate(vf=>this%u)
+      do i=1, size(vf)
+        write(0,*) 'Freeing vector_this%u(',i,')'
+        call vf(i)%free()
+      end do
+    end associate
+  end subroutine free
+
+end module foo_vector_field_mod
+
+program main
+  use foo_base_mod
+  use foo_vector_field_mod,only: vector_field,new_vector_field
+  use foo_scalar_field_mod,only: map
+  implicit none
+  type(vector_field) :: u
+  type(foo_d_vect_type) :: v
+  real(foo_dpk_), allocatable :: av(:)
+  integer(foo_ipk_) :: ictxt, iam, np, i,info
+  call foo_init(ictxt)
+  call foo_info(ictxt,iam,np)
+  u = new_vector_field(ictxt)
+  call u%free()
+  do i=1,10
+    u = new_vector_field(ictxt)
+    call u%free()
+  end do
+  call u%free()
+  call foo_exit(ictxt)
+end program
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
new file mode 100644
index 0000000..36c1245
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
@@ -0,0 +1,214 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Tests the fix for PR61830.
+!
+! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
+!
+module foo_base_mod
+  integer, parameter :: foo_dpk_ = kind(1.d0)
+  type foo_d_base_vect_type
+    real(foo_dpk_), allocatable :: v(:)
+  contains
+    procedure :: free     => d_base_free
+    procedure :: get_vect => d_base_get_vect
+    procedure :: allocate => d_base_allocate
+  end type foo_d_base_vect_type
+
+
+  type foo_d_vect_type
+    class(foo_d_base_vect_type), allocatable :: v
+  contains
+    procedure :: free     => d_vect_free
+    procedure :: get_vect => d_vect_get_vect
+  end type foo_d_vect_type
+
+  type foo_desc_type
+    integer :: nl=-1
+  end type foo_desc_type
+
+contains
+
+  subroutine  foo_cdall(map,nl)
+    type(foo_desc_type) :: map
+    integer, optional  :: nl
+
+    if (present(nl)) then
+      map%nl = nl
+    else
+      map%nl = 1
+    end if
+  end subroutine foo_cdall
+
+
+  subroutine  foo_cdasb(map,info)
+    integer :: info
+    type(foo_desc_type) :: map
+    if (map%nl < 0) map%nl=1
+  end subroutine foo_cdasb
+
+
+
+  subroutine d_base_allocate(this,n)
+    class(foo_d_base_vect_type), intent(out) :: this
+
+    allocate(this%v(max(1,n)))
+
+  end subroutine d_base_allocate
+
+  subroutine d_base_free(this)
+    class(foo_d_base_vect_type), intent(inout) :: this
+    if (allocated(this%v))  then
+      write(0,*) 'Scalar deallocation'
+      deallocate(this%v)
+    end if
+  end subroutine d_base_free
+
+  function d_base_get_vect(this) result(res)
+    class(foo_d_base_vect_type), intent(inout) :: this
+    real(foo_dpk_), allocatable :: res(:)
+
+    if (allocated(this%v)) then
+      res = this%v
+    else
+      allocate(res(1))
+    end if
+  end function d_base_get_vect
+
+  subroutine d_vect_free(this)
+    class(foo_d_vect_type) :: this
+    if (allocated(this%v)) then
+      call this%v%free()
+      write(0,*) 'Deallocate class() component'
+      deallocate(this%v)
+    end if
+  end subroutine d_vect_free
+
+  function d_vect_get_vect(this) result(res)
+    class(foo_d_vect_type) :: this
+    real(foo_dpk_), allocatable :: res(:)
+
+    if (allocated(this%v)) then
+      res = this%v%get_vect()
+    else
+      allocate(res(1))
+    end if
+  end function d_vect_get_vect
+
+  subroutine foo_geall(v,map,info)
+    type(foo_d_vect_type), intent(out) :: v
+    type(foo_Desc_type) :: map
+    integer :: info
+
+    allocate(foo_d_base_vect_type :: v%v,stat=info)
+    if (info == 0) call v%v%allocate(map%nl)
+  end subroutine foo_geall
+
+end module foo_base_mod
+
+
+module foo_scalar_field_mod
+  use foo_base_mod
+  implicit none
+
+  type scalar_field
+    type(foo_d_vect_type)        :: f
+    type(foo_desc_type), pointer :: map => null()
+  contains
+    procedure :: free
+  end type
+
+  integer, parameter :: nx=4,ny=nx, nz=nx
+  type(foo_desc_type), allocatable, save, target :: map
+  integer ,save :: NumMy_xy_planes
+  integer ,parameter :: NumGlobalElements = nx*ny*nz
+  integer ,parameter :: NumGlobal_xy_planes = nz, &
+       & Num_xy_points_per_plane = nx*ny
+
+contains
+  subroutine initialize_map(NumMyElements)
+    integer :: NumMyElements, info
+    info = 0
+    if (allocated(map)) deallocate(map,stat=info)
+    if (info == 0) allocate(map,stat=info)
+    if (info == 0) call foo_cdall(map,nl=NumMyElements)
+    if (info == 0) call foo_cdasb(map,info)
+  end subroutine initialize_map
+
+  function new_scalar_field() result(this)
+    type(scalar_field)                          :: this
+    real(foo_dpk_) ,allocatable   :: f_v(:)
+    integer :: i,j,k,NumMyElements, iam, np, info,ip
+    integer, allocatable :: idxs(:)
+
+    NumMy_xy_planes = NumGlobal_xy_planes
+    NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane
+    if (.not. allocated(map)) call initialize_map(NumMyElements)
+    this%map => map
+    call foo_geall(this%f,this%map,info)
+  end function
+
+  subroutine free(this)
+    class(scalar_field), intent(inout) :: this
+    integer ::info
+    call this%f%free()
+  end subroutine free
+
+end module foo_scalar_field_mod
+
+module foo_vector_field_mod
+  use foo_base_mod
+  use foo_scalar_field_mod
+  implicit none
+  type vector_field
+    type(scalar_field) :: u(1)
+  end type vector_field
+contains
+  function new_vector_field() result(this)
+    type(vector_field) :: this
+    integer :: i
+    do i=1, size(this%u)
+      associate(sf=>this%u(i))
+        sf = new_scalar_field()
+      end associate
+    end do
+  end function
+
+  subroutine free_v_field(this)
+    class(vector_field), intent(inout) :: this
+    integer :: i
+    associate(vf=>this%u)
+      do i=1, size(vf)
+        call vf(i)%free()
+      end do
+    end associate
+  end subroutine free_v_field
+
+end module foo_vector_field_mod
+
+program main
+  use foo_base_mod
+  use foo_vector_field_mod
+  use foo_scalar_field_mod
+  implicit none
+  type(vector_field) :: u
+  type(foo_d_vect_type) :: v
+  real(foo_dpk_), allocatable :: av(:)
+  integer  :: iam, np, i,info
+
+  u = new_vector_field()
+  call foo_geall(v,map,info)
+  call free_v_field(u)
+  do i=1,10
+    u = new_vector_field()
+    call free_v_field(u)
+    av = v%get_vect()
+  end do
+! This gets rid of the "memory leak"
+  if (associated (u%u(1)%map)) deallocate (u%u(1)%map)
+  call free_v_field(u)
+  call v%free()
+  deallocate(av)
+end program
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }
-- 
2.6.2