[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_copy_sequence_descriptor

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:f90f6f2d65980c675903c9d931b3312a89e5f269

commit f90f6f2d65980c675903c9d931b3312a89e5f269
Author: Mikael Morin <mik...@gcc.gnu.org>
Date:   Tue Dec 31 15:27:35 2024 +0100

    Introduction gfc_copy_sequence_descriptor

Diff:
---
 gcc/fortran/trans-array.cc | 26 +-------------------------
 gcc/fortran/trans-expr.cc  | 43 +++++++++++++++++++++++++++++++++++++++++++
 gcc/fortran/trans.h        |  1 +
 3 files changed, 45 insertions(+), 25 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4c237b561aa6..d42575c38485 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9902,31 +9902,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, 
bool g77,
            conv_shift_descriptor (&block, se->expr, expr->rank);
 
          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));
-             gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
-                             gfc_conv_descriptor_dtype (se->expr));
-             gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
-                             build_int_cst (signed_char_type_node, 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);
 
          /* Handle optional.  */
          if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 003754cdad6f..09a8fc9dd5dd 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -846,6 +846,49 @@ descriptor_rank (tree descriptor)
 }
 
 
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc)
+{
+  int lhs_rank = descriptor_rank (lhs_desc);
+  int rhs_rank = descriptor_rank (rhs_desc);
+  tree desc;
+
+  if (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_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+                     gfc_conv_descriptor_dtype (rhs_desc));
+      gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+                     build_int_cst (signed_char_type_node, 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);
+}
+
+
 void
 gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
                             bool)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 449d2b3026c0..544cf3fb6497 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -465,6 +465,7 @@ void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, 
symbol_attribute, int);
 bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
 
 void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree);
 void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
                                bool, bool, const char *, tree * = nullptr);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,