From: Paul Thomas Date: Wed, 30 Sep 2020 12:44:39 +0000 (+0100) Subject: This patch fixes PR97045 - unlimited polymorphic array element selectors. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fcc4891d7f3bff1a3f7428f12830bc942989306c;p=gcc.git This patch fixes PR97045 - unlimited polymorphic array element selectors. 2020-30-09 Paul Thomas gcc/fortran PR fortran/97045 * trans-array.c (gfc_conv_array_ref): Make sure that the class decl is passed to build_array_ref in the case of unlimited polymorphic entities. * trans-expr.c (gfc_conv_derived_to_class): Ensure that array refs do not preceed the _len component. Free the _len expr. * trans-stmt.c (trans_associate_var): Reset 'need_len_assign' for polymorphic scalars. * trans.c (gfc_build_array_ref): When the vptr size is used for span, multiply by the _len field of unlimited polymorphic entities, when non-zero. gcc/testsuite/ PR fortran/97045 * gfortran.dg/select_type_50.f90 : New test. --- diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6566c47d4ae..998d4d4ed9b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3787,7 +3787,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, decl = sym->backend_decl; } else if (sym->ts.type == BT_CLASS) - decl = NULL_TREE; + { + if (UNLIMITED_POLY (sym)) + { + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, class_expr); + if (!se->class_vptr) + se->class_vptr = gfc_class_vptr_get (tmpse.expr); + gfc_free_expr (class_expr); + decl = tmpse.expr; + } + else + decl = NULL_TREE; + } se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a690839f591..2c31ec9bf01 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -728,7 +728,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_expr *len; gfc_se se; - len = gfc_copy_expr (e); + len = gfc_find_and_cut_at_last_class_ref (e); gfc_add_len_component (len); gfc_init_se (&se, NULL); gfc_conv_expr (&se, len); @@ -739,6 +739,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, integer_zero_node)); else tmp = se.expr; + gfc_free_expr (len); } else tmp = integer_zero_node; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 389fec7227e..adc6b8fefb5 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -2091,6 +2091,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Obtain a temporary class container for the result. */ gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + need_len_assign = false; } else { diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index ed054261452..8caa625ab0e 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -429,7 +429,28 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) /* If decl or vptr are non-null, pointer arithmetic for the array reference is likely. Generate the 'span' for the array reference. */ if (vptr) - span = gfc_vptr_size_get (vptr); + { + span = gfc_vptr_size_get (vptr); + + /* Check if this is an unlimited polymorphic object carrying a character + payload. In this case, the 'len' field is non-zero. */ + if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + { + tmp = gfc_class_len_or_zero_get (decl); + if (!integer_zerop (tmp)) + { + tree cond; + tree stype = TREE_TYPE (span); + tmp = fold_convert (stype, tmp); + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, tmp, + build_int_cst (stype, 0)); + tmp = fold_build2 (MULT_EXPR, stype, span, tmp); + span = fold_build3_loc (input_location, COND_EXPR, stype, + cond, span, tmp); + } + } + } else if (decl) span = get_array_span (type, decl); diff --git a/gcc/testsuite/gfortran.dg/select_type_50.f90 b/gcc/testsuite/gfortran.dg/select_type_50.f90 new file mode 100644 index 00000000000..aea1c81fa20 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_50.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR97045. The report was for the INTEGER version. Testing +! revealed a further bug with the character versions. +! +! Contributed by Igor Gayday +! +program test_prg + implicit none + integer :: i + integer, allocatable :: arr(:, :) + character(kind = 1, len = 2), allocatable :: chr(:, :) + character(kind = 4, len = 2), allocatable :: chr4(:, :) + + arr = reshape ([(i, i = 1, 9)], [3, 3]) + do i = 1, 3 + call write_array(arr(1:2, i), i) + end do + + chr = reshape([(char (i)//char (i+1), i = 65, 83, 2)], [3, 3]) + do i = 1, 3 + call write_array (chr(1:2, i), i) + end do + + chr4 = reshape([(char (i, kind = 4)//char (i+1, kind = 4), i = 65, 83, 2)], & + [3, 3]) + do i = 1, 3 + call write_array (chr4(1:2, i), i) + end do + +contains + + subroutine write_array(array, j) + class(*), intent(in) :: array(:) + integer :: i = 2 + integer :: j, k + + select type (elem => array(i)) + type is (integer) + k = 3*(j-1)+i + if (elem .ne. k) stop 1 + type is (character(kind = 1, len = *)) + k = 63 + 2*(3*(j-1)+i) + if (elem .ne. char (k)//char (k+1)) print *, elem, " ", char (k)//char (k+1) + type is (character(kind = 4, len = *)) + k = 63 + 2*(3*(j-1)+i) + if (elem .ne. char (k, kind = 4)//char (k+1, kind = 4)) stop 3 + end select + + end subroutine + +end program