https://gcc.gnu.org/g:be9046fd848c961a87fa8e8b7b2ba7ec005a62bc
commit be9046fd848c961a87fa8e8b7b2ba7ec005a62bc
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Sat Dec 7 22:22:10 2024 +0100
Sauvegarde modifs
Diff:
---
gcc/fortran/trans-array.cc | 42 +++++++++++++++++++++++++++++
gcc/fortran/trans-array.h | 2 ++
gcc/fortran/trans-decl.cc | 67 +++++++---------------------------------------
3 files changed, 54 insertions(+), 57 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 091d47798b1e..2a2ca7cc88a4 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -734,6 +734,48 @@ gfc_build_null_descriptor (tree type, gfc_typespec &ts,
}
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+ vec<constructor_elt, va_gc> *v = nullptr;
+
+ tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+ tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+ tree data_type = TREE_TYPE (data_field);
+ tree data_value;
+ if (ts.u.derived->components->attr.dimension
+ || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+ data_value = gfc_build_null_descriptor (data_type,
+ ts.u.derived->components->ts,
+
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+ }
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (data_type)
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_type)));
+ data_value = fold_convert (data_type, null_pointer_node);
+ }
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+ tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+ tree vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+
+ return build_constructor (type, v);
+}
+
+
void
gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index ab27f15cab22..58b7a6aec336 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -140,6 +140,8 @@ void gfc_set_delta (gfc_loopinfo *);
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree
descriptor);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index a62fe3f0441c..652f1bac3d7e 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4741,16 +4741,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
{
/* Nullify explicit return class arrays on entry. */
- tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4892,48 +4890,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
- build_int_cst (gfc_array_index_type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
- NULL_TREE);
- }
-
if (sym->ts.type == BT_CLASS
&& (sym->attr.save || flag_max_stack_var_size == 0)
&& CLASS_DATA (sym)->attr.allocatable)
{
- tree vptr;
-
- if (UNLIMITED_POLY (sym))
- vptr = null_pointer_node;
- else
- {
- gfc_symbol *vsym;
- vsym = gfc_find_derived_vtab (sym->ts.u.derived);
- vptr = gfc_get_symbol_decl (vsym);
- vptr = gfc_build_addr_expr (NULL, vptr);
- }
-
- if (CLASS_DATA (sym)->attr.dimension
- || (CLASS_DATA (sym)->attr.codimension
- && flag_coarray != GFC_FCOARRAY_LIB))
- {
- tmp = gfc_class_data_get (sym->backend_decl);
- tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
- }
- else
- tmp = null_pointer_node;
-
DECL_INITIAL (sym->backend_decl)
- = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+ = gfc_build_default_class_descriptor (TREE_TYPE
(sym->backend_decl),
+ sym->ts);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
else if ((sym->attr.dimension || sym->attr.codimension
@@ -5092,20 +5055,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
se.want_pointer = 1;
gfc_conv_expr (&se, e);
}
- else if (sym->ts.type == BT_CLASS
- && !CLASS_DATA (sym)->attr.dimension
- && !CLASS_DATA (sym)->attr.codimension)
- {
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- }
else
{
- se.descriptor_only = 1;
+ se.want_pointer = 1;
gfc_conv_expr (&se, e);
- descriptor = se.expr;
- se.expr = gfc_conv_descriptor_data_addr (se.expr);
- se.expr = build_fold_indirect_ref_loc (input_location,
se.expr);
}
gfc_free_expr (e);
