https://gcc.gnu.org/g:6ee66376a1b8c97bd0be0eb0a51b90dabbaee58b
commit 6ee66376a1b8c97bd0be0eb0a51b90dabbaee58b
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Dec 5 20:30:08 2024 +0100
Creation méthode initialisation descripteur
Diff:
---
gcc/fortran/expr.cc | 25 ++++++---
gcc/fortran/trans-array.cc | 136 +++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 154 insertions(+), 7 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a997bdae726a..da63c3970938 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5386,27 +5386,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
gfc_ref *ref;
if (expr->rank == 0)
- return NULL;
+ return nullptr;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
+ gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+ if (sym
+ && sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else if (sym)
+ as = sym->as;
else
- as = NULL;
+ as = nullptr;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+ else
+ as = comp->as;
+ }
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
continue;
case REF_ARRAY:
@@ -5416,7 +5427,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
case AR_ELEMENT:
case AR_SECTION:
case AR_UNKNOWN:
- as = NULL;
+ as = nullptr;
continue;
case AR_FULL:
@@ -5428,7 +5439,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
}
else
- as = NULL;
+ as = nullptr;
return as;
}
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a458af322ce8..60c922bb871d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -543,6 +543,142 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
+
+static int
+get_type_info (const gfc_typespec &ts)
+{
+ switch (ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_DERIVED:
+ case BT_CHARACTER:
+ case BT_CLASS:
+ case BT_VOID:
+ case BT_UNSIGNED:
+ return ts.type;
+
+ case BT_PROCEDURE:
+ case BT_ASSUMED:
+ return BT_VOID;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ return BT_UNKNOWN;
+}
+
+
+static tree
+get_size_info (gfc_typespec &ts)
+{
+ switch (ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_DERIVED:
+ case BT_UNSIGNED:
+ return size_in_bytes (TREE_TYPE (gfc_typenode_for_spec (&ts)));
+
+ case BT_CHARACTER:
+ {
+ tree type = gfc_typenode_for_spec (&ts);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ tree elt_type = TREE_TYPE (type);
+ tree len = ts.u.cl->backend_decl;
+ return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ size_in_bytes (elt_type),
+ len);
+ }
+
+ case BT_CLASS:
+ return get_size_info (ts.u.derived->components->ts);
+
+ case BT_PROCEDURE:
+ case BT_VOID:
+ case BT_ASSUMED:
+ default:
+ gcc_unreachable ();
+ }
+
+ return NULL_TREE;
+}
+
+
+static tree
+build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &)
+{
+ tree type = get_dtype_type_node ();
+
+ tree fields = TYPE_FIELDS (type);
+
+ tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
+ tree elem_len_val = get_size_info (ts);
+
+ tree version_field = gfc_advance_chain (fields, GFC_DTYPE_VERSION);
+ tree version_val = build_int_cst (TREE_TYPE (version_field), 0);
+
+ tree rank_field = gfc_advance_chain (fields, GFC_DTYPE_RANK);
+ tree rank_val = build_int_cst (TREE_TYPE (rank_field), rank);
+
+ 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 (ts));
+
+ return build_constructor_va (type, 4,
+ elem_len_field, elem_len_val,
+ version_field, version_val,
+ rank_field, rank_val,
+ type_info_field, type_info_val);
+}
+
+
+/* Build a null array descriptor constructor. */
+
+tree
+gfc_build_null_descriptor (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (DATA_FIELD == 0);
+ tree fields = TYPE_FIELDS (type);
+
+ tree data_field = gfc_advance_chain (fields, DATA_FIELD);
+ tree data_value = fold_convert (TREE_TYPE (data_field), null_pointer_node);
+
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = build_dtype (ts, rank, attr);
+
+ return build_constructor_va (type, 2,
+ data_field, data_value,
+ dtype_field, dtype_value);
+}
+
+
+void
+gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (var_ref);
+ int rank = as != nullptr ? as->rank : 0;
+
+ attr = gfc_expr_attr (var_ref);
+
+ gfc_add_modify (&var.pre, var.expr,
+ gfc_build_null_descriptor (TREE_TYPE (var.expr), var_ref->ts,
+ rank, attr));
+}
+
+
/* Build a null array descriptor constructor. */
tree
