Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 195244)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 7941,7946 ****
--- 7941,7947 ----
    tree lbound;
    tree ubound;
    tree desc;
+   tree old_desc;
    tree desc2;
    tree offset;
    tree jump_label1;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8091,8096 ****
--- 8092,8104 ----
  			  size1, size2);
    neq_size = gfc_evaluate_now (cond, &fblock);
  
+   /* Deallocation of allocatable components will have to occur on
+      reallocation.  Fix the old descriptor now.  */
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     old_desc = gfc_evaluate_now (desc, &fblock);
+   else
+     old_desc = NULL_TREE;
  
    /* Now modify the lhs descriptor and the associated scalarizer
       variables. F2003 7.4.1.3: "If variable is or becomes an
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8201,8212 ****
--- 8209,8238 ----
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>]. */
    gfc_init_block (&realloc_block);
+ 
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
+ 				       expr1->rank);
+       gfc_add_expr_to_block (&realloc_block, tmp);
+     }
+ 
    tmp = build_call_expr_loc (input_location,
  			     builtin_decl_explicit (BUILT_IN_REALLOC), 2,
  			     fold_convert (pvoid_type_node, array1),
  			     size2);
    gfc_conv_descriptor_data_set (&realloc_block,
  				desc, tmp);
+ 
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ 				    expr1->rank);
+       gfc_add_expr_to_block (&realloc_block, tmp);
+     }
+ 
    realloc_expr = gfc_finish_block (&realloc_block);
  
    /* Only reallocate if sizes are different.  */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8224,8229 ****
--- 8250,8262 ----
  				desc, tmp);
    tmp = gfc_conv_descriptor_dtype (desc);
    gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ 				    expr1->rank);
+       gfc_add_expr_to_block (&alloc_block, tmp);
+     }
    alloc_expr = gfc_finish_block (&alloc_block);
  
    /* Malloc if not allocated; realloc otherwise.  */
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90	(working copy)
***************
*** 0 ****
--- 1,28 ----
+ ! { dg-do run }
+ ! Test the fix for PR56008
+ !
+ ! Contributed by Stefan Mauerberger  <stefan.mauerberger@gmail.com>
+ !
+ PROGRAM main
+     !USE MPI
+ 
+     TYPE :: test_typ
+         REAL, ALLOCATABLE :: a(:)
+     END TYPE
+ 
+     TYPE(test_typ) :: xx, yy
+     TYPE(test_typ), ALLOCATABLE :: conc(:)
+ 
+     !CALL MPI_INIT(i)
+ 
+     xx = test_typ( [1.0,2.0] )
+     yy = test_typ( [4.0,4.9] )
+ 
+     conc = [ xx, yy ]
+ 
+     if (any (int (10.0*conc(1)%a) .ne. [10,20])) call abort
+     if (any (int (10.0*conc(2)%a) .ne. [40,49])) call abort
+ 
+     !CALL MPI_FINALIZE(i)
+ 
+ END PROGRAM main
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90	(working copy)
***************
*** 0 ****
--- 1,47 ----
+ ! { dg-do run }
+ ! Test the fix for PR47517
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ ! from a testcase by James Van Buskirk
+ module mytypes
+    implicit none
+    type label
+       integer, allocatable :: parts(:)
+    end type label
+    type table
+       type(label), allocatable :: headers(:)
+    end type table
+ end module mytypes
+ 
+ program allocate_assign
+    use mytypes
+    implicit none
+    integer, parameter :: ik8 = selected_int_kind(18)
+    type(table) x1(2)
+    type(table) x2(3)
+    type(table), allocatable :: x(:)
+    integer i, j, k
+    integer(ik8) s
+    call foo
+    s = 0
+    do k = 1, 10000
+       x = x1
+       s = s+x(2)%headers(2)%parts(2)
+       x = x2
+       s = s+x(2)%headers(2)%parts(2)
+    end do
+    if (s .ne. 40000) call abort
+ contains
+ !
+ ! TODO - these assignments lose 1872 bytes on x86_64/FC17
+ ! This is PR38319
+ !
+    subroutine foo
+        x1 = [table([(label([(j,j=1,3)]),i=1,3)]), &
+              table([(label([(j,j=1,4)]),i=1,4)])]
+ 
+        x2 = [table([(label([(j,j=1,4)]),i=1,4)]), &
+              table([(label([(j,j=1,5)]),i=1,5)]), &
+              table([(label([(j,j=1,6)]),i=1,6)])]
+    end subroutine
+ end program allocate_assign
