https://gcc.gnu.org/g:ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
commit ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Jan 9 21:38:39 2025 +0100
Extraction fonction fcncall_realloc_result
Correction variable inutilisée
Correction régression coarray dummy_3
Correction régression dummy_3
Diff:
---
gcc/fortran/trans-array.cc | 64 ++++++++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 52 +++++++++++--------------------------
3 files changed, 80 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 898930634ad1..7d43a8c000d3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1451,6 +1451,70 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
}
+class conditional_lb
+{
+ tree cond;
+public:
+ conditional_lb (tree arg_cond)
+ : cond (arg_cond) { }
+
+ tree lower_bound (tree src, int n) const {
+ tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+ lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+ return lbound;
+ }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, const conditional_lb &lb)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tree offset = gfc_index_zero_node;
+ for (int n = 0 ; n < rank; n++)
+ {
+ tree lbound;
+
+ lbound = lb.lower_bound (dest, n);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ tmp = gfc_conv_descriptor_ubound_get (src, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, lbound);
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], tmp);
+
+ /* Set stride and accumulate the offset. */
+ tmp = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[n]);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[n], tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, tmp);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ offset = gfc_evaluate_now (offset, block);
+ }
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, tree zero_cond)
+{
+ gfc_conv_shift_descriptor (block, dest, src, rank,
+ conditional_lb (zero_cond));
+}
+
+
static bool
keep_descriptor_lower_bound (gfc_expr *e)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8df55c2c00a5..571322ae11ff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c50b1e05cdbd..77e8a55af457 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -832,6 +832,9 @@ gfc_get_vptr_from_expr (tree expr)
int
gfc_descriptor_rank (tree descriptor)
{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+ return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
tree dim = gfc_get_descriptor_dimension (descriptor);
tree dim_type = TREE_TYPE (dim);
gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
@@ -916,8 +919,17 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
type = TREE_TYPE (tmp);
else
{
- gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
- type = TREE_TYPE (tmp);
+ int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+ int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+ if (corank > 0 && corank2 == 0)
+ type = TREE_TYPE (tmp2);
+ else if (corank2 > 0 && corank == 0)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
}
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
@@ -11595,7 +11607,6 @@ fcncall_realloc_result (gfc_se *se, int rank, tree
dtype)
tree desc;
tree res_desc;
tree tmp;
- tree offset;
tree zero_cond;
tree not_same_shape;
stmtblock_t shape_block;
@@ -11628,9 +11639,6 @@ fcncall_realloc_result (gfc_se *se, int rank, tree
dtype)
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (&se->post, tmp);
- tmp = gfc_conv_descriptor_data_get (res_desc);
- gfc_conv_descriptor_data_set (&se->post, desc, tmp);
-
/* Check that the shapes are the same between lhs and expression.
The evaluation of the shape is done in 'shape_block' to avoid
unitialized warnings from the lhs bounds. */
@@ -11674,37 +11682,7 @@ fcncall_realloc_result (gfc_se *se, int rank, tree
dtype)
/* Now reset the bounds returned from the function call to bounds based
on the lhs lbounds, except where the lhs is not allocated or the shapes
of 'variable and 'expr' are different. Set the offset accordingly. */
- offset = gfc_index_zero_node;
- for (n = 0 ; n < rank; n++)
- {
- tree lbound;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, zero_cond,
- gfc_index_one_node, lbound);
- lbound = gfc_evaluate_now (lbound, &se->post);
-
- tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, lbound);
- gfc_conv_descriptor_lbound_set (&se->post, desc,
- gfc_rank_cst[n], lbound);
- gfc_conv_descriptor_ubound_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
-
- /* Set stride and accumulate the offset. */
- tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
- gfc_conv_descriptor_stride_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, tmp);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
- offset = gfc_evaluate_now (offset, &se->post);
- }
-
- gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+ gfc_conv_shift_descriptor (&se->post, desc, res_desc, rank, zero_cond);
}
