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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@207204 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aacf31b..577d778 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5dd7baf..50e9a1a 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/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.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1e88ecb..049da58 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,6 +1,7 @@
-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.
 

diff --git a/gcc/testsuite/gfortran.dg/allocate_class_3.f90 b/gcc/testsuite/gfortran.dg/allocate_class_3.f90
new file mode 100644 (file)
index 0000000..ddc7e23
--- /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
+

diff --git a/gcc/testsuite/gfortran.dg/elemental_by_value_1.f90 b/gcc/testsuite/gfortran.dg/elemental_by_value_1.f90
new file mode 100644 (file)
index 0000000..e69de29