Dear All,
I have upgraded this patch slightly to fix PR58085 as well. I would
judge this to be completely safe because the fixes depend on the new
bit flag for both PRs.
Bootstrapped and regtested on FC17/x86_64 - OK for 4.9 immediately and trunk?
Paul
2014-04-12 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/60717
PR fortran/58085
* 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 for
array slices and constant arrays.
trans-expr.c (gfc_conv_intrinsic_to_class): Use it.
trans-stmt.c (trans_associate_var): Ditto.
(gfc_conv_procedure_call): Ditto.
2014-04-12 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/60717
* gfortran.dg/unlimited_polymorphic_17.f90: New test.
PR fortran/58085
* gfortran.dg/associate_15.f90: New test.
On 12 April 2014 10:30, Jakub Jelinek <ja...@redhat.com> wrote:
> On Sat, Apr 12, 2014 at 07:27:00AM +0200, Paul Richard Thomas wrote:
>> I know that you are probably snowed under with requests like this! I
>> was away on a business trip when Mikael's approval below came and had
>> intended to apply it to 4.9 aka trunk today. Is it OK with you if I
>> slip it into 4.9 or should I let it go until after the release?
>
> I'd prefer to put it in after the release, especially for non-regressions
> or regressions that aren't regressions from 4.8.2.
> 4.9.1 will be probably 2 months away from 4.9.0, and many people use release
> branch snapshots anyway, but I'd prefer to avoid any risks of slipping the
> release further.
>
> Jakub
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 209322)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6807,6814 ****
/* 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)))
base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
--- 6807,6815 ----
/* 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)
! || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
base = gfc_index_zero_node;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6893,6905 ****
stride, info->stride[n]);
if (se->direct_byref
! && info->ref
! && info->ref->u.ar.type != AR_FULL)
{
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,
--- 6894,6906 ----
stride, info->stride[n]);
if (se->direct_byref
! && ((info->ref && info->ref->u.ar.type != AR_FULL)
! || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
{
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);
--- 6936,6944 ----
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 209322)
--- 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-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 209322)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1170,1185 ****
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
! if (sym->assoc->variable)
{
se.direct_byref = 1;
se.expr = desc;
}
gfc_conv_expr_descriptor (&se, e);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
! if (!sym->assoc->variable)
{
int dim;
--- 1170,1187 ----
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
! if (sym->assoc->variable || e->expr_type == EXPR_ARRAY)
{
se.direct_byref = 1;
+ se.use_offset = 1;
se.expr = desc;
}
+
gfc_conv_expr_descriptor (&se, e);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
! if (!sym->assoc->variable && e->expr_type != EXPR_ARRAY)
{
int dim;
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 209322)
--- 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 and constant
+ arrays in gfc_conv_expr_descriptor. */
+ unsigned use_offset:1;
+
unsigned want_coarray:1;
/* Scalarization parameters. */
Index: gcc/testsuite/gfortran.dg/associate_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_15.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/associate_15.f90 (working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ ! Test the fix for PR58085, where the offset for 'x' was set to zero,
+ ! rather than -1.
+ !
+ ! Contributed by Vladimir Fuka <vladimir.f...@gmail.com>
+ !
+ module foo
+ contains
+ function bar (arg) result (res)
+ integer arg, res(3)
+ res = [arg, arg+1, arg +2]
+ end function
+ end module
+ use foo
+ real d(3,3)
+ integer a,b,c
+ character(48) line1, line2
+ associate (x=>shape(d))
+ a = x(1)
+ b = x(2)
+ write (line1, *) a, b
+ write (line2, *) x
+ if (trim (line1) .ne. trim (line2)) call abort
+ end associate
+ associate (x=>[1,2])
+ a = x(1)
+ b = x(2)
+ write (line1, *) a, b
+ write (line2, *) x
+ if (trim (line1) .ne. trim (line2)) call abort
+ end associate
+ associate (x=>bar(5)) ! make sure that we haven't broken function
association
+ a = x(1)
+ b = x(2)
+ c = x(3)
+ write (line1, *) a, b, c
+ write (line2, *) x
+ if (trim (line1) .ne. trim (line2)) call abort
+ end associate
+ end
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
