See the attached patch.
Regression tested on x86_64-pc-linux-gnu. OK for master?
This fixes a 13 regression, even though the code fixed here is much
older than the regression.
OK for backporting down to 13 branch as well?
From 3cafcbd221a317f6f65d7778e5c9ff278e02b462 Mon Sep 17 00:00:00 2001
From: Mikael Morin <[email protected]>
Date: Mon, 29 Jun 2026 21:33:01 +0200
Subject: [PATCH] fortran: Don't reuse original descriptors for packed arrays
[PR125998]
Don't try to reuse the original descriptor when creating a descriptor
for packed data in gfc_conv_array_parameter.
For a non-transposed array (anything but TRANSPOSE(VAR)) the original
descriptor was reused, and only the data was reset to the result of
packing. This is wrong because the original descriptor can be
non-contiguous, it can't be correct as the descriptor of packed data.
In the testcase, a dummy array associated with a transposed array actual
argument matches this case. Reusing the descriptor in that case would
cause the packed data to be used transposed, that is not in the normal
array element order. This change removes this case to always fallback
to what was previously the transposed case (see next).
For the transposed case (TRANSPOSE(VAR)), the full dimensions of the
original untransposed descriptor were reused (in other words, the
dimensions of VAR). This is wrong because packing doesn't change the
shape, so the packed array should have the same bounds as the bounds
of TRANSPOSE(VAR), not the same bounds as VAR. Reusing the strides of
an unpacked array for a packed array doesn't seem right either. This
change uses matching dimensions when copying from the original
descriptor, and only copies the lbound and ubound. The strides are
recalculated. And then the offset is recalculated as well (even though
I couldn't find a testcase where it made a difference).
PR fortran/97592
PR fortran/125998
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_conv_array_parameter): Always create a new
descriptor. Copy lbound and ubound from the original descriptor
using matching dimension indexes. Recalculate stride and
offset.
gcc/testsuite/ChangeLog:
* gfortran.dg/contiguous_17.f90: New test.
---
gcc/fortran/trans-array.cc | 65 ++++--
gcc/testsuite/gfortran.dg/contiguous_17.f90 | 229 ++++++++++++++++++++
2 files changed, 277 insertions(+), 17 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/contiguous_17.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ebd04c53b9d..181f4c68562 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9766,14 +9766,10 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
{
tmp = build_fold_indirect_ref_loc (input_location, desc);
- gfc_ss * ss = gfc_walk_expr (expr);
- if (!transposed_dims (ss) && expr->rank != -1)
- {
- if (!ctree)
- gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
- }
- else if (!ctree)
+ if (!ctree)
{
+ /* The original descriptor may have transposed dims so we
+ can't reuse it directly; we have to create a new one. */
tree old_field, new_field;
tree old_desc = tmp;
tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
@@ -9838,19 +9834,55 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
}
else
{
- /* The original descriptor has transposed dims so we can't
- reuse it directly; we have to create a new one. */
- old_field = gfc_conv_descriptor_offset_get (old_desc);
- gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
+ tree offset = gfc_index_zero_node;
+
+ tree stride = gfc_index_one_node;
for (int i = 0; i < expr->rank; i++)
{
- old_field = gfc_conv_descriptor_dimension (old_desc,
- gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
- new_field = gfc_conv_descriptor_dimension (new_desc,
- gfc_rank_cst[i]);
- gfc_add_modify (&se->pre, new_field, old_field);
+ tree dim = gfc_rank_cst[i];
+
+ tree lbound = gfc_conv_descriptor_lbound_get (old_desc,
+ dim);
+ lbound = gfc_evaluate_now (lbound, &se->pre);
+ gfc_conv_descriptor_lbound_set (&se->pre, new_desc, dim,
+ lbound);
+
+ tree ubound = gfc_conv_descriptor_ubound_get (old_desc,
+ dim);
+ ubound = gfc_evaluate_now (ubound, &se->pre);
+ gfc_conv_descriptor_ubound_set (&se->pre, new_desc, dim,
+ ubound);
+
+ gfc_conv_descriptor_stride_set (&se->pre, new_desc, dim,
+ stride);
+
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ stride, lbound);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp);
+ offset = gfc_evaluate_now (offset, &se->pre);
+
+ /* Now calculate the stride for next dimension, unless the
+ current dimension is the last one. */
+ if (i == expr->rank - 1)
+ break;
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ lbound, gfc_index_one_node);
+ tree extent = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ ubound, tmp);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ stride, extent);
+ stride = gfc_evaluate_now (stride, &se->pre);
}
+
+ gfc_conv_descriptor_offset_set (&se->pre, new_desc, offset);
}
if (flag_coarray == GFC_FCOARRAY_LIB
@@ -9866,7 +9898,6 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
}
- gfc_free_ss (ss);
}
if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
diff --git a/gcc/testsuite/gfortran.dg/contiguous_17.f90 b/gcc/testsuite/gfortran.dg/contiguous_17.f90
new file mode 100644
index 00000000000..0fd27b1d41e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_17.f90
@@ -0,0 +1,229 @@
+! { dg-do run }
+!
+! PR fortran/125998
+! Check the correct passing of a transposed array to an assumed-shape dummy
+! having the contiguous and target attributes.
+!
+! Original testcase from Federico Perini <[email protected]>
+
+subroutine original
+ real(8) :: a(3,4)
+ integer :: dims(2)
+ character(48) :: iomsg
+ call show(transpose(a),dims)
+ if (any(dims/=shape(transpose(a)))) then
+ write(iomsg,1) 'invalid a^T dims',dims, &
+ ' should be',shape(transpose(a))
+ error stop iomsg
+ endif
+ 1 format(*(a,' [',i0,',',i0,']'))
+
+contains
+
+ subroutine show(x,dims)
+ ! "3 4" with `contiguous` (BUG); "4 3" without
+ real(8), intent(in), target, contiguous :: x(:,:)
+ integer, intent(out) :: dims(2)
+ dims = [size(x,1),size(x,2)]
+ end
+
+end
+
+module m
+ implicit none
+ private
+ public :: check_all
+
+contains
+
+ subroutine abort_different(lx,x,ly,y,code)
+ character(*), intent(in) :: lx, ly
+ integer, intent(in) :: x(..), y(..), code
+ write(6,'(a," /= ",a)') lx, ly
+ select rank(x)
+ rank(1)
+ write(6,3) lx
+ write(6,*) x
+ rank(2)
+ write(6,3) lx
+ write(6,*) x
+ rank default
+ end select
+ select rank(y)
+ rank(1)
+ write(6,3) ly
+ write(6,*) y
+ rank(2)
+ write(6,3) ly
+ write(6,*) y
+ rank default
+ end select
+ error stop code
+ 3 format(a,":")
+ end subroutine
+
+ subroutine check_target(x,expected,num_error)
+ integer, intent(in), target, contiguous :: x(:,:)
+ integer, intent(in) :: num_error, expected(:,:)
+ if (any(shape(x) /= shape(expected))) then
+ call abort_different( &
+ "shape(x)",shape(x), &
+ "shape(expected)",shape(expected), &
+ num_error*10+1 &
+ )
+ end if
+ if (any(x /= expected)) then
+ call abort_different("x",x,"expected",expected,num_error*10+2)
+ end if
+ if (x(2,2) /= expected(2,2)) then
+ call abort_different( &
+ "x(2,2)",x(2,2), &
+ "expected(2,2)",expected(2,2), &
+ num_error*10+3 &
+ )
+ end if
+ end
+
+ subroutine check_non_target(x,expected,num_error)
+ integer, intent(in), contiguous :: x(:,:)
+ integer, intent(in) :: num_error, expected(:,:)
+ if (any(shape(x) /= shape(expected))) then
+ call abort_different( &
+ "shape(x)",shape(x), &
+ "shape(expected)",shape(expected), &
+ num_error*10+1 &
+ )
+ end if
+ if (any(x /= expected)) then
+ call abort_different("x",x,"expected",expected,num_error*10+2)
+ end if
+ if (x(2,2) /= expected(2,2)) then
+ call abort_different( &
+ "x(2,2)",x(2,2), &
+ "expected(2,2)",expected(2,2), &
+ num_error*10+3 &
+ )
+ end if
+ end
+
+ subroutine wrapper_target(x,expected,num_error)
+ integer, intent(in), target :: x(:,:)
+ integer, intent(in) :: expected(:,:)
+ integer, intent(in) :: num_error
+ call check_target(x,expected,num_error)
+ end subroutine
+
+ subroutine wrapper_non_target(x,expected,num_error)
+ integer, intent(in) :: x(:,:), expected(:,:)
+ integer, intent(in) :: num_error
+ call check_non_target(x,expected,num_error)
+ end subroutine
+
+ subroutine wrapper_transpose_target(x,expected,num_error)
+ integer, intent(in), target :: x(:,:)
+ integer, intent(in) :: expected(:,:)
+ integer, intent(in) :: num_error
+ call check_target(transpose(x),expected,num_error)
+ end subroutine
+
+ subroutine wrapper_transpose_non_target(x,expected,num_error)
+ integer, intent(in) :: x(:,:), expected(:,:)
+ integer, intent(in) :: num_error
+ call check_non_target(transpose(x),expected,num_error)
+ end subroutine
+
+ subroutine check_all
+ integer :: a(3,4)
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call check_target( &
+ transpose(a), &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 1 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call check_non_target( &
+ transpose(a), &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 2 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_target( &
+ transpose(a), &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 3 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_non_target( &
+ transpose(a), &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 4 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_transpose_target( &
+ a, &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 5 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_transpose_non_target( &
+ a, &
+ reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), &
+ 6 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_transpose_target( &
+ transpose(a), &
+ reshape([0,1,1,2,3,5,8,13,21,34,55,89],[3,4]), &
+ 7 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_transpose_non_target( &
+ transpose(a), &
+ reshape([0,1,1,2,3,5,8,13,21,34,55,89],[3,4]), &
+ 8 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call check_target( &
+ a(::2,::2), &
+ reshape([0,1,8,21],[2,2]), &
+ 9 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call check_non_target( &
+ a(::2,::2), &
+ reshape([0,1,8,21],[2,2]), &
+ 10 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_target( &
+ a(::2,::2), &
+ reshape([0,1,8,21],[2,2]), &
+ 11 &
+ )
+
+ a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a))
+ call wrapper_non_target( &
+ a(::2,::2), &
+ reshape([0,1,8,21],[2,2]), &
+ 12 &
+ )
+
+ end subroutine
+
+end module
+
+use m
+call original
+call check_all
+end
--
2.53.0
