Hi Harald, thank you for the investigation and useful tips. I had to figure what went wrong here, but I now figured, that the array needs repacking when a negative stride is used (or at least a call to that routine, which then fixes "stuff"). I have added it, freeing the memory allocated potentially by pack, and also updated the testcase to include the negative stride.
Regtests fine on x86_64-pc-linux-gnu/Fedora 39. Ok for mainline? Regards, Andre On Sun, 16 Jun 2024 23:27:46 +0200 Harald Anlauf <anl...@gmx.de> wrote: << snipped for brevity >>> -- Andre Vehreschild * Email: vehre ad gmx dot de
From c0c95afa95bb682385e47cc248f04e6eecd91e6d Mon Sep 17 00:00:00 2001 From: Andre Vehreschild <ve...@gcc.gnu.org> Date: Fri, 14 Jun 2024 16:54:37 +0200 Subject: [PATCH] Fortran: Fix rejecting class arrays of different ranks as storage association argument. Removing the assert in trans-expr, lead to initial strides not set which is not fixed. When the array needs repacking, this is done for class arrays now, too. PR fortran/96992 gcc/fortran/ChangeLog: * trans-array.cc (gfc_trans_array_bounds): Set a starting stride, when descriptor expects a variable for the stride. (gfc_trans_dummy_array_bias): Allow storage association for dummy class arrays, when they are not elemental. * trans-expr.cc (gfc_conv_derived_to_class): Remove assert to allow converting derived to class type arrays with assumed rank. Add packing when necessary. gcc/testsuite/ChangeLog: * gfortran.dg/pr96992.f90: New test. --- gcc/fortran/trans-array.cc | 7 ++- gcc/fortran/trans-expr.cc | 31 ++++++++++++- gcc/testsuite/gfortran.dg/pr96992.f90 | 66 +++++++++++++++++++++++++++ 3 files changed, 101 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr96992.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 24a9a51692c..573e056d7c6 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -6798,6 +6798,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, size = gfc_index_one_node; offset = gfc_index_zero_node; + stride = GFC_TYPE_ARRAY_STRIDE (type, 0); + if (stride && VAR_P (stride)) + gfc_add_modify (pblock, stride, gfc_index_one_node); for (dim = 0; dim < as->rank; dim++) { /* Evaluate non-constant array bound expressions. @@ -7143,7 +7146,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) return; - if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) + if ((!is_classarray + || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT)) + && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym)) { gfc_trans_g77_array (sym, block); return; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 0796fb75505..4468163e482 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -874,6 +874,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, stmtblock_t block; gfc_init_block (&block); gfc_ref *ref; + tree maybetmp = NULL_TREE, origdata = NULL_TREE; parmse->ss = ss; parmse->use_offset = 1; @@ -903,8 +904,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, if (e->rank != class_ts.u.derived->components->as->rank) { - gcc_assert (class_ts.u.derived->components->as->type - == AS_ASSUMED_RANK); + tree desc; + + desc = parmse->expr; + if (VAR_P (desc) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && !GFC_DECL_PACKED_ARRAY (desc) + && !GFC_DECL_PARTIAL_PACKED_ARRAY (desc)) + { + origdata = gfc_evaluate_now ( + fold_convert (pvoid_type_node, + gfc_conv_descriptor_data_get (desc)), + &block); + tmp = gfc_build_addr_expr (NULL, desc); + tmp = build_call_expr (gfor_fndecl_in_pack, 1, tmp); + maybetmp = gfc_evaluate_now (tmp, &block); + gfc_conv_descriptor_data_set (&block, desc, maybetmp); + /* Add code to free eventually allocated temporary array + from pack. */ + tmp = fold_build2 (NE_EXPR, boolean_type_node, maybetmp, + origdata); + tmp = build3_v (COND_EXPR, tmp, gfc_call_free (maybetmp), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&parmse->post, tmp); + } if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))) { @@ -933,6 +955,11 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, if (derived_array && *derived_array != NULL_TREE) gfc_conv_descriptor_data_set (&block, *derived_array, null_pointer_node); + if (maybetmp) + { + gfc_add_modify (&block, maybetmp, null_pointer_node); + gfc_add_modify (&block, origdata, null_pointer_node); + } tmp = build3_v (COND_EXPR, cond_optional, tmp, gfc_finish_block (&block)); diff --git a/gcc/testsuite/gfortran.dg/pr96992.f90 b/gcc/testsuite/gfortran.dg/pr96992.f90 new file mode 100644 index 00000000000..e4b38ef35f0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr96992.f90 @@ -0,0 +1,66 @@ +! { dg-do run } + +! PR fortran/96992 + +! Contributed by Thomas Koenig <tkoe...@gcc.gnu.org> + +! From the standard: +! An actual argument that represents an element sequence and +! corresponds to a dummy argument that is an array is sequence +! associated with the dummy argument. The rank and shape of the +! actual argument need not agree with the rank and shape of the +! dummy argument, but the number of elements in the dummy argument +! shall not exceed the number of elements in the element sequence +! of the actual argument. If the dummy argument is assumed-size, +! the number of elements in the dummy argument is exactly +! the number of elements in the element sequence. + +! Check that walking the sequence starts with an initialized stride +! for dim == 0. + +module foo_mod + implicit none + type foo + integer :: i + end type foo +contains + subroutine d1(x,n) + integer, intent(in) :: n + integer :: i + class (foo), intent(out), dimension(n) :: x + select type(x) + class is(foo) + x(:)%i = (/ (42 + i, i = 1, n ) /) + class default + stop 1 + end select + end subroutine d1 + subroutine d2(x,n) + integer, intent(in) :: n + integer :: i + class (foo), intent(in), dimension(n,n,n) :: x + select type (x) + class is (foo) + if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop 2 + class default + stop 3 + end select + end subroutine d2 +end module foo_mod +program main + use foo_mod + implicit none + type (foo), dimension(:), allocatable :: f + integer :: n,i + n = 3 + allocate (f(n*n*n)) + call d1(f,n*n*n) + call d2(f,n) + + ! Use negative stride + call d1(f(n*n*n:1:-1),n*n*n) + if ( any( f%i /= (/ (42 + i, i = n ** 3, 1, -1 ) /) )) stop 4 + call d2(f(n*n*n:1:-1),n) + deallocate (f) +end program main + -- 2.45.2