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 <[email protected]> wrote:
<< snipped for brevity >>>
--
Andre Vehreschild * Email: vehre ad gmx dot de
From c0c95afa95bb682385e47cc248f04e6eecd91e6d Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
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 <[email protected]>
+
+! 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
