[Patch, fortran] PR59414 [4.8/4.9 Regression] [OOP] ICE in in gfc_conv_expr_descriptor on ALLOCATE inside SELECT TYPE

Paul Richard Thomas paul.richard.thomas@gmail.com
Mon Jan 20 18:48:00 GMT 2014


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

    PR fortran/59414
    * gfortran.dg/allocate_class_3.f90 : New test
-------------- next part --------------
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  <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
+ 


More information about the Gcc-patches mailing list