https://gcc.gnu.org/g:584a8ddc06a8fcba45b6cb141236d579acec8435
commit 584a8ddc06a8fcba45b6cb141236d579acec8435
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Feb 6 17:16:13 2025 +0100
Factorisation gfc_conv_shift_descriptor
Correction compil'
Correction régression allocated_4.f90
Factorisation gfc_conv_shift_descriptor.
Correction régression allocated_4.f90
Modifications mineures
Correction régression bound_10.f90
Correction régression alloc_comp_constructor_1.f90
Correction régression realloc_on_assign_10
Revert "Correction régression realloc_on_assign_10"
This reverts commit 007ca869933eb74b76398200ef0237219ba01cd8.
Correction régression realloc_on_assign_11.f90
Diff:
---
gcc/fortran/trans-array.cc | 165 ++++++++++++++++++++++-----------------------
gcc/fortran/trans-expr.cc | 15 ++++-
2 files changed, 94 insertions(+), 86 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 77e1e1abea4f..bbcba5c5bcca 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1478,35 +1478,43 @@ gfc_build_null_descriptor (tree type)
specified. This also updates ubound and offset accordingly. */
static void
-conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
- tree new_lbound, tree offset)
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
+ tree new_lbound, tree offset, bool zero_based)
{
- tree ubound, lbound, stride;
- tree diff, offs_diff;
-
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+ new_lbound = gfc_evaluate_now (new_lbound, block);
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ tree stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
- /* Get difference (new - old) by which to shift stuff. */
- diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- new_lbound, lbound);
+ tree diff;
+ if (zero_based)
+ diff = new_lbound;
+ else
+ {
+ /* Get difference (new - old) by which to shift stuff. */
+ diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ new_lbound, lbound);
+ diff = gfc_evaluate_now (diff, block);
+ }
/* Shift ubound and offset accordingly. This has to be done before
updating the lbound, as they depend on the lbound expression! */
- ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- ubound, diff);
- gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
- offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- diff, stride);
- tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, offs_diff);
- gfc_add_modify (block, offset, tmp);
+ tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, diff);
+ gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
+ /* Set lbound to the value we want. */
+ gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
- /* Finally set lbound to value we want. */
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+ tree offs_diff = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
+ diff, stride);
+ tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp2);
+
+ if (from_desc != to_desc)
+ gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank_cst[dim], stride);
}
@@ -1514,6 +1522,7 @@ class lb_info_base
{
public:
virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+ virtual bool zero_based_src () const { return false; }
};
@@ -1574,21 +1583,64 @@ public:
static void
-conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
const lb_info_base &info)
{
- tree tmp = gfc_conv_descriptor_offset_get (desc);
- tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
- gfc_add_modify (block, offset_var, tmp);
+ if (src != dest)
+ {
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+ }
+
+ tree offset_var = gfc_create_var (gfc_array_index_type, "offset");
+ tree init_offset;
+ if (info.zero_based_src ())
+ init_offset = gfc_index_zero_node;
+ else
+ init_offset = gfc_conv_descriptor_offset_get (src);
+ gfc_add_modify (block, offset_var, init_offset);
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
tree lower_bound = info.lower_bound (block, dim);
- conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
+ conv_shift_descriptor_lbound (block, src, dest, dim, lower_bound,
offset_var,
+ info.zero_based_src ());
}
- gfc_conv_descriptor_offset_set (block, desc, offset_var);
+ gfc_conv_descriptor_offset_set (block, dest, offset_var);
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info_base &info)
+{
+ conv_shift_descriptor (block, desc, desc, rank, info);
+}
+
+
+class cond_descr_lb : public lb_info_base
+{
+ tree desc;
+ tree cond;
+public:
+ cond_descr_lb (tree arg_desc, tree arg_cond)
+ : desc (arg_desc), cond (arg_cond) { }
+
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+ virtual bool zero_based_src () const { return true; }
+};
+
+
+tree
+cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED, int dim) const
+{
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+ return lbound;
}
@@ -1861,67 +1913,12 @@ 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));
+ conv_shift_descriptor (block, src, dest, rank,
+ cond_descr_lb (dest, zero_cond));
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2373f267169f..331b45cdbd60 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9511,11 +9511,22 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
+ stmtblock_t shift_block;
+ gfc_init_block (&shift_block);
+ gfc_conv_shift_descriptor_subarray (&shift_block, dest, expr, arg);
+
+ tree data = gfc_conv_descriptor_data_get (se.expr);
+ data = fold_convert (pvoid_type_node, data);
+ tree non_null = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ data, null_pointer_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ non_null, gfc_finish_block (&shift_block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
- gfc_conv_shift_descriptor_subarray (&block, dest, expr, arg);
-
if (arg)
{
/* If a conversion expression has a null data pointer
