2014-02-01 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-02-01  Paul Thomas  <pault@gcc.gnu.org>

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


git-svn-id: https://gcc.gnu.org/svn/gcc/branches/gcc-4_8-branch@207390 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 161 insertions, 0 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f423c46ba85..2ec8e7fa5e3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2014-02-01  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
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 430b10e3760..1d8588d6072 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,10 +5104,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.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ab31676e53a..10ada5e10d4 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2014-02-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/59414
+	* gfortran.dg/allocate_class_3.f90 : New test
+
 2014-01-30  David Holsgrove <david.holsgrove@xilinx.com>
 
 	Backport from mainline.
diff --git a/gcc/testsuite/gfortran.dg/allocate_class_3.f90 b/gcc/testsuite/gfortran.dg/allocate_class_3.f90
new file mode 100644
index 00000000000..ddc7e23283f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_class_3.f90
@@ -0,0 +1,107 @@
+! { 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
+