https://gcc.gnu.org/g:837eb01ed7035de0cc44aa66c956492554db614b
commit 837eb01ed7035de0cc44aa66c956492554db614b
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Apr 11 10:32:11 2025 +0200
Correction ICEs PR95331
Diff:
---
gcc/fortran/trans-array.cc | 125 +++++++++++++++++++++++-----------------
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-descriptor.cc | 6 +-
gcc/fortran/trans-expr.cc | 2 +-
gcc/fortran/trans-types.cc | 10 +++-
gcc/fortran/trans.cc | 26 ++++-----
6 files changed, 97 insertions(+), 74 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5014c1aa8731..c846b2c2a1ef 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3092,7 +3092,8 @@ gfc_conv_array_spacing (tree descriptor, int dim)
/* For descriptorless arrays use the array size. */
tmp = GFC_TYPE_ARRAY_SPACING (type, dim);
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
tmp = gfc_conv_descriptor_spacing_get (descriptor, gfc_rank_cst[dim]);
@@ -3111,7 +3112,8 @@ gfc_conv_array_lbound (tree descriptor, int dim)
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
@@ -3130,7 +3132,8 @@ gfc_conv_array_ubound (tree descriptor, int dim)
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
/* This should only ever happen when passing an assumed shape array
@@ -3477,15 +3480,37 @@ non_negative_strides_array_p (tree expr)
static tree
-build_array_ref (tree desc, tree offset)
+build_array_ref (tree descriptor, tree array, tree index,
+ bool non_negative_stride, tree lbound, tree spacing,
+ const vec<tree> * array_type_domains)
{
- tree tmp;
+ tree elt_type = NULL_TREE;
+ if (!array_type_domains || array_type_domains->is_empty ())
+ elt_type = TREE_TYPE (TREE_TYPE (array));
+ else
+ {
+ tree desc_type = TREE_TYPE (descriptor);
+ tree core_type = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (desc_type));
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ unsigned j;
+ tree *dom_p;
+ FOR_EACH_VEC_ELT (*array_type_domains, j, dom_p)
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (core_type)
+ && TYPE_DOMAIN (core_type) == *dom_p);
+ core_type = TREE_TYPE (core_type);
+ }
- tmp = gfc_build_array_ref (tmp, offset, non_negative_strides_array_p (desc));
- return tmp;
+ core_type = TREE_TYPE (core_type);
+
+ tree elt_type = core_type;
+
+ FOR_EACH_VEC_ELT_REVERSE (*array_type_domains, j, dom_p)
+ elt_type = build_array_type (elt_type, *dom_p);
+ }
+
+ return gfc_build_array_ref (elt_type, array, index, non_negative_stride,
+ lbound, spacing);
}
@@ -3797,39 +3822,14 @@ add_array_index (stmtblock_t *pblock, gfc_loopinfo
*loop, gfc_ss *ss,
tree index = fold_convert_loc (input_location, gfc_array_index_type, tmp);
- tree elt_type = NULL_TREE;
- if (!array_type_domains || array_type_domains->is_empty ())
- elt_type = TREE_TYPE (array);
- else
- {
- tree desc_type = TREE_TYPE (info->descriptor);
- tree core_type = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (desc_type));
-
- unsigned j;
- tree *dom_p;
- FOR_EACH_VEC_ELT (*array_type_domains, j, dom_p)
- {
- gcc_assert (GFC_ARRAY_TYPE_P (core_type)
- && TYPE_DOMAIN (core_type) == *dom_p);
- core_type = TREE_TYPE (core_type);
- }
-
- core_type = TREE_TYPE (core_type);
-
- tree elt_type = core_type;
-
- FOR_EACH_VEC_ELT_REVERSE (*array_type_domains, j, dom_p)
- elt_type = build_array_type (elt_type, *dom_p);
- }
-
gfc_ss_type ss_type = ss->info->type;
bool non_negative_stride = ss_type == GFC_SS_FUNCTION
|| ss_type == GFC_SS_CONSTRUCTOR
|| ss_type == GFC_SS_INTRINSIC
|| non_negative_strides_array_p (info->descriptor);
- return gfc_build_array_ref (elt_type, array, index,
- non_negative_stride, info->lbound[array_dim],
- info->spacing[array_dim]);
+ return build_array_ref (info->descriptor, array, index, non_negative_stride,
+ info->lbound[array_dim], info->spacing[array_dim],
+ array_type_domains);
}
@@ -3896,7 +3896,7 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim,
int flag,
gcc_assert (0 == ploop->order[0]);
info->spacing0 = gfc_conv_array_spacing (info->descriptor, 0);
- info->spacing0 = gfc_evaluate_now (info->spacing0, &loop->pre);
+ info->spacing0 = gfc_evaluate_now (info->spacing0, pblock);
if (info->ref)
{
@@ -3909,7 +3909,7 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim,
int flag,
{
if (ar->dimen_type[i] == DIMEN_ELEMENT)
array = add_array_index (pblock, ploop, ss, array, ar,
- pss->dim[i], i, &domains);
+ i, -1 /* unused */, &domains);
else
domains.safe_push (TYPE_DOMAIN (array_type));
@@ -4321,9 +4321,6 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss
* ss, int dim)
evaluate_bound (block, info->end, ar->end, desc, dim, false,
ar->as->type == AS_DEFERRED, save_value);
- evaluate_bound (block, info->lbound, nullptr, desc, dim, true,
- ar->as->type == AS_DEFERRED, save_value);
-
/* Calculate the stride. */
if (stride == NULL)
info->stride[dim] = gfc_index_one_node;
@@ -4341,6 +4338,20 @@ gfc_conv_section_startstride (stmtblock_t * block,
gfc_ss * ss, int dim)
}
+static void
+conv_evaluate_lbound (stmtblock_t * block, gfc_ss * ss, int dim)
+{
+ gcc_assert (ss->info->type == GFC_SS_SECTION);
+
+ gfc_array_info *info = &ss->info->data.array;
+ gfc_array_ref *ar = &info->ref->u.ar;
+ tree desc = info->descriptor;
+
+ evaluate_bound (block, info->lbound, nullptr, desc, dim, true,
+ ar->as->type == AS_DEFERRED, !ss->is_alloc_lhs);
+}
+
+
/* Generate in INNER the bounds checking code along the dimension DIM for
the array associated with SS_INFO. */
@@ -4592,7 +4603,13 @@ done:
{
gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
conv_array_spacing (&outer_loop->pre, ss, ss->dim[n]);
+ conv_evaluate_lbound (&outer_loop->pre, ss, ss->dim[n]);
}
+ if (loop->parent == nullptr)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ if (info->subscript[n]
+ && info->subscript[n]->info->type == GFC_SS_SCALAR)
+ conv_evaluate_lbound (&outer_loop->pre, ss, n);
break;
case GFC_SS_INTRINSIC:
@@ -6844,10 +6861,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree
tmpdesc,
/* Calculate the overall offset, including subreferences. */
void
-gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc,
bool subref, gfc_expr *expr)
{
- tree tmp;
tree field;
tree stride;
tree index;
@@ -6855,17 +6871,20 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm,
tree desc, tree offset,
gfc_se start;
int n;
- /* If offset is NULL and this is not a subreferenced array, there is
- nothing to do. */
- if (offset == NULL_TREE)
+ tree offset = gfc_index_zero_node;
+
+ bool non_negative_strides = non_negative_strides_array_p (desc);
+
+ tree tmp = gfc_conv_array_data (desc);
+ tree array = build_fold_indirect_ref_loc (input_location, tmp);
+
+ for (int i = GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)) - 1; i >= 0; i--)
{
- if (subref)
- offset = gfc_index_zero_node;
- else
- return;
+ array = build_array_ref (desc, array, gfc_index_zero_node,
+ non_negative_strides, gfc_index_zero_node,
+ NULL_TREE, nullptr);
}
-
- tmp = build_array_ref (desc, offset);
+ tmp = array;
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index d52c1a859459..73322a227a5f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,7 +147,7 @@ void gfc_conv_array_ref (gfc_se *, gfc_array_ref *,
gfc_expr *, locus *);
void gfc_conv_tmp_array_ref (gfc_se * se);
/* Calculate the overall offset, including subreferences. */
-void gfc_get_dataptr_offset (stmtblock_t*, tree, tree, tree, bool, gfc_expr*);
+void gfc_get_dataptr_offset (stmtblock_t*, tree, tree, bool, gfc_expr*);
/* Obtain the span of an array. */
tree gfc_get_array_span (tree, gfc_expr *);
/* Evaluate an array expression. */
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 699f29cd6137..4bbc05be7a4e 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -2514,7 +2514,8 @@ gfc_copy_descriptor (stmtblock_t *block, tree dest, tree
src,
gfc_add_modify (block, dest, tmp1);
/* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+ if (subref)
+ gfc_get_dataptr_offset (block, dest, src, subref, src_expr);
/* ....and set the span field. */
tree tmp2;
@@ -3183,8 +3184,7 @@ gfc_set_descriptor (stmtblock_t *block, tree dest, tree
src, gfc_expr *src_expr,
if (data_needed)
/* Point the data pointer at the 1st element in the section. */
- gfc_get_dataptr_offset (block, dest, src, gfc_index_zero_node,
- subref, src_expr);
+ gfc_get_dataptr_offset (block, dest, src, subref, src_expr);
else
gfc_conv_descriptor_data_set (block, dest,
gfc_index_zero_node);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 37fdda7e0cdd..2dcb684e326a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5938,7 +5938,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr
*e, gfc_symbol *fsym)
if (POINTER_TYPE_P (TREE_TYPE (gfc)))
gfc = build_fold_indirect_ref_loc (input_location, gfc);
else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
- gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
+ gfc_get_dataptr_offset (&se.pre, gfc, gfc, true, e);
}
if (e->ts.type == BT_CHARACTER)
{
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index f559b2bd384f..4661ff92fa8d 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1445,8 +1445,14 @@ gfc_get_element_type (tree type)
}
else
{
- gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- element = TREE_TYPE (type);
+ int rank = GFC_TYPE_ARRAY_RANK (type);
+ for (int i = 0; i < rank; i++)
+ {
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ type = TREE_TYPE (type);
+ }
+
+ element = type;
}
}
else
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index c77bd72b3fb2..c59ebbdaf7bd 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -413,7 +413,7 @@ gfc_build_spanned_array_ref (tree base, tree offset, tree
span)
tree
gfc_build_array_ref (tree type, tree base, tree index, bool
non_negative_offset,
- tree offset, tree spacing)
+ tree min_val, tree spacing)
{
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
@@ -422,22 +422,15 @@ gfc_build_array_ref (tree type, tree base, tree index,
bool non_negative_offset,
STRIP_TYPE_NOPS (index);
if (non_negative_offset)
- {
- tree min_val = offset ? fold_build1_loc (input_location, NEGATE_EXPR,
- gfc_array_index_type, offset)
- : NULL_TREE;
- return build4_loc (input_location, ARRAY_REF, type, base, index,
- min_val, spacing);
- }
+ return build4_loc (input_location, ARRAY_REF, type, base, index,
+ min_val, spacing);
/* Otherwise use pointer arithmetic. */
else
{
gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
- tree min = NULL_TREE;
- if (offset != NULL_TREE)
- min = fold_build1_loc (input_location, NEGATE_EXPR,
- gfc_array_index_type, offset);
- else if (TYPE_DOMAIN (TREE_TYPE (base)))
+ tree min = min_val;
+ if (min == NULL_TREE
+ && TYPE_DOMAIN (TREE_TYPE (base)))
min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)));
tree zero_based_index
@@ -448,9 +441,14 @@ gfc_build_array_ref (tree type, tree base, tree index,
bool non_negative_offset,
fold_convert (gfc_array_index_type, min))
: fold_convert (gfc_array_index_type, index);
+ tree delta = spacing;
+ if (delta == NULL_TREE)
+ delta = fold_convert_loc (input_location, gfc_array_index_type,
+ TYPE_SIZE_UNIT (type));
+
tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- zero_based_index, spacing);
+ zero_based_index, delta);
offset_bytes = fold_convert_loc (input_location, sizetype,
offset_bytes);
