re PR fortran/59414 ([OOP] ICE in in gfc_conv_expr_descriptor on ALLOCATE inside SELECT TYPE)

2014-01-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/59414
	* trans-stmt.c (gfc_trans_allocate): Before the pointer
	assignment to transfer the source _vptr to a class allocate
	expression, the final class reference should be exposed. The
	tail that includes the _data and array references is stored.
	This reduced expression is transferred to 'lhs' and the _vptr
	added. Then the tail is restored to the allocate expression.

2014-01-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/59414
	* gfortran.dg/allocate_class_3.f90 : New test

From-SVN: r207204

gcc/fortran/ChangeLog

+2014-01-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/59414
+	* trans-stmt.c (gfc_trans_allocate): Before the pointer
+	assignment to transfer the source _vptr to a class allocate
+	expression, the final class reference should be exposed. The
+	tail that includes the _data and array references is stored.
+	This reduced expression is transferred to 'lhs' and the _vptr
+	added. Then the tail is restored to the allocate expression.
+
 2014-01-26  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/58007

gcc/fortran/trans-stmt.c

@@ -5102,10 +5102,49 @@ gfc_trans_allocate (gfc_code * code)
 	{
 	  gfc_expr *lhs, *rhs;
 	  gfc_se lse;
+	  gfc_ref *ref, *class_ref, *tail;
+
+	  /* Find the last class reference.  */
+	  class_ref = NULL;
+	  for (ref = e->ref; ref; ref = ref->next)
+	    {
+	      if (ref->type == REF_COMPONENT
+		  && ref->u.c.component->ts.type == BT_CLASS)
+		class_ref = ref;
+
+	      if (ref->next == NULL)
+		break;
+	    }
+
+	  /* Remove and store all subsequent references after the
+	     CLASS reference.  */
+	  if (class_ref)
+	    {
+	      tail = class_ref->next;
+	      class_ref->next = NULL;
+	    }
+	  else
+	    {
+	      tail = e->ref;
+	      e->ref = NULL;
+	    }
 
 	  lhs = gfc_expr_to_initialize (e);
 	  gfc_add_vptr_component (lhs);
 
+	  /* Remove the _vptr component and restore the original tail
+	     references.  */
+	  if (class_ref)
+	    {
+	      gfc_free_ref_list (class_ref->next);
+	      class_ref->next = tail;
+	    }
+	  else
+	    {
+	      gfc_free_ref_list (e->ref);
+	      e->ref = tail;
+	    }
+
 	  if (class_expr != NULL_TREE)
 	    {
 	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */

gcc/testsuite/ChangeLog

-2014-01-28  Kazu Hirata  <kazu@codesourcery.com>
+2014-01-28  Paul Thomas  <pault@gcc.gnu.org>
 
-	* gcc.target/arm/thumb-cbranchqi.c: Accept bls also.
+	PR fortran/59414
+	* gfortran.dg/allocate_class_3.f90 : New test
 
 2014-01-28  Dodji Seketeli  <dodji@redhat.com>
 
@@ -707,7 +708,7 @@
 
 	PR ipa/58252
 	PR ipa/59226
-	* g++.dg/ipa/devirt-20.C: New testcase.	
+	* g++.dg/ipa/devirt-20.C: New testcase.
 	* g++.dg/torture/pr58252.C: Likewise.
 	* g++.dg/torture/pr59226.C: Likewise.
 

gcc/testsuite/gfortran.dg/allocate_class_3.f90

+! { dg-do run }
+! Tests the fix for PR59414, comment #3, in which the allocate
+! expressions were not correctly being stripped to provide the
+! vpointer as an lhs to the pointer assignment of the vptr from
+! the SOURCE expression.
+!
+! Contributed by Antony Lewis  <antony@cosmologist.info>
+!
+module ObjectLists
+  implicit none
+
+  type :: t
+    integer :: i
+  end type
+
+  type Object_array_pointer
+    class(t), pointer :: p(:)
+  end type
+
+contains
+
+  subroutine AddArray1 (P, Pt)
+    class(t) :: P(:)
+    class(Object_array_pointer) :: Pt
+
+    select type (Pt)
+    class is (Object_array_pointer)
+      if (associated (Pt%P)) deallocate (Pt%P)
+      allocate(Pt%P(1:SIZE(P)), source=P)
+    end select
+  end subroutine
+
+  subroutine AddArray2 (P, Pt)
+    class(t) :: P(:)
+    class(Object_array_pointer) :: Pt
+
+    select type (Pt)
+    type is (Object_array_pointer)
+      if (associated (Pt%P)) deallocate (Pt%P)
+      allocate(Pt%P(1:SIZE(P)), source=P)
+    end select
+  end subroutine
+
+  subroutine AddArray3 (P, Pt)
+    class(t) :: P
+    class(Object_array_pointer) :: Pt
+
+    select type (Pt)
+    class is (Object_array_pointer)
+      if (associated (Pt%P)) deallocate (Pt%P)
+      allocate(Pt%P(1:4), source=P)
+    end select
+  end subroutine
+
+  subroutine AddArray4 (P, Pt)
+    type(t) :: P(:)
+    class(Object_array_pointer) :: Pt
+
+    select type (Pt)
+    class is (Object_array_pointer)
+      if (associated (Pt%P)) deallocate (Pt%P)
+      allocate(Pt%P(1:SIZE(P)), source=P)
+    end select
+  end subroutine
+end module
+
+  use ObjectLists
+  type(Object_array_pointer), pointer :: Pt
+  class(t), pointer :: P(:)
+
+  allocate (P(2), source = [t(1),t(2)])
+  allocate (Pt, source = Object_array_pointer(NULL()))
+  call AddArray1 (P, Pt)
+  select type (x => Pt%p)
+    type is (t)
+      if (any (x%i .ne. [1,2])) call abort
+  end select
+  deallocate (P)
+  deallocate (pt)
+
+  allocate (P(3), source = [t(3),t(4),t(5)])
+  allocate (Pt, source = Object_array_pointer(NULL()))
+  call AddArray2 (P, Pt)
+  select type (x => Pt%p)
+    type is (t)
+      if (any (x%i .ne. [3,4,5])) call abort
+  end select
+  deallocate (P)
+  deallocate (pt)
+
+  allocate (Pt, source = Object_array_pointer(NULL()))
+  call AddArray3 (t(6), Pt)
+  select type (x => Pt%p)
+    type is (t)
+      if (any (x%i .ne. [6,6,6,6])) call abort
+  end select
+  deallocate (pt)
+
+  allocate (Pt, source = Object_array_pointer(NULL()))
+  call AddArray4 ([t(7), t(8)], Pt)
+  select type (x => Pt%p)
+    type is (t)
+      if (any (x%i .ne. [7,8])) call abort
+  end select
+  deallocate (pt)
+ end
+