https://gcc.gnu.org/g:98b94a1a2699a73092154f7f8a58bd661b33b8d9
commit 98b94a1a2699a73092154f7f8a58bd661b33b8d9
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Tue Feb 4 11:16:32 2025 +0100
Sauvegarde factorisation set_descriptor_from_scalar
Diff:
---
gcc/fortran/trans-array.cc | 153 +++++++++++++++++++++++++++++----------------
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 25 +++++---
gcc/fortran/trans-types.cc | 44 ++++++++-----
gcc/fortran/trans-types.h | 1 +
5 files changed, 149 insertions(+), 76 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d6e7c9829ff2..60ce464ee032 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -600,7 +600,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
}
-static int
+static bt
get_type_info (const bt &type)
{
switch (type)
@@ -611,11 +611,13 @@ get_type_info (const bt &type)
case BT_COMPLEX:
case BT_DERIVED:
case BT_CHARACTER:
- case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
return type;
+ case BT_CLASS:
+ return BT_DERIVED;
+
case BT_PROCEDURE:
case BT_ASSUMED:
return BT_VOID;
@@ -672,9 +674,14 @@ get_size_info (gfc_typespec &ts)
class modify_info
{
public:
+ virtual bool set_dtype () const { return is_initialization (); }
+ virtual bool use_tree_type () const { return false; }
virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
+ virtual bool set_span () const { return false; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
+ virtual tree get_length (gfc_typespec &ts) const { return get_size_info
(ts); }
};
class nullification : public modify_info
@@ -698,8 +705,14 @@ class init_info : public modify_info
public:
virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
+ virtual bt get_type_type (const gfc_typespec &) const;
};
+bt
+init_info::get_type_type (const gfc_typespec & type_info) const
+{
+ return get_type_info (type_info.type);
+}
class default_init : public init_info
{
@@ -732,18 +745,76 @@ public:
class scalar_value : public init_info
{
private:
- gfc_typespec &ts;
+ gfc_typespec *ts;
tree value;
+ bool use_tree_type_;
+ tree get_elt_type () const;
+
public:
scalar_value(gfc_typespec &arg_ts, tree arg_value)
- : ts(arg_ts), value(arg_value) { }
+ : ts(&arg_ts), value(arg_value), use_tree_type_ (false) { }
+ scalar_value(tree arg_value)
+ : ts(nullptr), value(arg_value), use_tree_type_ (true) { }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const { return value; }
- virtual gfc_typespec *get_type () const { return &ts; }
+ virtual gfc_typespec *get_type () const { return ts; }
+ virtual bool set_span () const { return true; }
+ virtual bool use_tree_type () const { return use_tree_type_; }
+ virtual bt get_type_type (const gfc_typespec &) const;
+ virtual tree get_length (gfc_typespec &ts) const;
};
+tree
+scalar_value::get_elt_type () const
+{
+ tree tmp = value;
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = TREE_TYPE (tmp);
+
+ tree etype = TREE_TYPE (tmp);
+
+ /* For arrays, which are not scalar coarrays. */
+ if (TREE_CODE (etype) == ARRAY_TYPE && !TYPE_STRING_FLAG (etype))
+ etype = TREE_TYPE (etype);
+
+ return etype;
+}
+
+bt
+scalar_value::get_type_type (const gfc_typespec & type_info) const
+{
+ bt n;
+ if (use_tree_type ())
+ {
+ tree etype = get_elt_type ();
+ gfc_get_type_info (etype, &n, nullptr);
+ }
+ else
+ n = get_type_info (type_info.type);
+
+ return n;
+}
+
+tree
+scalar_value::get_length (gfc_typespec & type_info) const
+{
+ bt n;
+ tree size;
+ if (use_tree_type ())
+ {
+ tree etype = get_elt_type ();
+ gfc_get_type_info (etype, &n, &size);
+ }
+ else
+ size = init_info::get_length (type_info);
+
+ return size;
+}
+
+
static tree
build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &,
const init_info &init)
@@ -758,13 +829,14 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
if (type_info == nullptr)
type_info = &ts;
- if (!(type_info->type == BT_CLASS
- || (type_info->type == BT_CHARACTER
- && type_info->deferred)))
+ if (!(init.is_initialization ()
+ && (type_info->type == BT_CLASS
+ || (type_info->type == BT_CHARACTER
+ && type_info->deferred))))
{
tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
tree elem_len_val = fold_convert (TREE_TYPE (elem_len_field),
- get_size_info (*type_info));
+ init.get_length (*type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -780,10 +852,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
}
tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
- tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (type_info->type == BT_CLASS
- ? BT_DERIVED
- : type_info->type));
+ bt n = init.get_type_type (*type_info);
+ tree type_info_val = build_int_cst (TREE_TYPE (type_info_field), n);
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
@@ -818,6 +888,12 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
}
+ if (init.set_span ())
+ {
+ tree span_field = gfc_advance_chain (fields, SPAN_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, span_field, integer_zero_node);
+ }
+
if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
{
/* Declare the variable static so its array descriptor stays present
@@ -1197,6 +1273,16 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree
descriptor,
}
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ symbol_attribute *attr)
+{
+ init_struct (block, desc,
+ get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
+ scalar_value (scalar)));
+}
+
+
/* Build a null array descriptor constructor. */
tree
@@ -1814,47 +1900,6 @@ gfc_get_scalar_to_descriptor_type (tree scalar,
symbol_attribute attr)
}
-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);
-}
-
void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index a4e49ba705ee..97cf7f8cb41f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -149,7 +149,7 @@ 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);
+ symbol_attribute *);
void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
gfc_symbol *, bool, bool, bool);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index fdd46491b946..f514edd32bae 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -167,8 +167,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, attr,
- false, NULL_TREE);
+ 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(). */
@@ -953,9 +952,18 @@ 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)
- gfc_set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, gfc_expr_attr (e),
- false, cond_optional);
+ {
+ tree tmp = parmse->expr;
+ if (cond_optional)
+ {
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&parmse->pre, ctree, tmp, &attr);
+ }
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1330,8 +1338,11 @@ 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)
- gfc_set_descriptor_from_scalar (&block, ctree, parmse->expr,
- gfc_expr_attr (e), true, NULL_TREE);
+ {
+ tree data = gfc_class_data_get (parmse->expr);
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&block, ctree, data, &attr);
+ }
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 5ad0fe62654a..5f8100b9d45e 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1678,23 +1678,13 @@ gfc_get_desc_dim_type (void)
}
-/* Return the DTYPE for an array. This describes the type and type parameters
- of the array. */
-/* TODO: Only call this when the value is actually used, and make all the
- unknown cases abort. */
-
-tree
-gfc_get_dtype_rank_type (int rank, tree etype)
+void
+gfc_get_type_info (tree etype, bt *type, tree *psize)
{
- tree ptype;
tree size;
- int n;
- tree tmp;
- tree dtype;
- tree field;
- vec<constructor_elt, va_gc> *v = NULL;
+ bt n;
- ptype = etype;
+ tree ptype = etype;
while (TREE_CODE (etype) == POINTER_TYPE
|| TREE_CODE (etype) == ARRAY_TYPE)
{
@@ -1749,6 +1739,9 @@ gfc_get_dtype_rank_type (int rank, tree etype)
gcc_unreachable ();
}
+ if (type)
+ *type = n;
+
switch (n)
{
case BT_CHARACTER:
@@ -1768,6 +1761,29 @@ gfc_get_dtype_rank_type (int rank, tree etype)
STRIP_NOPS (size);
size = fold_convert (size_type_node, size);
+
+ if (psize)
+ *psize = size;
+}
+
+
+/* Return the DTYPE for an array. This describes the type and type parameters
+ of the array. */
+/* TODO: Only call this when the value is actually used, and make all the
+ unknown cases abort. */
+
+tree
+gfc_get_dtype_rank_type (int rank, tree etype)
+{
+ tree size;
+ bt n;
+ tree tmp;
+ tree dtype;
+ tree field;
+ vec<constructor_elt, va_gc> *v = NULL;
+
+ gfc_get_type_info (etype, &n, &size);
+
tmp = get_dtype_type_node ();
field = gfc_advance_chain (TYPE_FIELDS (tmp),
GFC_DTYPE_ELEM_LEN);
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index aba841da9cb5..1f1281524507 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -116,6 +116,7 @@ bool gfc_return_by_reference (gfc_symbol *);
bool gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
+void gfc_get_type_info (tree, bt *, tree *);
tree gfc_get_dtype_rank_type (int, tree);
tree gfc_get_dtype (tree, int *rank = NULL);
