re PR fortran/84546 (Bad sourced allocation of CLASS(*) with source with CLASS(*) component)

2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84546
	* trans-array.c (structure_alloc_comps): Make sure that the
	vptr is copied and that the unlimited polymorphic _len is used
	to compute the size to be allocated.
	* trans-expr.c (gfc_get_class_array_ref): If unlimited, use the
	unlimited polymorphic _len for the offset to the element.
	(gfc_copy_class_to_class): Set the new 'unlimited' argument.
	* trans.h : Add the boolean 'unlimited' to the prototype.

2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84546
	* gfortran.dg/unlimited_polymorphic_29.f90 : New test.

From-SVN: r258438

6 files changed, 154 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 45def32..e767908 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2018-03-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/84546
+	* trans-array.c (structure_alloc_comps): Make sure that the
+	vptr is copied and that the unlimited polymorphic _len is used
+	to compute the size to be allocated.
+	* trans-expr.c (gfc_get_class_array_ref): If unlimited, use the
+	unlimited polymorphic _len for the offset to the element.
+	(gfc_copy_class_to_class): Set the new 'unlimited' argument.
+	* trans.h : Add the boolean 'unlimited' to the prototype.
 
 2018-03-11  Steven G. Kargl  <kargl@gcc.gnu.org>
 
@@ -86,7 +96,7 @@
 	PR fortran/66128
 	* simplify.c (is_size_zero_array): New function to check for size
 	zero array.
-	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, 
+	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
 	 gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity,
 	 gfc_simplify_minval, gfc_simplify_maxval, gfc_simplify_norm2,
 	 gfc_simplify_product, gfc_simplify_sum): Use it, and implement
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 171cebd..bd73168 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8883,6 +8883,31 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      gfc_init_block (&tmpblock);
 
+	      gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
+			      gfc_class_vptr_get (comp));
+
+	      /* Copy the unlimited '_len' field. If it is greater than zero
+		 (ie. a character(_len)), multiply it by size and use this
+		 for the malloc call.  */
+	      if (UNLIMITED_POLY (c))
+		{
+		  tree ctmp;
+		  gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
+				  gfc_class_len_get (comp));
+
+		  size = gfc_evaluate_now (size, &tmpblock);
+		  tmp = gfc_class_len_get (comp);
+		  ctmp = fold_build2_loc (input_location, MULT_EXPR,
+					  size_type_node, size,
+					  fold_convert (size_type_node, tmp));
+		  tmp = fold_build2_loc (input_location, GT_EXPR,
+					 logical_type_node, tmp,
+					 build_zero_cst (TREE_TYPE (tmp)));
+		  size = fold_build3_loc (input_location, COND_EXPR,
+					  size_type_node, tmp, ctmp, size);
+		  size = gfc_evaluate_now (size, &tmpblock);
+		}
+
 	      /* Coarray component have to have the same allocation status and
 		 shape/type-parameter/effective-type on the LHS and RHS of an
 		 intrinsic assignment. Hence, we did not deallocated them - and
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c84cd10..54bda1d 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1185,15 +1185,32 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
    of the referenced element.  */
 
 tree
-gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
+gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
+			 bool unlimited)
 {
-  tree data = data_comp != NULL_TREE ? data_comp :
-				       gfc_class_data_get (class_decl);
-  tree size = gfc_class_vtab_size_get (class_decl);
-  tree offset = fold_build2_loc (input_location, MULT_EXPR,
-				 gfc_array_index_type,
-				 index, size);
-  tree ptr;
+  tree data, size, tmp, ctmp, offset, ptr;
+
+  data = data_comp != NULL_TREE ? data_comp :
+				  gfc_class_data_get (class_decl);
+  size = gfc_class_vtab_size_get (class_decl);
+
+  if (unlimited)
+    {
+      tmp = fold_convert (gfc_array_index_type,
+			  gfc_class_len_get (class_decl));
+      ctmp = fold_build2_loc (input_location, MULT_EXPR,
+			      gfc_array_index_type, size, tmp);
+      tmp = fold_build2_loc (input_location, GT_EXPR,
+			     logical_type_node, tmp,
+			     build_zero_cst (TREE_TYPE (tmp)));
+      size = fold_build3_loc (input_location, COND_EXPR,
+			      gfc_array_index_type, tmp, ctmp, size);
+    }
+
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    index, size);
+
   data = gfc_conv_descriptor_data_get (data);
   ptr = fold_convert (pvoid_type_node, data);
   ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
@@ -1295,14 +1312,15 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 
       if (is_from_desc)
 	{
-	  from_ref = gfc_get_class_array_ref (index, from, from_data);
+	  from_ref = gfc_get_class_array_ref (index, from, from_data,
+					      unlimited);
 	  vec_safe_push (args, from_ref);
 	}
       else
         vec_safe_push (args, from_data);
 
       if (is_to_class)
-	to_ref = gfc_get_class_array_ref (index, to, to_data);
+	to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
       else
 	{
 	  tmp = gfc_conv_array_data (to);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2ada805..1bd8206 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -431,7 +431,7 @@ tree gfc_vptr_deallocate_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
-tree gfc_get_class_array_ref (tree, tree, tree);
+tree gfc_get_class_array_ref (tree, tree, tree, bool);
 tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c089a1d..883fbb0c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-03-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/84546
+	* gfortran.dg/unlimited_polymorphic_29.f90 : New test.
+
 2018-03-11  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/83939
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90
new file mode 100644
index 0000000..d4ad39c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90
@@ -0,0 +1,84 @@
+! { dg-do run }
+!
+! Test the fix for PR84546 in which the failing cases would
+! have x%vec = ['foo','b   '].
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+module any_vector_type
+
+  type :: any_vector
+    class(*), allocatable :: vec(:)
+  end type
+
+  interface any_vector
+    procedure any_vector1
+  end interface
+
+contains
+
+  function any_vector1(vec) result(this)
+    class(*), intent(in) :: vec(:)
+    type(any_vector) :: this
+    allocate(this%vec, source=vec)
+  end function
+
+end module
+
+program main
+
+  use any_vector_type
+  implicit none
+
+  class(*), allocatable :: x
+  character(*), parameter :: vec(2) = ['foo','bar']
+  integer :: vec1(3) = [7,8,9]
+
+  call foo1
+  call foo2
+  call foo3
+  call foo4
+
+contains
+
+  subroutine foo1 ! This always worked
+    allocate (any_vector :: x)
+    select type (x)
+      type is (any_vector)
+        x = any_vector(vec)
+    end select
+    call bar(1)
+    deallocate (x)
+  end
+
+  subroutine foo2 ! Failure found during diagnosis
+    x = any_vector (vec)
+    call bar(2)
+    deallocate (x)
+  end
+
+  subroutine foo3 ! Original failure
+    allocate (x, source = any_vector (vec))
+    call bar(3)
+    deallocate (x)
+  end
+
+  subroutine foo4 ! This always worked
+    allocate (x, source = any_vector (vec1))
+    call bar(4)
+    deallocate (x)
+  end
+
+  subroutine bar (stop_flag)
+    integer :: stop_flag
+    select type (x)
+      type is (any_vector)
+        select type (xvec => x%vec)
+          type is (character(*))
+            if (any(xvec /= vec)) stop stop_flag
+          type is (integer)
+            if (any(xvec /= (vec1))) stop stop_flag
+        end select
+    end select
+  end
+end program