re PR fortran/52102 ([OOP] Wrong result with ALLOCATE of CLASS components with…

re PR fortran/52102 ([OOP] Wrong result with ALLOCATE of CLASS components with array constructor SOURCE-expr)

2012-02-05  Paul Thomas  <pault@gcc.gnu.org>

	* trans-array.c (gfc_array_allocate): Zero memory for all class
	array allocations.
	* trans-stmt.c (gfc_trans_allocate): Ditto for class scalars.

	PR fortran/52102
	* trans-stmt.c (gfc_trans_allocate): Before correcting a class
	array reference, ensure that 'dataref' points to the _data
	component that is followed by the array reference..

2012-02-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52102
	* gfortran.dg/class_48.f90 : Add test of allocate class array
	component with source in subroutine test3.  Remove commenting
	out in subroutine test4, since branching on unitialized variable
	is now fixed (no PR for this last.).

From-SVN: r183915

gcc/fortran/ChangeLog

+2012-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-array.c (gfc_array_allocate): Zero memory for all class
+	array allocations.
+	* trans-stmt.c (gfc_trans_allocate): Ditto for class scalars.
+
+	PR fortran/52102
+	* trans-stmt.c (gfc_trans_allocate): Before correcting a class
+	array reference, ensure that 'dataref' points to the _data
+	component that is followed by the array reference..
+
 2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/41587

gcc/fortran/trans-array.c

@@ -5111,8 +5111,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 
   gfc_add_expr_to_block (&se->pre, tmp);
 
-  if (expr->ts.type == BT_CLASS
-	&& (expr3_elem_size != NULL_TREE || expr3))
+  if (expr->ts.type == BT_CLASS)
     {
       tmp = build_int_cst (unsigned_char_type_node, 0);
       /* With class objects, it is best to play safe and null the 

gcc/fortran/trans-stmt.c

@@ -4957,7 +4957,7 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
-	  else if (al->expr->ts.type == BT_CLASS && code->expr3)
+	  else if (al->expr->ts.type == BT_CLASS)
 	    {
 	      /* With class objects, it is best to play safe and null the 
 		 memory because we cannot know if dynamic types have allocatable
@@ -5076,7 +5076,13 @@ gfc_trans_allocate (gfc_code * code)
 	      actual->next->expr = gfc_copy_expr (al->expr);
 	      actual->next->expr->ts.type = BT_CLASS;
 	      gfc_add_data_component (actual->next->expr);
+
 	      dataref = actual->next->expr->ref;
+	      /* Make sure we go up through the reference chain to
+		 the _data reference, where the arrayspec is found.  */
+	      while (dataref->next && dataref->next->type != REF_ARRAY)
+		dataref = dataref->next;
+
 	      if (dataref->u.c.component->as)
 		{
 		  int dim;

gcc/testsuite/ChangeLog

+2012-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52102
+	* gfortran.dg/class_48.f90 : Add test of allocate class array
+	component with source in subroutine test3.  Remove commenting
+	out in subroutine test4, since branching on unitialized variable
+	is now fixed (no PR for this last.).
+
 2012-02-05  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	* gcc.dg/tree-prof/stringop-2.c (main): Add a nomips16 attribute

gcc/testsuite/gfortran.dg/class_48.f90

 ! { dg-do run }
 !
 ! PR fortran/51972
+! Also tests fixes for PR52102
 !
 ! Check whether DT assignment with polymorphic components works.
 !
@@ -70,10 +71,11 @@ subroutine test3 ()
 
   type(t2) :: one, two
 
-  allocate (two%a(2))
-  two%a(1)%x = 4
-  two%a(2)%x = 6
+! Test allocate with array source - PR52102
+  allocate (two%a(2), source = [t(4), t(6)])
+
   if (allocated (one%a)) call abort ()
+
   one = two
   if (.not.allocated (one%a)) call abort ()
 
@@ -82,6 +84,24 @@ subroutine test3 ()
 
   deallocate (two%a)
   one = two
+
+  if (allocated (one%a)) call abort ()
+
+! Test allocate with no source followed by assignments.
+  allocate (two%a(2))
+  two%a(1)%x = 5
+  two%a(2)%x = 7
+
+  if (allocated (one%a)) call abort ()
+
+  one = two
+  if (.not.allocated (one%a)) call abort ()
+
+  if ((one%a(1)%x /= 5)) call abort ()
+  if ((one%a(2)%x /= 7)) call abort ()
+
+  deallocate (two%a)
+  one = two
   if (allocated (one%a)) call abort ()
 end subroutine test3
 
@@ -98,38 +118,35 @@ subroutine test4 ()
 
   if (allocated (one%a)) call abort ()
   if (allocated (two%a)) call abort ()
-!
-! FIXME: Fails due to PR 51754
-!
-! NOTE: Might be only visible with MALLOC_PERTURB_ or with valgrind
-!
-!  allocate (two%a(2))
-!  if (allocated (two%a(1)%x)) call abort ()
-!  if (allocated (two%a(2)%x)) call abort ()
-!  allocate (two%a(1)%x(3), source=[1,2,3])
-!  allocate (two%a(2)%x(5), source=[5,6,7,8,9])
-!  one = two
-!  if (.not. allocated (one%a)) call abort ()
-!  if (.not. allocated (one%a(1)%x)) call abort ()
-!  if (.not. allocated (one%a(2)%x)) call abort ()
-!
-!  if (size(one%a) /= 2) call abort()
-!  if (size(one%a(1)%x) /= 3) call abort()
-!  if (size(one%a(2)%x) /= 5) call abort()
-!  if (any (one%a(1)%x /= [1,2,3])) call abort ()
-!  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
-!
-!  deallocate (two%a(1)%x)
-!  one = two
-!  if (.not. allocated (one%a)) call abort ()
-!  if (allocated (one%a(1)%x)) call abort ()
-!  if (.not. allocated (one%a(2)%x)) call abort ()
-!
-!  if (size(one%a) /= 2) call abort()
-!  if (size(one%a(2)%x) /= 5) call abort()
-!  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
-!
-!  deallocate (two%a)
+
+  allocate (two%a(2))
+
+  if (allocated (two%a(1)%x)) call abort ()
+  if (allocated (two%a(2)%x)) call abort ()
+  allocate (two%a(1)%x(3), source=[1,2,3])
+  allocate (two%a(2)%x(5), source=[5,6,7,8,9])
+  one = two
+  if (.not. allocated (one%a)) call abort ()
+  if (.not. allocated (one%a(1)%x)) call abort ()
+  if (.not. allocated (one%a(2)%x)) call abort ()
+
+  if (size(one%a) /= 2) call abort()
+  if (size(one%a(1)%x) /= 3) call abort()
+  if (size(one%a(2)%x) /= 5) call abort()
+  if (any (one%a(1)%x /= [1,2,3])) call abort ()
+  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
+
+  deallocate (two%a(1)%x)
+  one = two
+  if (.not. allocated (one%a)) call abort ()
+  if (allocated (one%a(1)%x)) call abort ()
+  if (.not. allocated (one%a(2)%x)) call abort ()
+
+  if (size(one%a) /= 2) call abort()
+  if (size(one%a(2)%x) /= 5) call abort()
+  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
+
+  deallocate (two%a)
   one = two
   if (allocated (one%a)) call abort ()
   if (allocated (two%a)) call abort ()
@@ -141,3 +158,4 @@ call test2 ()
 call test3 ()
 call test4 ()
 end
+