https://gcc.gnu.org/g:07c2ae51c1db0e1d0c00b8bcecb019bb490e32f7
commit 07c2ae51c1db0e1d0c00b8bcecb019bb490e32f7 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 | 29 ++------------ gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +- 4 files changed, 58 insertions(+), 27 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 4532753a75fe..c5da644cbc2a 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -726,6 +726,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 345a9752dddc..3de7a5c247a8 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -139,6 +139,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 b077cee86a38..dac8bab149c2 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4785,14 +4785,12 @@ 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_clear_descriptor (&init, proc_sym, tmp); gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } } @@ -4940,30 +4938,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) && (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 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" } }