https://gcc.gnu.org/g:1a3c145421ec579cbbc4ad1e51f3f6de3227ae0f
commit 1a3c145421ec579cbbc4ad1e51f3f6de3227ae0f Author: Mikael Morin <[email protected]> Date: Mon Aug 10 22:14:37 2026 +0200 fortran: array descriptor: Move scalar descriptor init 3/3 [PR122521] Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline? -- >8 -- Move the array descriptor initialization part of gfc_conv_scalar_to_descriptor to its own function in trans-descriptor.cc. PR fortran/122521 gcc/fortran/ChangeLog: * trans-expr.cc (gfc_conv_scalar_to_descriptor): Move scalar descriptor initialization code ... * trans-descriptor.cc (gfc_set_descriptor_from_scalar): ... here as a new function. * trans-descriptor.h (gfc_set_descriptor_from_scalar): New declaration. Diff: --- gcc/fortran/trans-descriptor.cc | 22 ++++++++++++++++++++++ gcc/fortran/trans-descriptor.h | 1 + gcc/fortran/trans-expr.cc | 14 +++----------- 3 files changed, 26 insertions(+), 11 deletions(-) diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc index c6fe64d69d05..2139cd9fc311 100644 --- a/gcc/fortran/trans-descriptor.cc +++ b/gcc/fortran/trans-descriptor.cc @@ -873,6 +873,28 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, } +/* Add code to BLOCK initializing the zero-rank array descriptor DESCR, so that + it represents the same data as the scalar reference SCALAR. This is used to + implement the argument association between the actual argument SCALAR and an + assumed-rank dummy argument. */ + +void +gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, tree scalar) +{ + 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)); +} + + /* Add code to BLOCK initializing the zero-rank array descriptor DESCR, so that it represents the same data as the class descriptor reference SCALAR corresponding to the scalar polymorphic expression SCALAR_EXPR. This is used diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h index e4ff7318a971..3f611b1d76af 100644 --- a/gcc/fortran/trans-descriptor.h +++ b/gcc/fortran/trans-descriptor.h @@ -75,6 +75,7 @@ tree gfc_create_null_actual_descriptor (stmtblock_t *, gfc_typespec *, void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree, gfc_expr *, tree); +void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree); void gfc_set_descriptor_from_scalar_class (stmtblock_t *, tree, tree, gfc_expr *); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index c24102df1206..a1b739da6344 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -87,10 +87,9 @@ gfc_get_character_len_in_bytes (tree type) tree gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) { - tree desc, type, etype; + tree desc, type; type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), attr); - etype = TREE_TYPE (scalar); desc = gfc_create_var (type, "desc"); DECL_ARTIFICIAL (desc) = 1; @@ -101,15 +100,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) gfc_add_modify (&se->pre, tmp, scalar); scalar = tmp; } - 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 (&se->pre, desc, - gfc_get_dtype_rank_type (0, etype)); - gfc_conv_descriptor_data_set (&se->pre, desc, scalar); - gfc_conv_descriptor_span_set (&se->pre, desc, - gfc_conv_descriptor_elem_len_get (desc)); + + gfc_set_descriptor_from_scalar (&se->pre, desc, scalar); /* Copy pointer address back - but only if it could have changed and if the actual argument is a pointer and not, e.g., NULL(). */
