Re: [Patch, fortran] PR67171 - [6 regression] sourced allocation

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2071 bytes --]

Shucks! Here it is....

On 24 October 2015 at 15:08, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> This patch does four things:
> (i) On deallocating class components, the vptr is set to point to the
> vtable of the declared type;
> (ii) When digging out the last class reference, a NULL is returned if
> the allocatable component is to the right of a part reference with
> non-zero rank, so that the resulting ICE is removed. The previous
> modification takes care of these cases for gfc_reset_vptr and
> gfc_reset_len;
> (iii) gfc_reset_vptr has been simplified by the use of
> gfc_get_vptr_from_expr; and
> (iv) All variable expressions for the source are passed to
> gfc_trans-assignment, so that array sections work correctly.
>
> I see that Andre has already reserved the testcase
> allocate_with_source_10, for the pending patch that I undertook to
> review, so I will change this to #12 on submission
>
> OK for trunk?
>
> Cheers
>
> Paul
>
> 2015-01-24  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/67171
>     * trans-array.c (structure_alloc_comps): On deallocation of
>     class components, reset the vptr to the declared type vtable
>     and reset the _len field of unlimited polymorphic components.
>     *trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on
>     allocatable component references to the right of part reference
>     with non-zero rank and return NULL.
>     (gfc_reset_vptr): Simplify this function by using the function
>     gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE.
>     (gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns
>     NULL return.
>     * trans-stmt.c (gfc_trans_allocate): Rely on the use of
>     gfc_trans_assignment if expr3 is a variable expression since
>     this deals correctly with array sections.
>
> 2015-01-24  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/67171
>     * gfortran.dg/allocate_with_source_10.f03: New test



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 7729 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 229283)
--- gcc/fortran/trans-array.c	(working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8012,8017 ****
--- 8012,8043 ----
  					 build_int_cst (TREE_TYPE (comp), 0));
  		}
  	      gfc_add_expr_to_block (&tmpblock, tmp);
+ 
+ 	      /* Finally, reset the vptr to the declared type vtable and, if
+ 		 necessary reset the _len field.  */
+ 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ 				     decl, cdecl, NULL_TREE);
+ 	      tmp = gfc_class_vptr_get (comp);
+ 	      if (UNLIMITED_POLY (c))
+ 		{
+ 		  gfc_add_modify (&tmpblock, tmp,
+ 				  build_int_cst (TREE_TYPE (tmp), 0));
+ 		  tmp = gfc_class_len_get (comp);
+ 		  gfc_add_modify (&tmpblock, tmp,
+ 				  build_int_cst (TREE_TYPE (tmp), 0));
+ 		}
+ 	      else
+ 		{
+ 		  tree vtab;
+ 		  gfc_symbol *vtable;
+ 		  vtable = gfc_find_derived_vtab (c->ts.u.derived);
+ 		  vtab = vtable->backend_decl;
+ 		  if (vtab == NULL_TREE)
+ 		    vtab = gfc_get_symbol_decl(vtable);
+ 		  vtab = gfc_build_addr_expr (NULL, vtab);
+ 		  vtab = fold_convert (TREE_TYPE (tmp), vtab);
+ 		  gfc_add_modify (&tmpblock, tmp, vtab);
+ 		}
  	    }
  
  	  if (cmp_has_alloc_comps
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 229283)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_expr *
*** 271,285 ****
  gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
  {
    gfc_expr *base_expr;
!   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;
--- 271,297 ----
  gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
  {
    gfc_expr *base_expr;
!   gfc_ref *ref, *class_ref, *tail, *array_ref;
  
    /* Find the last class reference.  */
    class_ref = NULL;
+   array_ref = NULL;
    for (ref = e->ref; ref; ref = ref->next)
      {
+       if (ref->type == REF_ARRAY
+ 	  && ref->u.ar.type != AR_ELEMENT)
+ 	array_ref = ref;
+ 
        if (ref->type == REF_COMPONENT
  	  && ref->u.c.component->ts.type == BT_CLASS)
+ 	{
+ 	  /* Component to the right of a part reference with nonzero rank
+ 	     must not have the ALLOCATABLE attribute.  */
+ 	  if (array_ref
+ 	      && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+ 	    return NULL;
  	  class_ref = ref;
+ 	}
  
        if (ref->next == NULL)
  	break;
*************** gfc_find_and_cut_at_last_class_ref (gfc_
*** 320,366 ****
  void
  gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
  {
-   gfc_expr *rhs, *lhs = gfc_copy_expr (e);
    gfc_symbol *vtab;
!   tree tmp;
!   gfc_ref *ref;
! 
!   /* If we have a class array, we need go back to the class
!      container.  */
!   if (lhs->ref && lhs->ref->next && !lhs->ref->next->next
!       && lhs->ref->next->type == REF_ARRAY
!       && lhs->ref->next->u.ar.type == AR_FULL
!       && lhs->ref->type == REF_COMPONENT
!       && strcmp (lhs->ref->u.c.component->name, "_data") == 0)
!     {
!       gfc_free_ref_list (lhs->ref);
!       lhs->ref = NULL;
!     }
    else
!     for (ref = lhs->ref; ref; ref = ref->next)
!       if (ref->next && ref->next->next && !ref->next->next->next
! 	  && ref->next->next->type == REF_ARRAY
! 	  && ref->next->next->u.ar.type == AR_FULL
! 	  && ref->next->type == REF_COMPONENT
! 	  && strcmp (ref->next->u.c.component->name, "_data") == 0)
! 	{
! 	  gfc_free_ref_list (ref->next);
! 	  ref->next = NULL;
! 	}
! 
!   gfc_add_vptr_component (lhs);
  
    if (UNLIMITED_POLY (e))
!     rhs = gfc_get_null_expr (NULL);
    else
      {
        vtab = gfc_find_derived_vtab (e->ts.u.derived);
!       rhs = gfc_lval_expr_from_sym (vtab);
      }
-   tmp = gfc_trans_pointer_assignment (lhs, rhs);
-   gfc_add_expr_to_block (block, tmp);
-   gfc_free_expr (lhs);
-   gfc_free_expr (rhs);
  }
  
  
--- 332,364 ----
  void
  gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
  {
    gfc_symbol *vtab;
!   tree vptr;
!   tree vtable;
!   gfc_se se;
! 
!   gfc_init_se (&se, NULL);
!   if (e->rank)
!     gfc_conv_expr_descriptor (&se, e);
    else
!     gfc_conv_expr (&se, e);
!   gfc_add_block_to_block (block, &se.pre);
!   vptr = gfc_get_vptr_from_expr (se.expr);
!   if (vptr == NULL_TREE)
!     return;
  
    if (UNLIMITED_POLY (e))
!     gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
    else
      {
        vtab = gfc_find_derived_vtab (e->ts.u.derived);
!       vtable = vtab->backend_decl;
!       if (vtable == NULL_TREE)
! 	vtable = gfc_get_symbol_decl (vtab);
!       vtable = gfc_build_addr_expr (NULL, vtable);
!       vtable = fold_convert (TREE_TYPE (vptr), vtable);
!       gfc_add_modify (block, vptr, vtable);
      }
  }
  
  
*************** gfc_reset_len (stmtblock_t *block, gfc_e
*** 372,377 ****
--- 370,377 ----
    gfc_expr *e;
    gfc_se se_len;
    e = gfc_find_and_cut_at_last_class_ref (expr);
+   if (e == NULL)
+     return;
    gfc_add_len_component (e);
    gfc_init_se (&se_len, NULL);
    gfc_conv_expr (&se_len, e);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 229283)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5343,5349 ****
  	     gets.
  	     No need to check whether e3_is is E3_UNSET, because that is
  	     done by expr3 != NULL_TREE.  */
! 	  if (e3_is != E3_MOLD && expr3 != NULL_TREE
  	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
  	    {
  	      /* Build a temporary symtree and symbol.  Do not add it to
--- 5343,5350 ----
  	     gets.
  	     No need to check whether e3_is is E3_UNSET, because that is
  	     done by expr3 != NULL_TREE.  */
! 	  if (code->expr3->expr_type != EXPR_VARIABLE
! 	      && e3_is != E3_MOLD && expr3 != NULL_TREE
  	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
  	    {
  	      /* Build a temporary symtree and symbol.  Do not add it to
Index: gcc/testsuite/gfortran.dg/allocate_with_source_10.f03
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_with_source_10.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/allocate_with_source_10.f03	(working copy)
***************
*** 0 ****
--- 1,38 ----
+ ! { dg-do run }
+ !
+ ! Checks the fix for PR67171, where the second ALLOCATE with and array section
+ ! SOURCE produced a zero index based temporary, which threw the assignment.
+ !
+ ! Contributed by Anton Shterenlikht  <mexas@bristol.ac.uk>
+ !
+ program z
+   implicit none
+   integer, parameter :: DIM1_SIZE = 10
+   real, allocatable :: d(:,:), tmp(:,:)
+   integer :: i, errstat
+ 
+   allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat )
+ 
+   d(:,1) = [( real (i), i=1,DIM1_SIZE)]
+   d(:,2) = [( real(2*i), i=1,DIM1_SIZE)]
+ !  write (*,*) d(1, :)
+ 
+   call move_alloc (from = d, to = tmp)
+ !  write (*,*) tmp( 1, :)
+ 
+   allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat)
+   if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) call abort
+   deallocate (d)
+ 
+   allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat)
+   if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) call abort
+ 
+   deallocate (tmp , d)
+ 
+ contains
+   function foo (arg) result (res)
+     real :: arg(:,:)
+     real :: res(size (arg, 1), size (arg, 2))
+     res = arg
+   end function
+ end program z