https://gcc.gnu.org/g:e3de44455296f04e014dad8c9efaef858384cfac
commit e3de44455296f04e014dad8c9efaef858384cfac
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Sat Dec 7 22:22:10 2024 +0100
Sauvegarde modifs
Annulation suppression else
Correction assertions
Initialisation vptr
Non initialisation elem_len pour les conteneurs de classe
Mise à jour class_allocatable_14
Diff:
---
gcc/fortran/trans-array.cc | 52 ++++++++++++++++++++++
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-decl.cc | 58 +++++--------------------
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 66 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 268de211cd66..d15576adde10 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -734,6 +734,58 @@ 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);
+
+ gcc_assert (ts.type == BT_CLASS);
+ 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,
+
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+ }
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (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;
+ if (ts.u.derived->attr.unlimited_polymorphic)
+ vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ else
+ {
+ gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+ tree vsym_decl = gfc_get_symbol_decl (vsym);
+ vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+ }
+ 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 1bb3294b0749..63a77d562a7b 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 4ae22a5584d0..dad15858fa6a 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4780,16 +4780,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);
+ }
}
@@ -4931,48 +4929,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
@@ -5144,7 +5107,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
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);
+ se.expr = build_fold_indirect_ref_loc (input_location,
+ se.expr);
}
gfc_free_expr (e);
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90
b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
index d2514772a038..01f02ab6e47a 100644
--- a/gcc/testsuite/gfortran.dg/class_allocate_14.f90
+++ b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
@@ -25,6 +25,6 @@ call sub()
call sub2()
end
-! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b =
{._data={.data=0B}, ._vptr=&__vtab_m_T};" 1 "original" } }
+! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b =
{._data={.data=0B, .dtype={.version=0, .rank=1}}, ._vptr=&__vtab_m_T};" 1
"original" } }
! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y =
{._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } }
