Dear All,
This fix, of itself, is quite obvious. The offset was being set to
zero for array segments, rather than that required for unity valued
lvalues.
I think that the fix could be used to clean up:
trans-expr.c(gfc_trans_alloc_subarray_assign)
trans-expr.c(gfc_trans_pointer_assign)
trans-expr.c(fncall_realloc_result)
trans-array.c(trans_associate_var)
each of which contains calculation of the offset. However, I do not
think that this is the stage to fix things that are not broken!
I propose to keep the PR open as a reminder to look into this.
Bootstrapped and regtested on X86_64/FC17 - OK for trunk and backporting to 4.8?
Paul
2014-04-12 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/58771
* trans.h : Add 'use_offset' bitfield to gfc_se.
* trans-array.c (gfc_conv_expr_descriptor) : Use 'use_offset'
as a trigger to unconditionally recalculate the offset.
trans-expr.c (gfc_conv_intrinsic_to_class) : Use it.
(gfc_conv_procedure_call) : Ditto.
2014-04-02 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/58771
* gfortran.dg/unlimited_polymorphic_17.f90 : New test
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 208997)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6807,6813 ****
/* Set offset for assignments to pointer only to zero if it is not
the full array. */
! if (se->direct_byref
&& info->ref && info->ref->u.ar.type != AR_FULL)
base = gfc_index_zero_node;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
--- 6807,6813 ----
/* Set offset for assignments to pointer only to zero if it is not
the full array. */
! if ((se->direct_byref || se->use_offset)
&& info->ref && info->ref->u.ar.type != AR_FULL)
base = gfc_index_zero_node;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6899,6905 ****
base = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (base), base, stride);
}
! else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
tmp = gfc_conv_array_lbound (desc, n);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
--- 6899,6905 ----
base = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (base), base, stride);
}
! else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
{
tmp = gfc_conv_array_lbound (desc, n);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6935,6942 ****
gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
subref_array_target, expr);
! if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
{
/* Set the offset. */
gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
--- 6935,6943 ----
gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
subref_array_target, expr);
! if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
+ || (se->use_offset && base != NULL_TREE))
{
/* Set the offset. */
gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 208997)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_intrinsic_to_class (gfc_se *par
*** 593,598 ****
--- 593,599 ----
else
{
parmse->ss = ss;
+ parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4378,4383 ****
--- 4379,4385 ----
|| CLASS_DATA (fsym)->attr.codimension))
{
/* Pass a class array. */
+ parmse.use_offset = 1;
gfc_conv_expr_descriptor (&parmse, e);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 208997)
--- gcc/fortran/trans.h (working copy)
*************** typedef struct gfc_se
*** 87,92 ****
--- 87,96 ----
args alias. */
unsigned force_tmp:1;
+ / * Unconditionally calculate offset for array segments in
+ gfc_conv_expr_descriptor. */
+ unsigned use_offset:1;
+
unsigned want_coarray:1;
/* Scalarization parameters. */
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 (working copy)
***************
*** 0 ****
--- 1,51 ----
+ ! { dg-do run }
+ ! Tests fix for PR60717 in which offsets in recursive calls below
+ ! were not being set correctly.
+ !
+ ! Reported on comp.lang.fortran by Thomas Schnurrenberger
+ !
+ module m
+ implicit none
+ real :: chksum0 = 0, chksum1 = 0, chksum2 = 0
+ contains
+ recursive subroutine show_real(a)
+ real, intent(in) :: a(:)
+ if (size (a) > 0) then
+ chksum0 = a(1) + chksum0
+ call show_real (a(2:))
+ end if
+ return
+ end subroutine show_real
+ recursive subroutine show_generic1(a)
+ class(*), intent(in) :: a(:)
+ if (size (a) > 0) then
+ select type (a)
+ type is (real)
+ chksum1 = a(1) + chksum1
+ end select
+ call show_generic1 (a(2:)) ! recursive call outside SELECT TYPE
+ end if
+ return
+ end subroutine show_generic1
+ recursive subroutine show_generic2(a)
+ class(*), intent(in) :: a(:)
+ if (size (a) > 0) then
+ select type (a)
+ type is (real)
+ chksum2 = a(1) + chksum2
+ call show_generic2 (a(2:)) ! recursive call inside SELECT TYPE
+ end select
+ end if
+ return
+ end subroutine show_generic2
+ end module m
+ program test
+ use :: m
+ implicit none
+ real :: array(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
+ call show_real (array)
+ call show_generic1 (array)
+ call show_generic2 (array)
+ if (chksum0 .ne. chksum1) call abort
+ if (chksum0 .ne. chksum2) call abort
+ end program test
