https://gcc.gnu.org/g:64d856d109db13b1f5dccbe2f9ac6447d659ee8b
commit 64d856d109db13b1f5dccbe2f9ac6447d659ee8b Author: Mikael Morin <[email protected]> Date: Wed Jul 22 21:40:38 2026 +0200 Refactoring gfc_set_descriptor_from_scalar Correction pr87992.f90 Correction artefact conflit rebase Correction artefact conflit rebase Déplacement shift descriptor vers gfc_conv_array_parameter Suppression variables inutilisées Diff: --- gcc/fortran/trans-array.cc | 39 ++++++++++++++---- gcc/fortran/trans-array.h | 2 +- gcc/fortran/trans-descriptor.cc | 91 +++++++++++++++++++++-------------------- gcc/fortran/trans-descriptor.h | 6 ++- gcc/fortran/trans-expr.cc | 22 +--------- gcc/fortran/trans-types.cc | 6 +-- 6 files changed, 88 insertions(+), 78 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index b719d67f71bc..067458680af8 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -216,6 +216,33 @@ gfc_get_cfi_dim_sm (tree desc, tree idx) #undef CFI_DIM_FIELD_SM +static bool +keep_descriptor_lower_bound (gfc_expr *e) +{ + gfc_ref *ref; + + /* Detect any array references with vector subscripts. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT + && ref->u.ar.type != AR_FULL) + { + int dim; + for (dim = 0; dim < ref->u.ar.dimen; dim++) + if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + break; + if (dim < ref->u.ar.dimen) + break; + } + + /* Array references with vector subscripts and non-variable + expressions need be converted to a one-based descriptor. */ + if (ref || e->expr_type != EXPR_VARIABLE) + return false; + + return true; +} + + /* Mark a SS chain as used. Flags specifies in which loops the SS is used. flags & 1 = Main loop body. flags & 2 = temp copy loop. */ @@ -8838,7 +8865,7 @@ gfc_resize_assumed_rank_dim_field (gfc_se *se, stmtblock_t *block, tree desc) void gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, const gfc_symbol *fsym, const char *proc_name, - tree *size, tree *lbshift, tree *packed) + tree *size, bool maybe_shift, tree *packed) { tree ptr; tree desc; @@ -9075,13 +9102,9 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, stmtblock_t block; gfc_init_block (&block); - if (lbshift && *lbshift) - { - /* Apply a shift of the lbound when supplied. */ - for (int dim = 0; dim < expr->rank; ++dim) - gfc_conv_shift_descriptor_lbound (&block, se->expr, dim, - *lbshift); - } + if (maybe_shift && !keep_descriptor_lower_bound (expr)) + gfc_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) diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index c0afccb28e2b..1dde17d42b21 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -152,7 +152,7 @@ tree gfc_get_array_span (tree, gfc_expr *); void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *); /* Convert an array for passing as an actual function parameter. */ void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *, - const char *, tree *, tree * = nullptr, + const char *, tree *, bool = false, tree * = nullptr); /* These work with both descriptors and descriptorless arrays. */ diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc index 625047112c7b..7425e5cdbd04 100644 --- a/gcc/fortran/trans-descriptor.cc +++ b/gcc/fortran/trans-descriptor.cc @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "trans-types.h" #include "trans-array.h" +#include "trans-descriptor.h" /* Array descriptor low level access routines. @@ -645,15 +646,16 @@ gfc_build_dtype_constructor (tree size, int type, int rank) tree field; vec<constructor_elt, va_gc> *v = NULL; - gcc_assert (size); - - STRIP_NOPS (size); - size = fold_convert (size_type_node, size); tree dtype_type_node = get_dtype_type_node (); - field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), - GFC_DTYPE_ELEM_LEN); - CONSTRUCTOR_APPEND_ELT (v, field, - fold_convert (TREE_TYPE (field), size)); + if (size) + { + STRIP_NOPS (size); + size = fold_convert (size_type_node, size); + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_ELEM_LEN); + CONSTRUCTOR_APPEND_ELT (v, field, + fold_convert (TREE_TYPE (field), size)); + } field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), GFC_DTYPE_VERSION); CONSTRUCTOR_APPEND_ELT (v, field, @@ -996,19 +998,37 @@ gfc_create_null_actual_descriptor (stmtblock_t *block, gfc_typespec *ts, void -gfc_set_descriptor_from_scalar_class (stmtblock_t *block, tree descr, - tree scalar, gfc_expr *scalar_expr) +gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, tree scalar, + symbol_attribute attr, tree cond_presence, + tree caf_token) { - tree type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), - gfc_expr_attr (scalar_expr)); - gfc_conv_descriptor_dtype_set (block, descr, - gfc_get_dtype (type)); + if (flag_coarray == GFC_FCOARRAY_LIB && caf_token) + gfc_conv_descriptor_token_set (block, descr, caf_token); - tree tmp = gfc_class_data_get (scalar); - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + tree type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), attr); + if (!POINTER_TYPE_P (TREE_TYPE (scalar))) + scalar = gfc_build_addr_expr (NULL_TREE, scalar); + if (cond_presence) + scalar = build3_loc (input_location, COND_EXPR, + TREE_TYPE (scalar), + cond_presence, scalar, + fold_convert (TREE_TYPE (scalar), + null_pointer_node)); - gfc_conv_descriptor_data_set (block, descr, tmp); + gfc_conv_descriptor_dtype_set (block, descr, gfc_get_dtype (type)); + gfc_copy_coarray_desc_part (block, descr, scalar); + gfc_conv_descriptor_data_set (block, descr, scalar); + gfc_conv_descriptor_span_set (block, descr, + gfc_conv_descriptor_elem_len_get (descr)); +} + + +void +gfc_set_descriptor_from_scalar_class (stmtblock_t *block, tree descr, + tree scalar, gfc_expr *scalar_expr) +{ + gfc_set_descriptor_from_scalar (block, descr, gfc_class_data_get (scalar), + gfc_expr_attr (scalar_expr)); } @@ -1050,36 +1070,17 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, tree scalar, gfc_expr *scalar_expr, tree cond_presence, tree caf_token) { - if (flag_coarray == GFC_FCOARRAY_LIB && caf_token) - gfc_conv_descriptor_token_set (block, descr, caf_token); - - tree type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), - gfc_expr_attr (scalar_expr)); - gfc_conv_descriptor_dtype_set (block, descr, - gfc_get_dtype (type)); - gfc_copy_coarray_desc_part (block, descr, scalar); - if (cond_presence) - scalar = build3_loc (input_location, COND_EXPR, - TREE_TYPE (scalar), - cond_presence, scalar, - fold_convert (TREE_TYPE (scalar), - null_pointer_node)); - gfc_conv_descriptor_data_set (block, descr, scalar); + gfc_set_descriptor_from_scalar (block, descr, scalar, + gfc_expr_attr (scalar_expr), cond_presence, + caf_token); } void -gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, tree scalar) +gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank) { - tree etype = TREE_TYPE (scalar); - if (!POINTER_TYPE_P (TREE_TYPE (scalar))) - scalar = gfc_build_addr_expr (NULL_TREE, scalar); - else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE) - etype = TREE_TYPE (etype); - - gfc_conv_descriptor_dtype_set (block, descr, - gfc_get_dtype_rank_type (0, etype)); - gfc_conv_descriptor_data_set (block, descr, scalar); - gfc_conv_descriptor_span_set (block, descr, - gfc_conv_descriptor_elem_len_get (descr)); + /* Apply a shift of the lbound when supplied. */ + for (int dim = 0; dim < rank; ++dim) + gfc_conv_shift_descriptor_lbound (block, desc, dim, + gfc_index_one_node); } diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h index b986aa208a77..637221025f56 100644 --- a/gcc/fortran/trans-descriptor.h +++ b/gcc/fortran/trans-descriptor.h @@ -85,8 +85,12 @@ void gfc_init_descriptor_variable (stmtblock_t *block, gfc_symbol *sym, tree des void gfc_copy_coarray_desc_part (stmtblock_t *, tree, tree); +void gfc_conv_shift_descriptor_lbound (stmtblock_t *, tree, int, tree); +void gfc_conv_shift_descriptor (stmtblock_t *, tree, int); + void gfc_set_descriptor_from_scalar_class (stmtblock_t *, tree, tree, gfc_expr *); -void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree); +void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree, symbol_attribute, + tree = NULL_TREE, tree = NULL_TREE); void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree, gfc_expr *, tree, tree); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 48f62feaa639..ba8097f34b9a 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -108,7 +108,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) scalar = tmp; } - gfc_set_descriptor_from_scalar (&se->pre, desc, scalar); + gfc_set_descriptor_from_scalar (&se->pre, desc, scalar, attr); /* Copy pointer address back - but only if it could have changed and if the actual argument is a pointer and not, e.g., NULL(). */ @@ -920,8 +920,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym, stmtblock_t block; gfc_init_block (&block); gfc_ref *ref; - int dim; - tree lbshift = NULL_TREE; /* Array refs with sections indicate, that a for a formal argument expecting contiguous repacking needs to be done. */ @@ -934,25 +932,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym, && (ref || e->rank != fsym->ts.u.derived->components->as->rank)) fsym->attr.contiguous = 1; - /* Detect any array references with vector subscripts. */ - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT - && ref->u.ar.type != AR_FULL) - { - for (dim = 0; dim < ref->u.ar.dimen; dim++) - if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - break; - if (dim < ref->u.ar.dimen) - break; - } - /* Array references with vector subscripts and non-variable - expressions need be converted to a one-based descriptor. */ - if (ref || e->expr_type != EXPR_VARIABLE) - lbshift = gfc_index_one_node; - parmse->expr = var; gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr, - &lbshift, &packed); + true, &packed); if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))) { diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index a7bc778ffba7..7db109d03036 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1707,7 +1707,6 @@ tree gfc_get_dtype_rank_type_slen (int rank, tree etype, tree length) { tree ptype; - tree size; int n; ptype = etype; @@ -1765,6 +1764,7 @@ gfc_get_dtype_rank_type_slen (int rank, tree etype, tree length) gcc_unreachable (); } + tree size = NULL_TREE; switch (n) { case BT_CHARACTER: @@ -1772,8 +1772,8 @@ gfc_get_dtype_rank_type_slen (int rank, tree etype, tree length) size = gfc_get_character_len_in_bytes (ptype, length); break; case BT_VOID: - gcc_assert (TREE_CODE (ptype) == POINTER_TYPE); - size = size_in_bytes (ptype); + if (TREE_CODE (ptype) == POINTER_TYPE) + size = size_in_bytes (ptype); break; default: size = size_in_bytes (etype);
