re PR fortran/43366 ([OOP][F08] Intrinsic assign to polymorphic variable)

gcc/fortran/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/51864
	PR fortran/57117
	PR fortran/61337
	PR fortran/61376
	* primary.c (gfc_expr_attr): For transformational functions on classes
	get the attrs from the class argument.
	* resolve.c (resolve_ordinary_assign): Remove error message due to
	feature implementation.  Rewrite POINTER_ASSIGNS to ordinary ones when
	the right-hand side is scalar class object (with some restrictions).
	* trans-array.c (trans_array_constructor): Create the temporary from
	class' inner type, i.e., the derived type.
	(build_class_array_ref): Add support for class array's storage of the
	class object or the array descriptor in the decl saved descriptor.
	(gfc_conv_expr_descriptor): When creating temporaries for class objects
	add the class object's handle into the decl saved descriptor.
	(structure_alloc_comps): Use the common way to get the _data component.
	(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
	only when the expression's type is BT_CLASS.
	(gfc_trans_class_init_assign): Correctly handle class arrays.
	(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
	(gfc_conv_procedure_call): Support for class types as arguments.
	(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
	component's tree.
	(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
	and _len components of a class object correctly.
	(pointer_assignment_is_proc_pointer): Identify assignments of
	procedure pointers.
	(gfc_trans_pointer_assignment): Enhance support for class object pointer
	assignments.
	(gfc_trans_scalar_assign): Removed assert.
	(trans_class_assignment): Assign to a class object.
	(gfc_trans_assignment_1): Treat class objects correctly.
	(gfc_trans_assignment): Propagate flags to trans_assignment_1.
	* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
	instead of copy_class_to_class.
	* trans-stmt.h: Function prototype removed.
	* trans.c (trans_code): Less special casing for class objects.
	* trans.h: Added flags to gfc_trans_assignment () prototype.

gcc/testsuite/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

        Forgot to add on original commit.
        * gfortran.dg/coarray_alloc_comp_2.f08: New test.

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/57117
	PR fortran/61337
	* gfortran.dg/alloc_comp_class_5.f03: New test.
	* gfortran.dg/class_allocate_21.f90: New test.
	* gfortran.dg/class_allocate_22.f90: New test.
	* gfortran.dg/realloc_on_assign_27.f08: New test.

From-SVN: r241439

gcc/fortran/ChangeLog

+2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/43366
+	PR fortran/51864
+	PR fortran/57117
+	PR fortran/61337
+	PR fortran/61376
+	* primary.c (gfc_expr_attr): For transformational functions on classes
+	get the attrs from the class argument.
+	* resolve.c (resolve_ordinary_assign): Remove error message due to
+	feature implementation.  Rewrite POINTER_ASSIGNS to ordinary ones when
+	the right-hand side is scalar class object (with some restrictions).
+	* trans-array.c (trans_array_constructor): Create the temporary from
+	class' inner type, i.e., the derived type.
+	(build_class_array_ref): Add support for class array's storage of the
+	class object or the array descriptor in the decl saved descriptor.
+	(gfc_conv_expr_descriptor): When creating temporaries for class objects
+	add the class object's handle into the decl saved descriptor.
+	(structure_alloc_comps): Use the common way to get the _data component.
+	(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
+	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
+	only when the expression's type is BT_CLASS.
+	(gfc_trans_class_init_assign): Correctly handle class arrays.
+	(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
+	(gfc_conv_procedure_call): Support for class types as arguments.
+	(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
+	component's tree.
+	(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
+	and _len components of a class object correctly.
+	(pointer_assignment_is_proc_pointer): Identify assignments of
+	procedure pointers.
+	(gfc_trans_pointer_assignment): Enhance support for class object pointer
+	assignments.
+	(gfc_trans_scalar_assign): Removed assert.
+	(trans_class_assignment): Assign to a class object.
+	(gfc_trans_assignment_1): Treat class objects correctly.
+	(gfc_trans_assignment): Propagate flags to trans_assignment_1.
+	* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
+	instead of copy_class_to_class.
+	* trans-stmt.h: Function prototype removed.
+	* trans.c (trans_code): Less special casing for class objects.
+	* trans.h: Added flags to gfc_trans_assignment () prototype.
+
 2016-10-21  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/69566

gcc/fortran/primary.c

@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
 	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
 	    }
 	}
+      else if (e->value.function.isym
+	       && e->value.function.isym->transformational
+	       && e->ts.type == BT_CLASS)
+	attr = CLASS_DATA (e)->attr;
       else
 	attr = gfc_variable_attr (e, NULL);
 

gcc/fortran/resolve.c

@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 		     "requires %<-frealloc-lhs%>", &lhs->where);
 	  return false;
 	}
-      /* See PR 43366.  */
-      gfc_error ("Assignment to an allocatable polymorphic variable at %L "
-		 "is not yet supported", &lhs->where);
-      return false;
     }
   else if (lhs->ts.type == BT_CLASS)
     {
@@ -10817,6 +10813,19 @@ start:
 	      break;
 
 	    gfc_check_pointer_assign (code->expr1, code->expr2);
+
+	    /* Assigning a class object always is a regular assign.  */
+	    if (code->expr2->ts.type == BT_CLASS
+		&& !CLASS_DATA (code->expr2)->attr.dimension
+		&& !(UNLIMITED_POLY (code->expr2)
+		     && code->expr1->ts.type == BT_DERIVED
+		     && (code->expr1->ts.u.derived->attr.sequence
+			 || code->expr1->ts.u.derived->attr.is_bind_c))
+		&& !(gfc_expr_attr (code->expr1).proc_pointer
+		     && code->expr2->expr_type == EXPR_VARIABLE
+		     && code->expr2->symtree->n.sym->attr.flavor
+			== FL_PROCEDURE))
+	      code->op = EXEC_ASSIGN;
 	    break;
 	  }
 

gcc/fortran/trans-array.c

@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
 	type = build_pointer_type (type);
     }
   else
-    type = gfc_typenode_for_spec (&expr->ts);
+    type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+				  ? &CLASS_DATA (expr)->ts : &expr->ts);
 
   /* See if the constructor determines the loop bounds.  */
   dynamic = false;
@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
   tree type;
   tree size;
   tree offset;
-  tree decl;
+  tree decl = NULL_TREE;
   tree tmp;
   gfc_expr *expr = se->ss->info->expr;
   gfc_ref *ref;
-  gfc_ref *class_ref;
+  gfc_ref *class_ref = NULL;
   gfc_typespec *ts;
 
-  if (expr == NULL
-      || (expr->ts.type != BT_CLASS
-	  && !gfc_is_alloc_class_array_function (expr)))
-    return false;
-
-  if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
-    ts = &expr->symtree->n.sym->ts;
+  if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
+      && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
+      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
+    decl = se->expr;
   else
-    ts = NULL;
-  class_ref = NULL;
-
-  for (ref = expr->ref; ref; ref = ref->next)
     {
-      if (ref->type == REF_COMPONENT
-	    && ref->u.c.component->ts.type == BT_CLASS
-	    && ref->next && ref->next->type == REF_COMPONENT
-	    && strcmp (ref->next->u.c.component->name, "_data") == 0
-	    && ref->next->next
-	    && ref->next->next->type == REF_ARRAY
-	    && ref->next->next->u.ar.type != AR_ELEMENT)
+      if (expr == NULL
+	  || (expr->ts.type != BT_CLASS
+	      && !gfc_is_alloc_class_array_function (expr)
+	      && !gfc_is_class_array_ref (expr, NULL)))
+	return false;
+
+      if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+	ts = &expr->symtree->n.sym->ts;
+      else
+	ts = NULL;
+
+      for (ref = expr->ref; ref; ref = ref->next)
 	{
-	  ts = &ref->u.c.component->ts;
-	  class_ref = ref;
-	  break;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS
+	      && ref->next && ref->next->type == REF_COMPONENT
+	      && strcmp (ref->next->u.c.component->name, "_data") == 0
+	      && ref->next->next
+	      && ref->next->next->type == REF_ARRAY
+	      && ref->next->next->u.ar.type != AR_ELEMENT)
+	    {
+	      ts = &ref->u.c.component->ts;
+	      class_ref = ref;
+	      break;
+	    }
 	}
-    }
 
-  if (ts == NULL)
-    return false;
+      if (ts == NULL)
+	return false;
+    }
 
-  if (class_ref == NULL && expr->symtree->n.sym->attr.function
+  if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
       && expr->symtree->n.sym == expr->symtree->n.sym->result)
     {
       gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
       decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
     }
-  else if (gfc_is_alloc_class_array_function (expr))
+  else if (expr && gfc_is_alloc_class_array_function (expr))
     {
       size = NULL_TREE;
       decl = NULL_TREE;
@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
     }
   else if (class_ref == NULL)
     {
-      decl = expr->symtree->n.sym->backend_decl;
+      if (decl == NULL_TREE)
+	decl = expr->symtree->n.sym->backend_decl;
       /* For class arrays the tree containing the class is stored in
 	 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
 	 For all others it's sym's backend_decl directly.  */
@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
       class_ref->next = NULL;
       gfc_init_se (&tmpse, NULL);
       gfc_conv_expr (&tmpse, expr);
+      gfc_add_block_to_block (&se->pre, &tmpse.pre);
       decl = tmpse.expr;
       class_ref->next = ref;
     }
@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 						loop.from, loop.to, 0,
 						GFC_ARRAY_UNKNOWN, false);
 	  parm = gfc_create_var (parmtype, "parm");
+
+	  /* When expression is a class object, then add the class' handle to
+	     the parm_decl.  */
+	  if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+	    {
+	      gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+	      gfc_se classse;
+
+	      /* class_expr can be NULL, when no _class ref is in expr.
+		 We must not fix this here with a gfc_fix_class_ref ().  */
+	      if (class_expr)
+		{
+		  gfc_init_se (&classse, NULL);
+		  gfc_conv_expr (&classse, class_expr);
+		  gfc_free_expr (class_expr);
+
+		  gcc_assert (classse.pre.head == NULL_TREE
+			      && classse.post.head == NULL_TREE);
+		  gfc_allocate_lang_decl (parm);
+		  GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+		}
+	    }
 	}
 
       offset = gfc_index_zero_node;
@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	      : base;
 	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
 	}
+      else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
+	       && (!rank_remap || se->use_offset)
+	       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+	{
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm,
+					 gfc_conv_descriptor_offset_get (desc));
+	}
       else if (onebased && (!rank_remap || se->use_offset)
 	  && expr->symtree
 	  && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
 	  : expr->symtree->n.sym->backend_decl;
     }
+  else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
+	   && IS_CLASS_ARRAY (expr))
+    {
+      tree vtype;
+      gfc_allocate_lang_decl (desc);
+      tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
+      GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
+      vtype = gfc_class_vptr_get (tmp);
+      gfc_add_modify (&se->pre, vtype,
+		      gfc_build_addr_expr (TREE_TYPE (vtype),
+				      gfc_find_vtab (&expr->ts)->backend_decl));
+    }
   if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      /* Add reference to '_data' component.  */
-	      tmp = CLASS_DATA (c)->backend_decl;
-	      comp = fold_build3_loc (input_location, COMPONENT_REF,
-				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
+
+	      comp = gfc_class_data_get (comp);
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
 		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
 	      else
@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
   if (!expr->ref)
     return false;
 
+  /* An allocatable class variable with no reference.  */
+  if (expr->symtree->n.sym->ts.type == BT_CLASS
+      && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+      && expr->ref && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0
+      && expr->ref->next == NULL)
+    return true;
+
   /* An allocatable variable.  */
   if (expr->symtree->n.sym->attr.allocatable
 	&& expr->ref

gcc/fortran/trans-stmt.h

@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
 tree gfc_trans_init_assign (gfc_code *);
 tree gfc_trans_class_init_assign (gfc_code *);
-tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);

gcc/fortran/trans.c

@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
 	  break;
 
 	case EXEC_ASSIGN:
-	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else
-	    res = gfc_trans_assign (code);
+	  res = gfc_trans_assign (code);
 	  break;
 
         case EXEC_LABEL_ASSIGN:
@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
           break;
 
 	case EXEC_POINTER_ASSIGN:
-	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else if (UNLIMITED_POLY (code->expr2)
-		   && code->expr1->ts.type == BT_DERIVED
-		   && (code->expr1->ts.u.derived->attr.sequence
-		       || code->expr1->ts.u.derived->attr.is_bind_c))
-	    /* F2003: C717  */
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else
-	    res = gfc_trans_pointer_assign (code);
+	  res = gfc_trans_pointer_assign (code);
 	  break;
 
 	case EXEC_INIT_ASSIGN:

gcc/fortran/trans.h

@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
 tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
 
 /* Generate code for an assignment, includes scalarization.  */
-tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
+			   bool a = true);
 
 /* Generate code for a pointer assignment.  */
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);

gcc/testsuite/ChangeLog

+2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	Forgot to add on original commit.
+	* gfortran.dg/coarray_alloc_comp_2.f08: New test.
+
+2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/43366
+	PR fortran/57117
+	PR fortran/61337
+	* gfortran.dg/alloc_comp_class_5.f03: New test.
+	* gfortran.dg/class_allocate_21.f90: New test.
+	* gfortran.dg/class_allocate_22.f90: New test.
+	* gfortran.dg/realloc_on_assign_27.f08: New test.
+
 2016-10-21  Jeff Law  <law@redhat.com>
 
 	* PR tree-optimization/71947

gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03

+! { dg-do run }
+!
+! Contributed by Vladimir Fuka
+! Check that pr61337 is fixed.
+
+module array_list
+
+  type container
+    class(*), allocatable :: items(:)
+  end type
+
+contains
+
+  subroutine add_item(a, e)
+    type(container),allocatable,intent(inout) :: a(:)
+    class(*),intent(in) :: e(:)
+    type(container),allocatable :: tmp(:)
+
+      if (.not.allocated(a)) then
+        allocate(a(1))
+        allocate(a(1)%items(size(e)), source = e)
+      else
+        call move_alloc(a,tmp)
+        allocate(a(size(tmp)+1))
+        a(1:size(tmp)) = tmp
+        allocate(a(size(tmp)+1)%items(size(e)), source=e)
+      end if
+   end subroutine
+
+end module
+
+program test_pr61337
+
+  use array_list
+
+  type(container), allocatable :: a_list(:)
+  integer(kind = 8) :: i
+
+  call add_item(a_list, [1, 2])
+  call add_item(a_list, [3.0_8, 4.0_8])
+  call add_item(a_list, [.true., .false.])
+
+  if (size(a_list) /= 3) call abort()
+  do i = 1, size(a_list)
+          call checkarr(a_list(i))
+  end do
+
+  deallocate(a_list)
+
+contains
+
+  subroutine checkarr(c)
+    type(container) :: c
+
+    if (allocated(c%items)) then
+      select type (x=>c%items)
+        type is (integer)
+          if (any(x /= [1, 2])) call abort()
+        type is (real(kind=8))
+          if (any(x /= [3.0_8, 4.0_8])) call abort()
+        type is (logical)
+          if (any(x .neqv. [.true., .false.])) call abort()
+        class default
+          call abort()
+      end select
+    else
+        call abort()
+    end if
+  end subroutine
+end

gcc/testsuite/gfortran.dg/class_allocate_21.f90

+! { dg-do run }
+!
+! Testcase for pr57117
+
+implicit none
+
+  type :: ti
+    integer :: i
+  end type
+
+  class(ti), allocatable :: x(:,:), z(:)
+  integer :: i
+
+  allocate(x(3,3))
+  x%i = reshape([( i, i = 1, 9 )], [3, 3])
+  allocate(z(9), source=reshape(x, (/ 9 /)))
+
+  if (any( z%i /= [( i, i = 1, 9 )])) call abort()
+  deallocate (x, z)
+end
+

gcc/testsuite/gfortran.dg/class_allocate_22.f90

+! { dg-do run }
+!
+! Check pr57117 is fixed.
+
+program pr57117
+  implicit none
+
+  type :: ti
+    integer :: i
+  end type
+
+  class(ti), allocatable :: x(:,:), y(:,:)
+  integer :: i
+
+  allocate(x(2,6))
+  select type (x)
+    class is (ti)
+       x%i = reshape([(i,i=1, 12)],[2,6])
+  end select
+  allocate(y, source=transpose(x))
+
+  if (any( ubound(y) /= [6,2])) call abort()
+  if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
+  deallocate (x,y)
+end
+

gcc/testsuite/gfortran.dg/coarray_alloc_comp_2.f08

+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+
+! Contributed by Damian Rouson
+! Check the new _caf_send_by_ref()-routine.
+
+program main
+
+implicit none
+
+type :: mytype
+  integer :: i
+  integer, allocatable :: indices(:)
+  real, dimension(2,5,3) :: volume
+  integer, allocatable :: scalar
+  integer :: j
+  integer, allocatable :: matrix(:,:)
+  real, allocatable :: dynvol(:,:,:)
+end type
+
+type arrtype
+  type(mytype), allocatable :: vec(:)
+  type(mytype), allocatable :: mat(:,:)
+end type arrtype
+
+type(mytype), save :: object[*]
+type(arrtype), save :: bar[*]
+integer :: i,j,me,neighbor
+integer :: idx(5)
+real, allocatable :: volume(:,:,:), vol2(:,:,:)
+real :: vol_static(2,5,3)
+
+idx = (/ 1,2,1,7,5 /)
+
+me=this_image()
+neighbor = merge(1,me+1,me==num_images())
+object[neighbor]%indices=[(i,i=1,5)]
+object[neighbor]%i = 37
+object[neighbor]%scalar = 42
+vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
+object[neighbor]%volume = vol_static
+object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7])
+object[neighbor]%dynvol = vol_static
+sync all
+if (object%scalar /= 42) call abort()
+if (any( object%indices /= [1,2,3,4,5] )) call abort()
+if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
+if (any( object%volume /= vol_static)) call abort()
+if (any( object%dynvol /= vol_static)) call abort()
+
+vol2 = vol_static
+vol2(:, ::2, :) = 42
+object[neighbor]%volume(:, ::2, :) = 42
+object[neighbor]%dynvol(:, ::2, :) = 42
+if (any( object%volume /= vol2)) call abort()
+if (any( object%dynvol /= vol2)) call abort()
+
+allocate(bar%vec(-2:2))
+
+bar[neighbor]%vec(1)%volume = vol_static
+if (any(bar%vec(1)%volume /= vol_static)) call abort()
+
+i = 15
+bar[neighbor]%vec(1)%scalar = i
+if (.not. allocated(bar%vec(1)%scalar)) call abort()
+if (bar%vec(1)%scalar /= 15) call abort()
+
+bar[neighbor]%vec(0)%scalar = 27
+if (.not. allocated(bar%vec(0)%scalar)) call abort()
+if (bar%vec(0)%scalar /= 27) call abort()
+
+bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ]
+allocate(bar%vec(2)%indices(5))
+bar[neighbor]%vec(2)%indices = 89
+
+if (.not. allocated(bar%vec(1)%indices)) call abort()
+if (allocated(bar%vec(-2)%indices)) call abort()
+if (allocated(bar%vec(-1)%indices)) call abort()
+if (allocated(bar%vec( 0)%indices)) call abort()
+if (.not. allocated(bar%vec( 2)%indices)) call abort()
+if (any(bar%vec(2)%indices /= 89)) call abort()
+
+if (any (bar%vec(1)%indices /= [ 3,4,15])) call abort()
+end program

gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08

+! { dg-do run }
+
+  type :: t
+    integer :: i
+  end type
+
+  type, extends(t) :: r
+    real :: r
+  end type
+
+  class(t), allocatable :: x
+  type(r) :: y = r (3, 42)
+
+  x = y
+  if (x%i /= 3) call abort()
+  select type(x)
+    class is (r)
+      if (x%r /= 42.0) call abort()
+    class default
+      call abort()
+  end select
+end
+