Dear All,
This is a straightforward patch that is completely described in the
ChangeLog entry. I am surprised that this could be a 4.8 regression
since, as far as I am aware, SELECT_TYPE was not capable of handling
array selectors before... Nonetheless, it flagged it up for me :-)
Bootstrapped and regtested on FC17/x86_64 - OK for trunk and, after a
decent delay, 4.8?
Cheers
Paul
PS I know of at least one other place where this manoeuvre had to be
done. If I find a third, I will turn it into a function in class.c.
It might be worth doing anyway?
2014-01-20 Paul Thomas <pa...@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-20 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/59414
* gfortran.dg/allocate_class_3.f90 : New test
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 206747)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5102,5111 ****
--- 5102,5150 ----
{
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. */
Index: gcc/testsuite/gfortran.dg/allocate_class_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_class_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/allocate_class_3.f90 (working copy)
***************
*** 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 <ant...@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
+
