From e519d2e8199746e9d2b6ef70de55f7331df5bc47 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 11 Feb 2018 18:22:24 +0000 Subject: [PATCH] re PR fortran/84074 (Incorrect indexing of array when actual argument is an array expression and dummy is polymorphic) 2018-02-11 Paul Thomas PR fortran/84074 * trans-expr.c (gfc_conv_derived_to_class): Set the use_offset flag. If the is a vector subscript or the expression is not a variable, make the descriptor one-based. 2018-02-11 Paul Thomas PR fortran/84074 * gfortran.dg/type_to_class_5.f03: New test. From-SVN: r257564 --- gcc/fortran/ChangeLog | 7 +++++ gcc/fortran/trans-expr.c | 27 ++++++++++++++++- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/type_to_class_5.f03 | 29 +++++++++++++++++++ 4 files changed, 67 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/type_to_class_5.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b0bd14f1839..bebf155bfd0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2018-02-11 Paul Thomas + + PR fortran/84074 + * trans-expr.c (gfc_conv_derived_to_class): Set the use_offset + flag. If the is a vector subscript or the expression is not a + variable, make the descriptor one-based. + 2018-02-10 Paul Thomas PR fortran/84141 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7f790e76a85..a4185820531 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -547,6 +547,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, tree ctree; tree var; tree tmp; + int dim; /* The derived type needs to be converted to a temporary CLASS object. */ @@ -636,10 +637,34 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { stmtblock_t block; gfc_init_block (&block); + gfc_ref *ref; parmse->ss = ss; + parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); + /* Detect any array references with vector subscripts. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT + && ref->u.ar.type != AR_FULL) + { + for (dim = 0; dim < ref->u.ar.dimen; dim++) + if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + break; + if (dim < ref->u.ar.dimen) + break; + } + + /* Array references with vector subscripts and non-variable expressions + need be coverted to a one-based descriptor. */ + if (ref || e->expr_type != EXPR_VARIABLE) + { + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim, + gfc_index_one_node); + } + if (e->rank != class_ts.u.derived->components->as->rank) { gcc_assert (class_ts.u.derived->components->as->type @@ -10105,7 +10130,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, &expr1->where, msg); } - /* Deallocate the lhs parameterized components if required. */ + /* Deallocate the lhs parameterized components if required. */ if (dealloc && expr2->expr_type == EXPR_FUNCTION && !expr1->symtree->n.sym->attr.associate_var) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a14db69e416..72b4e36fd16 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-02-11 Paul Thomas + + PR fortran/84074 + * gfortran.dg/type_to_class_5.f03: New test. + 2018-02-10 Paul Thomas PR fortran/56691 diff --git a/gcc/testsuite/gfortran.dg/type_to_class_5.f03 b/gcc/testsuite/gfortran.dg/type_to_class_5.f03 new file mode 100644 index 00000000000..29a4b409198 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/type_to_class_5.f03 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test the fix for PR84074 +! +! Contributed by Vladimir Fuka +! + type :: t + integer :: n + end type + + type(t) :: array(4) = [t(1),t(2),t(3),t(4)] + + call sub(array((/3,1/)), [3,1,0,0]) ! Does not increment any elements of 'array'. + call sub(array(1:3:2), [1,3,0,0]) + call sub(array(3:1:-2), [4,2,0,0]) + call sub(array, [3,2,5,4]) ! Elements 1 and 3 should have been incremented twice. + +contains + + subroutine sub(a, iarray) + class(t) :: a(:) + integer :: iarray(4) + integer :: i + do i=1,size(a) + if (a(i)%n .ne. iarray(i)) call abort + a(i)%n = a(i)%n+1 + enddo + end subroutine +end program -- 2.30.2