https://gcc.gnu.org/g:b3f681fdd2e483519aad29d8a4be9e3e4e326fd1
commit b3f681fdd2e483519aad29d8a4be9e3e4e326fd1
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Jul 16 17:31:08 2025 +0200
Extraction gfc_copy_sequence_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 38 ++++++++++---------------
gcc/fortran/trans-descriptor.cc | 62 +++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-descriptor.h | 1 +
3 files changed, 77 insertions(+), 24 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 832e8fae8a36..360220b6cfde 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8796,31 +8796,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
if (maybe_shift && !keep_descriptor_lower_bound (expr))
gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+ assumed_rank_fsym = true;
+ else
+ assumed_rank_fsym = false;
+
tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
- {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
- gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- tree tmp2 = gfc_conv_descriptor_dtype_get (se->expr);
- gfc_conv_descriptor_dtype_set (&block, arr, tmp2);
- gfc_conv_descriptor_rank_set (&block, arr, 1);
- gfc_conv_descriptor_span_set (&block, arr,
- gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
- }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+ assumed_rank_fsym);
/* Handle optional. */
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 64fed46c7ab2..625e9aa43464 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
+#include "trans-array.h"
/******************************************************************************/
@@ -978,3 +979,64 @@ gfc_nullify_descriptor (stmtblock_t *block, tree descr)
{
gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
}
+
+
+static int
+descriptor_rank (tree descriptor)
+{
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+ return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = descriptor_rank (lhs_desc);
+ int rhs_rank = descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+ desc = rhs_desc;
+ else
+ {
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_conv_descriptor_dtype_set (&block, arr,
+ gfc_conv_descriptor_dtype_get (rhs_desc));
+ gfc_conv_descriptor_rank_set (&block, arr, lhs_rank);
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ desc = arr;
+ }
+
+ gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 18b1f0109d3a..d997918f05f3 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -104,5 +104,6 @@ void gfc_conv_shift_descriptor (stmtblock_t *, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t *, tree, const gfc_array_ref &);
/* Build a null array descriptor constructor. */
void gfc_nullify_descriptor (stmtblock_t *block, tree);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
#endif /* GFC_TRANS_DESCRIPTOR_H */
