Shucks! Here it is....
On 24 October 2015 at 15:08, Paul Richard Thomas
<paul.richard.tho...@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 <pa...@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 <pa...@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
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 <me...@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
