https://gcc.gnu.org/g:1f9bc4d088c03779b54b2c3cc19de0361b1dfcf1
commit 1f9bc4d088c03779b54b2c3cc19de0361b1dfcf1
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Aug 7 11:40:21 2025 +0200
Création gfc_conv_null_array_descriptor, gfc_conv_scalar_null_to_descriptor
Diff:
---
gcc/fortran/trans-descriptor.cc | 33 +++++++++++++++++
gcc/fortran/trans-descriptor.h | 5 ++-
gcc/fortran/trans-expr.cc | 82 +++++++++++++++++++++++++++++++++--------
3 files changed, 103 insertions(+), 17 deletions(-)
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 392dd9a0a076..7e367fdbe999 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -684,3 +684,36 @@ gfc_init_absent_descriptor (stmtblock_t *block, tree descr)
gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
}
+
+void
+gfc_set_scalar_descriptor (stmtblock_t *block, tree descr, tree value)
+{
+ tree etype = TREE_TYPE (value);
+
+ if (POINTER_TYPE_P (etype)
+ && 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, value);
+ gfc_conv_descriptor_span_set (block, descr,
+ gfc_conv_descriptor_elem_len_get (descr));
+}
+
+
+void
+gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *expr, tree descr,
+ tree string_length)
+{
+ tree etype = gfc_get_element_type (TREE_TYPE (descr));
+ 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_slen (expr->rank,
etype,
+ string_length));
+ gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
+ gfc_conv_descriptor_span_set (block, descr,
+ gfc_conv_descriptor_elem_len_get (descr));
+}
+
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 476c6d73ad8c..724f3cc711af 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -19,8 +19,6 @@ along with GCC; see the file COPYING3. If not see
#ifndef GFC_TRANS_DESCRIPTOR_H
#define GFC_TRANS_DESCRIPTOR_H
-/* Build a null array descriptor constructor. */
-void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_set_scalar_null_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
gfc_expr *, locus *);
@@ -92,7 +90,10 @@ gfc_get_descriptor_offsets_for_info (const_tree desc_type,
tree *data_off,
void gfc_init_descriptor_variable (stmtblock_t *block, gfc_symbol *sym, tree
descr);
void gfc_init_descriptor_result (stmtblock_t *block, tree descr);
+void gfc_nullify_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *,
tree, tree);
void gfc_init_static_descriptor (tree descr);
void gfc_init_absent_descriptor (stmtblock_t *block, tree descr);
+void gfc_set_scalar_descriptor (stmtblock_t *, tree, tree);
+void gfc_nullify_descriptor (stmtblock_t *, gfc_expr *, tree, tree);
#endif /* GFC_TRANS_DESCRIPTOR_H */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index de848bdb6630..a5f22233db5a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -105,6 +105,56 @@ get_scalar_to_descriptor_type (tree scalar,
symbol_attribute attr)
akind, !(attr.pointer || attr.target));
}
+tree
+gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, tree scalar)
+{
+ symbol_attribute attr = sym->attr;
+
+ tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree desc = gfc_create_var (type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ if (CONSTANT_CLASS_P (scalar))
+ {
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (&se->pre, tmp, scalar);
+ scalar = tmp;
+ }
+ if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
+ scalar = gfc_build_addr_expr (NULL_TREE, scalar);
+
+ gfc_set_scalar_descriptor (&se->pre, desc, scalar);
+
+ return desc;
+}
+
+
+tree
+gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr *expr)
+{
+ tree lower[GFC_MAX_DIMENSIONS], upper[GFC_MAX_DIMENSIONS];
+
+ for (int i = 0; i < expr->rank; i++)
+ {
+ lower[i] = NULL_TREE;
+ upper[i] = NULL_TREE;
+ }
+
+ tree elt_type = gfc_typenode_for_spec (&sym->ts);
+ tree desc_type = gfc_get_array_type_bounds (elt_type, expr->rank, 0,
+ lower, upper, 0,
+ GFC_ARRAY_UNKNOWN, false);
+
+ tree desc = gfc_create_var (desc_type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ gfc_nullify_descriptor (&se->pre, expr, desc, se->string_length);
+
+ return desc;
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -6633,14 +6683,29 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e,
gfc_symbol * fsym)
if (e->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.type == BT_CHARACTER)
{
+ /* Ensure that a usable length is available. */
+ if (parmse->string_length == NULL_TREE)
+ {
+ gfc_typespec *ts = &e->symtree->n.sym->ts;
+
+ if (ts->u.cl->length != NULL
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ gfc_conv_const_charlen (ts->u.cl);
+
+ if (ts->u.cl->backend_decl)
+ parmse->string_length = ts->u.cl->backend_decl;
+ }
+
/* MOLD is present. Substitute a temporary character NULL pointer.
For an assumed-rank dummy we need a descriptor that passes the
correct rank. */
if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
{
tree tmp = parmse->expr;
- tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
- gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
+ if (e->rank == 0)
+ tmp = gfc_conv_scalar_null_to_descriptor (parmse, fsym, tmp);
+ else
+ tmp = gfc_conv_null_array_descriptor (parmse, fsym, e);
parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
@@ -6650,19 +6715,6 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e,
gfc_symbol * fsym)
build_zero_cst (TREE_TYPE (tmp)));
parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
-
- /* Ensure that a usable length is available. */
- if (parmse->string_length == NULL_TREE)
- {
- gfc_typespec *ts = &e->symtree->n.sym->ts;
-
- if (ts->u.cl->length != NULL
- && ts->u.cl->length->expr_type == EXPR_CONSTANT)
- gfc_conv_const_charlen (ts->u.cl);
-
- if (ts->u.cl->backend_decl)
- parmse->string_length = ts->u.cl->backend_decl;
- }
}
else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
{
