https://gcc.gnu.org/g:da5e5710423d6343f0a87d02839a6081754af298
commit da5e5710423d6343f0a87d02839a6081754af298
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Jan 30 21:07:15 2025 +0100
Déplacement méthode set_descriptor_from_scalar
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 63 +++++++++++++++++++++++++++++++++++
gcc/fortran/trans-array.h | 3 ++
gcc/fortran/trans-expr.cc | 83 +++++-----------------------------------------
3 files changed, 75 insertions(+), 74 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e40c1dbf2783..64d7b6c3f64e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1786,6 +1786,69 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree
desc,
gfc_conv_descriptor_offset_set (block, desc, offset);
}
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+ akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else
+ akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+ scalar = TREE_TYPE (scalar);
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ symbol_attribute scalar_attr, bool is_class,
+ tree cond_optional)
+{
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, scalar_attr);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ tree etype = gfc_get_element_type (type);
+ tree dtype_val;
+ if (etype == void_type_node)
+ dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
+ else
+ dtype_val = gfc_get_dtype (type);
+
+ tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (block, dtype_ref, dtype_val);
+
+ gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+ tree tmp;
+ if (is_class)
+ tmp = gfc_class_data_get (scalar);
+ else
+ tmp = scalar;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ if (cond_optional)
+ {
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+ }
+
+ gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 296a8052dd73..691231f66903 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,6 +147,9 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
gfc_expr *, locus *);
+tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
+void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
+ symbol_attribute, bool, tree);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 56cef8b382aa..ee344bfb5477 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -83,34 +83,12 @@ gfc_get_character_len_in_bytes (tree type)
}
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
- enum gfc_array_kind akind;
-
- if (attr.pointer)
- akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
- akind = GFC_ARRAY_ALLOCATABLE;
- else
- akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
- scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
-}
-
-
tree
gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr
*expr, tree scalar)
{
symbol_attribute attr = sym->attr;
- tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
tree desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -172,55 +150,12 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
-void
-set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- symbol_attribute scalar_attr, bool is_class,
- tree cond_optional)
-{
- tree type = get_scalar_to_descriptor_type (scalar, scalar_attr);
- if (POINTER_TYPE_P (type))
- type = TREE_TYPE (type);
-
- tree etype = gfc_get_element_type (type);
- tree dtype_val;
- if (etype == void_type_node)
- dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
- else
- dtype_val = gfc_get_dtype (type);
-
- tree dtype_ref = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (block, dtype_ref, dtype_val);
-
- gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
-
- tree tmp;
- if (is_class)
- tmp = gfc_class_data_get (scalar);
- else
- tmp = scalar;
-
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- if (cond_optional)
- {
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- cond_optional, tmp,
- fold_convert (TREE_TYPE (scalar),
- null_pointer_node));
- }
-
- gfc_conv_descriptor_data_set (block, desc, tmp);
-}
-
-
-
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
tree desc, type;
- type = get_scalar_to_descriptor_type (scalar, attr);
+ type = gfc_get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -232,8 +167,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar,
symbol_attribute attr)
scalar = tmp;
}
- set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
- false, NULL_TREE);
+ gfc_set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
+ false, NULL_TREE);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -1082,9 +1017,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Scalar to an assumed-rank array. */
if (fsym->ts.u.derived->components->as)
- set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, gfc_expr_attr (e),
- false, cond_optional);
+ gfc_set_descriptor_from_scalar (&parmse->pre, ctree,
+ parmse->expr, gfc_expr_attr (e),
+ false, cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1459,8 +1394,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts,
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
- set_descriptor_from_scalar (&block, ctree, parmse->expr,
- gfc_expr_attr (e), true, NULL_TREE);
+ gfc_set_descriptor_from_scalar (&block, ctree, parmse->expr,
+ gfc_expr_attr (e), true, NULL_TREE);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
