https://gcc.gnu.org/g:08aca07552f8c3be0649ad1f56ea6124c09237c4
commit 08aca07552f8c3be0649ad1f56ea6124c09237c4
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Tue Jul 15 20:30:45 2025 +0200
Extraction gfc_build_default_class_descriptor
Correction régression class_allocate_14
Diff:
---
gcc/fortran/trans-decl.cc | 24 ++--------------------
gcc/fortran/trans-descriptor.cc | 44 ++++++++++++++++++++++++++++++++++++-----
gcc/fortran/trans-descriptor.h | 4 +++-
gcc/fortran/trans-expr.cc | 14 ++++++++++---
gcc/fortran/trans.h | 1 +
5 files changed, 56 insertions(+), 31 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 66fd67e61f60..65a782b6dddf 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4926,30 +4926,10 @@ 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;
+ tree class_type = TREE_TYPE (sym->backend_decl);
DECL_INITIAL (sym->backend_decl)
- = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+ = gfc_build_default_class_descriptor (sym->ts, class_type);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
else if ((sym->attr.dimension || sym->attr.codimension
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 27c85d4e73c1..57570145118d 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -173,8 +173,8 @@ gfc_get_cfi_dim_sm (tree desc, tree idx)
#define UBOUND_SUBFIELD 2
-static tree
-get_type_field (tree type, unsigned field_idx, tree field_type = NULL_TREE)
+tree
+gfc_get_type_field (tree type, unsigned field_idx, tree field_type = NULL_TREE)
{
tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
gcc_assert (field != NULL_TREE
@@ -187,7 +187,7 @@ get_type_field (tree type, unsigned field_idx, tree
field_type = NULL_TREE)
static tree
get_ref_comp (tree ref, unsigned field_idx, tree type = NULL_TREE)
{
- tree field = get_type_field (TREE_TYPE (ref), field_idx, type);
+ tree field = gfc_get_type_field (TREE_TYPE (ref), field_idx, type);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
ref, field, NULL_TREE);
@@ -415,8 +415,9 @@ gfc_conv_descriptor_type_set (stmtblock_t *block, tree
desc, int value)
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- tree dtype_field = get_type_field (type, DTYPE_FIELD, get_dtype_type_node
());
- tree field = get_type_field (TREE_TYPE (dtype_field), GFC_DTYPE_TYPE);
+ tree dtype_field = gfc_get_type_field (type, DTYPE_FIELD,
+ get_dtype_type_node ());
+ tree field = gfc_get_type_field (TREE_TYPE (dtype_field), GFC_DTYPE_TYPE);
tree type_value = build_int_cst (TREE_TYPE (field), value);
gfc_conv_descriptor_type_set (block, desc, type_value);
@@ -706,3 +707,36 @@ gfc_init_descriptor_result (stmtblock_t *block, tree descr)
gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
}
+
+tree
+gfc_build_default_class_descriptor (const gfc_typespec &ts, tree class_type)
+{
+ gcc_assert (ts.type == BT_CLASS);
+
+ gfc_symbol *derived = ts.u.derived;
+
+ tree vptr;
+ if (derived->attr.unlimited_polymorphic)
+ vptr = null_pointer_node;
+ else
+ {
+ gfc_symbol *vsym;
+ vsym = gfc_find_derived_vtab (derived);
+ vptr = gfc_get_symbol_decl (vsym);
+ vptr = gfc_build_addr_expr (NULL, vptr);
+ }
+
+ tree tmp;
+ if (derived->components->attr.dimension
+ || (derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+ {
+ tmp = gfc_class_type_data_field_get (class_type);
+ tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+ }
+ else
+ tmp = null_pointer_node;
+
+ return gfc_class_set_static_fields (class_type, vptr, tmp);
+}
+
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 0b6540116452..f5b5e59f1cfe 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
-tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+tree gfc_build_default_class_descriptor (const gfc_typespec &, tree);
void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_set_scalar_null_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
@@ -46,6 +46,8 @@ tree gfc_get_cfi_dim_extent (tree desc, tree idx);
tree gfc_get_cfi_dim_sm (tree desc, tree idx);
+tree gfc_get_type_field (tree, unsigned, tree);
+
tree gfc_get_descriptor_dimension (tree desc);
tree gfc_conv_descriptor_token (tree desc);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e34716a99ad8..39e953fa2af3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -223,20 +223,28 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse, gfc_expr *expr)
tree
-gfc_class_set_static_fields (tree decl, tree vptr, tree data)
+gfc_class_type_data_field_get (tree class_type)
+{
+ return gfc_advance_chain (TYPE_FIELDS (class_type),
+ CLASS_DATA_FIELD);
+}
+
+
+tree
+gfc_class_set_static_fields (tree decl_type, tree vptr, tree data)
{
tree tmp;
tree field;
vec<constructor_elt, va_gc> *init = NULL;
- field = TYPE_FIELDS (TREE_TYPE (decl));
+ field = TYPE_FIELDS (decl_type);
tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp, data);
tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
- return build_constructor (TREE_TYPE (decl), init);
+ return build_constructor (decl_type, init);
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 461b0cdac71c..798bf0e8a0dc 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -430,6 +430,7 @@ typedef struct
gfc_wrapped_block;
/* Class API functions. */
+tree gfc_class_type_data_field_get (tree);
tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
