Hi All,
This patch makes sure that offsets and bounds are correct in passing
derived types to class formal arrays. It is straightforward enough as
not to require explanation.
Bootstraps and regtests on FC25/x86_64 - OK for trunk?
Paul
2018-02-11 Paul Thomas <pa...@gcc.gnu.org>
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 <pa...@gcc.gnu.org>
PR fortran/84074
* gfortran.dg/type_to_class_5.f03: New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 257549)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 547,552 ****
--- 547,553 ----
tree ctree;
tree var;
tree tmp;
+ int dim;
/* The derived type needs to be converted to a temporary
CLASS object. */
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 636,645 ****
--- 637,670 ----
{
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 vector array references. */
+ 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;
+ }
+
+ /* Vector array references and non-variable expressions need be
+ coverted to one-based descriptors. */
+ 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
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10105,10111 ****
&expr1->where, msg);
}
! /* Deallocate the lhs parameterized components if required. */
if (dealloc && expr2->expr_type == EXPR_FUNCTION
&& !expr1->symtree->n.sym->attr.associate_var)
{
--- 10130,10136 ----
&expr1->where, msg);
}
! /* Deallocate the lhs parameterized components if required. */
if (dealloc && expr2->expr_type == EXPR_FUNCTION
&& !expr1->symtree->n.sym->attr.associate_var)
{
Index: gcc/testsuite/gfortran.dg/type_to_class_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/type_to_class_5.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/type_to_class_5.f03 (working copy)
***************
*** 0 ****
--- 1,29 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR84074
+ !
+ ! Contributed by Vladimir Fuka <vladimir.f...@gmail.com>
+ !
+ 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
