From f9018fa7d4dc752331e62963c9cf86ab01a1bfc5 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Fri, 7 Jun 2024 08:57:36 +0200
Subject: [PATCH 2/3] Use gfc_reset_vptr more consistently.
The vptr for a class type is set in various ways in different
locations. Refactor the use and simplify code.
gcc/fortran/ChangeLog:
* trans-array.cc (structure_alloc_comps): Use reset_vptr.
* trans-decl.cc (gfc_trans_deferred_vars): Same.
(gfc_generate_function_code): Same.
* trans-expr.cc (gfc_reset_vptr): Allow supplying the class
type.
(gfc_conv_procedure_call): Use reset_vptr.
* trans-intrinsic.cc (gfc_conv_intrinsic_transfer): Same.
---
gcc/fortran/trans-array.cc | 34 ++++----------------
gcc/fortran/trans-decl.cc | 19 ++----------
gcc/fortran/trans-expr.cc | 57 +++++++++++++++++-----------------
gcc/fortran/trans-intrinsic.cc | 10 +-----
4 files changed, 38 insertions(+), 82 deletions(-)
@@ -9864,15 +9864,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
else
{
/* Build the vtable address and set the vptr with it. */
- tree vtab;
- gfc_symbol *vtable;
- vtable = gfc_find_derived_vtab (c->ts.u.derived);
- vtab = vtable->backend_decl;
- if (vtab == NULL_TREE)
- vtab = gfc_get_symbol_decl (vtable);
- vtab = gfc_build_addr_expr (NULL, vtab);
- vtab = fold_convert (TREE_TYPE (tmp), vtab);
- gfc_add_modify (&tmpblock, tmp, vtab);
+ gfc_reset_vptr (&tmpblock, nullptr, tmp, c->ts.u.derived);
}
}
@@ -9903,15 +9895,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
&& (CLASS_DATA (c)->attr.allocatable
|| CLASS_DATA (c)->attr.class_pointer))
{
- tree vptr_decl;
+ tree class_ref;
/* Allocatable CLASS components. */
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
-
- vptr_decl = gfc_class_vptr_get (comp);
+ class_ref = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
- comp = gfc_class_data_get (comp);
+ comp = gfc_class_data_get (class_ref);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp,
null_pointer_node);
@@ -9926,19 +9916,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
/* The dynamic type of a disassociated pointer or unallocated
allocatable variable is its declared type. An unlimited
polymorphic entity has no declared type. */
- if (!UNLIMITED_POLY (c))
- {
- vtab = gfc_find_derived_vtab (c->ts.u.derived);
- if (!vtab->backend_decl)
- gfc_get_symbol_decl (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
- }
- else
- tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, vptr_decl, tmp);
- gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_reset_vptr (&fnblock, nullptr, class_ref, c->ts.u.derived);
cmp_has_alloc_comps = false;
}
@@ -5070,26 +5070,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
- gfc_symbol *vtab;
- tree rhs;
-
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
e = gfc_lval_expr_from_sym (sym);
- gfc_add_vptr_component (e);
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
+ gfc_reset_vptr (&init, e);
gfc_free_expr (e);
- if (UNLIMITED_POLY (sym))
- rhs = build_int_cst (TREE_TYPE (se.expr), 0);
- else
- {
- vtab = gfc_find_derived_vtab (sym->ts.u.derived);
- rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
- gfc_get_symbol_decl (vtab));
- }
- gfc_add_modify (&init, se.expr, rhs);
gfc_restore_backend_locus (&loc);
}
@@ -7931,7 +7916,7 @@ gfc_generate_function_code (gfc_namespace * ns)
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
gfc_reset_vptr (&init, nullptr, result,
- CLASS_DATA (sym->result)->ts.u.derived);
+ sym->result->ts.u.derived);
}
else if (sym->ts.type == BT_DERIVED
&& !sym->attr.allocatable)
@@ -532,12 +532,12 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
/* Reset the vptr to the declared type, e.g. after deallocation.
Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
- one with e or derived. At least one of the two has to be set. The generated
- assignment code is added at the end of BLOCK. */
+ one with e or class_type. At least one of the two has to be set. The
+ generated assignment code is added at the end of BLOCK. */
void
gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
- gfc_symbol *derived)
+ gfc_symbol *class_type)
{
tree vptr = NULL_TREE;
@@ -564,15 +564,31 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
if (vptr == NULL_TREE)
return;
- if (UNLIMITED_POLY (e))
+ if (UNLIMITED_POLY (e)
+ || UNLIMITED_POLY (class_type)
+ /* When the class_type's source is not a symbol (e.g. a component's ts),
+ then look at the _data-components type. */
+ || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
+ && class_type->components && class_type->components->ts.u.derived
+ && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
else
{
- gfc_symbol *vtab;
+ gfc_symbol *vtab, *type = nullptr;
tree vtable;
+ if (e)
+ type = e->ts.u.derived;
+ else if (class_type)
+ {
+ if (class_type->ts.type == BT_CLASS)
+ type = CLASS_DATA (class_type)->ts.u.derived;
+ else
+ type = class_type;
+ }
+ gcc_assert (type);
/* Return the vptr to the address of the declared type. */
- vtab = gfc_find_derived_vtab (derived ? derived : e->ts.u.derived);
+ vtab = gfc_find_derived_vtab (type);
vtable = vtab->backend_decl;
if (vtable == NULL_TREE)
vtable = gfc_get_symbol_decl (vtab);
@@ -6872,29 +6888,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
NULL_TREE, true,
e, e->ts, cls);
gfc_add_expr_to_block (&block, tmp);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, ptr,
- null_pointer_node);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_add_modify (&block, ptr,
+ fold_convert (TREE_TYPE (ptr),
+ null_pointer_node));
- if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
- {
- gfc_add_modify (&block, ptr,
- fold_convert (TREE_TYPE (ptr),
- null_pointer_node));
- gfc_add_expr_to_block (&block, tmp);
- }
- else if (fsym->ts.type == BT_CLASS)
- {
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
- tmp = gfc_get_symbol_decl (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- ptr = gfc_class_vptr_get (parmse.expr);
- gfc_add_modify (&block, ptr,
- fold_convert (TREE_TYPE (ptr), tmp));
- gfc_add_expr_to_block (&block, tmp);
- }
+ if (fsym->ts.type == BT_CLASS)
+ gfc_reset_vptr (&block, nullptr,
+ build_fold_indirect_ref (parmse.expr),
+ fsym->ts.u.derived);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
@@ -8815,15 +8815,7 @@ scalar_transfer:
/* For CLASS results, set the _vptr. */
if (mold_expr->ts.type == BT_CLASS)
- {
- tree vptr;
- gfc_symbol *vtab;
- vptr = gfc_class_vptr_get (tmpdecl);
- vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
- }
+ gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
se->expr = tmpdecl;
}
--
2.45.1