From 1cf43a1dbdb4f61d2f9bbfffb2fdc6130aa07781 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 13 Apr 2014 11:58:55 +0000 Subject: [PATCH] re PR fortran/58085 (Wrong indexing of an array in ASSOCIATE) 2014-04-13 Paul Thomas PR fortran/58085 PR fortran/60717 * 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-13 Paul Thomas PR fortran/60717 * gfortran.dg/unlimited_polymorphic_17.f90: New test. PR fortran/58085 * gfortran.dg/associate_15.f90: New test. From-SVN: r209347 --- gcc/fortran/ChangeLog | 12 +++++ gcc/fortran/trans-array.c | 16 +++--- gcc/fortran/trans-expr.c | 2 + gcc/fortran/trans-stmt.c | 6 ++- gcc/fortran/trans.h | 8 ++- gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/associate_15.f90 | 40 +++++++++++++++ .../gfortran.dg/unlimited_polymorphic_17.f90 | 51 +++++++++++++++++++ 8 files changed, 132 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_15.f90 create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c14e209752c1..29ea5f7871c6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2014-04-13 Paul Thomas + + PR fortran/58085 + PR fortran/60717 + * 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-11 Tobias Burnus PR fortran/58880 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8c4afb098bf7..69c47bb1ab2e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6807,8 +6807,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* 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) + 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); @@ -6893,13 +6894,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) stride, info->stride[n]); if (se->direct_byref - && info->ref - && info->ref->u.ar.type != AR_FULL) + && ((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))) + 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, @@ -6935,8 +6936,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) 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) + 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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 30931a364c40..955102b042e1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -593,6 +593,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, else { parmse->ss = ss; + parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); gfc_add_modify (&parmse->pre, ctree, parmse->expr); } @@ -4378,6 +4379,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || 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 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1a9068c0f466..00c99fcfb5be 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1170,16 +1170,18 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* 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) + 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) + if (!sym->assoc->variable && e->expr_type != EXPR_ARRAY) { int dim; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4ae68c6cb859..f8d29ecf2ec4 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -87,6 +87,10 @@ typedef struct gfc_se 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. */ @@ -99,7 +103,7 @@ gfc_se; /* Denotes different types of coarray. Please keep in sync with libgfortran/caf/libcaf.h. */ -typedef enum +typedef enum { GFC_CAF_COARRAY_STATIC, GFC_CAF_COARRAY_ALLOC, @@ -178,7 +182,7 @@ typedef enum /* An intrinsic function call. Many intrinsic functions which map directly to library calls are created as GFC_SS_FUNCTION nodes. */ GFC_SS_INTRINSIC, - + /* A component of a derived type. */ GFC_SS_COMPONENT } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0af82c08c6aa..666ba05c12bb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2014-04-13 Paul Thomas + + PR fortran/60717 + * gfortran.dg/unlimited_polymorphic_17.f90: New test. + + PR fortran/58085 + * gfortran.dg/associate_15.f90: New test. + 2014-04-12 Igor Zamyatin PR middle-end/60467 diff --git a/gcc/testsuite/gfortran.dg/associate_15.f90 b/gcc/testsuite/gfortran.dg/associate_15.f90 new file mode 100644 index 000000000000..7e34eb518e0c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_15.f90 @@ -0,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 +! +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 diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 new file mode 100644 index 000000000000..0fcff74b9108 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90 @@ -0,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 -- 2.47.2