From 9847eaa6aa96eead01ab26800812bc5aeb6443d2 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Tue, 11 Jun 2024 12:52:26 +0200
Subject: [PATCH 3/3] Add gfc_class_set_vptr.
First step to adding a general assign all class type's data members
routine. Having a general routine prevents forgetting to tackle the
edge cases, e.g. setting _len.
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_class_set_vptr): Add setting of _vptr
member.
* trans-intrinsic.cc (conv_intrinsic_move_alloc): First use
of gfc_class_set_vptr and refactor very similar code.
* trans.h (gfc_class_set_vptr): Declare the new function.
gcc/testsuite/ChangeLog:
* gfortran.dg/unlimited_polymorphic_11.f90: Remove unnecessary
casts in gd-final expression.
---
gcc/fortran/trans-expr.cc | 44 ++++
gcc/fortran/trans-intrinsic.cc | 203 +++++-------------
gcc/fortran/trans.h | 2 +
.../gfortran.dg/unlimited_polymorphic_11.f90 | 2 +-
4 files changed, 106 insertions(+), 145 deletions(-)
@@ -598,6 +598,50 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
}
}
+void
+gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
+{
+ tree tmp, vptr_ref;
+ // gcc_assert (POINTER_TYPE_P (TREE_TYPE (to))
+ // && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (to))));
+ vptr_ref = gfc_get_vptr_from_expr (to);
+ if (POINTER_TYPE_P (TREE_TYPE (from))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
+ {
+ gfc_add_modify (block, vptr_ref,
+ fold_convert (TREE_TYPE (vptr_ref),
+ gfc_get_vptr_from_expr (from)));
+ }
+ else if (VAR_P (from)
+ && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
+ {
+ gfc_add_modify (block, vptr_ref,
+ gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
+ && GFC_CLASS_TYPE_P (
+ TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
+ {
+ gfc_add_modify (block, vptr_ref,
+ fold_convert (TREE_TYPE (vptr_ref),
+ gfc_get_vptr_from_expr (TREE_OPERAND (
+ TREE_OPERAND (from, 0), 0))));
+ }
+ else
+ {
+ tree vtab;
+ gfc_symbol *type;
+ tmp = TREE_TYPE (from);
+ if (POINTER_TYPE_P (tmp))
+ tmp = TREE_TYPE (tmp);
+ gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
+ &type);
+ vtab = gfc_find_derived_vtab (type)->backend_decl;
+ gcc_assert (vtab);
+ gfc_add_modify (block, vptr_ref,
+ gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab));
+ }
+}
/* Reset the len for unlimited polymorphic objects. */
@@ -12667,10 +12667,9 @@ conv_intrinsic_move_alloc (gfc_code *code)
{
stmtblock_t block;
gfc_expr *from_expr, *to_expr;
- gfc_expr *to_expr2, *from_expr2 = NULL;
gfc_se from_se, to_se;
- tree tmp;
- bool coarray;
+ tree tmp, to_tree, from_tree;
+ bool coarray, from_is_class, from_is_scalar;
gfc_start_block (&block);
@@ -12680,178 +12679,94 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
- gcc_assert (from_expr->ts.type != BT_CLASS
- || to_expr->ts.type == BT_CLASS);
+ gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
coarray = gfc_get_corank (from_expr) != 0;
- if (from_expr->rank == 0 && !coarray)
+ from_is_class = from_expr->ts.type == BT_CLASS;
+ from_is_scalar = from_expr->rank == 0 && !coarray;
+ if (to_expr->ts.type == BT_CLASS || from_is_scalar)
{
- if (from_expr->ts.type != BT_CLASS)
- from_expr2 = from_expr;
+ from_se.want_pointer = 1;
+ if (from_is_scalar)
+ gfc_conv_expr (&from_se, from_expr);
else
- {
- from_expr2 = gfc_copy_expr (from_expr);
- gfc_add_data_component (from_expr2);
- }
-
- if (to_expr->ts.type != BT_CLASS)
- to_expr2 = to_expr;
+ gfc_conv_expr_descriptor (&from_se, from_expr);
+ if (from_is_class)
+ from_tree = gfc_class_data_get (from_se.expr);
else
{
- to_expr2 = gfc_copy_expr (to_expr);
- gfc_add_data_component (to_expr2);
+ gfc_symbol *vtab;
+ from_tree = from_se.expr;
+
+ vtab = gfc_find_vtab (&from_expr->ts);
+ gcc_assert (vtab);
+ from_se.expr = gfc_get_symbol_decl (vtab);
}
+ gfc_add_block_to_block (&block, &from_se.pre);
- from_se.want_pointer = 1;
to_se.want_pointer = 1;
- gfc_conv_expr (&from_se, from_expr2);
- gfc_conv_expr (&to_se, to_expr2);
- gfc_add_block_to_block (&block, &from_se.pre);
+ if (to_expr->rank == 0)
+ gfc_conv_expr (&to_se, to_expr);
+ else
+ gfc_conv_expr_descriptor (&to_se, to_expr);
+ if (to_expr->ts.type == BT_CLASS)
+ to_tree = gfc_class_data_get (to_se.expr);
+ else
+ to_tree = to_se.expr;
gfc_add_block_to_block (&block, &to_se.pre);
/* Deallocate "to". */
- tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
- true, to_expr, to_expr->ts);
- gfc_add_expr_to_block (&block, tmp);
+ if (to_expr->rank == 0)
+ {
+ tmp
+ = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE,
+ true, to_expr, to_expr->ts);
+ gfc_add_expr_to_block (&block, tmp);
+ }
- /* Assign (_data) pointers. */
- gfc_add_modify_loc (input_location, &block, to_se.expr,
- fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+ if (from_is_scalar)
+ {
+ /* Assign (_data) pointers. */
+ gfc_add_modify_loc (input_location, &block, to_tree,
+ fold_convert (TREE_TYPE (to_tree), from_tree));
- /* Set "from" to NULL. */
- gfc_add_modify_loc (input_location, &block, from_se.expr,
- fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+ /* Set "from" to NULL. */
+ gfc_add_modify_loc (input_location, &block, from_tree,
+ fold_convert (TREE_TYPE (from_tree),
+ null_pointer_node));
- gfc_add_block_to_block (&block, &from_se.post);
+ gfc_add_block_to_block (&block, &from_se.post);
+ }
gfc_add_block_to_block (&block, &to_se.post);
/* Set _vptr. */
if (to_expr->ts.type == BT_CLASS)
{
- gfc_symbol *vtab;
-
- gfc_free_expr (to_expr2);
- gfc_init_se (&to_se, NULL);
- to_se.want_pointer = 1;
- gfc_add_vptr_component (to_expr);
- gfc_conv_expr (&to_se, to_expr);
-
- if (from_expr->ts.type == BT_CLASS)
- {
- if (UNLIMITED_POLY (from_expr))
- vtab = NULL;
- else
- {
- vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
- gcc_assert (vtab);
- }
-
- gfc_free_expr (from_expr2);
- gfc_init_se (&from_se, NULL);
- from_se.want_pointer = 1;
- gfc_add_vptr_component (from_expr);
- gfc_conv_expr (&from_se, from_expr);
- gfc_add_modify_loc (input_location, &block, to_se.expr,
- fold_convert (TREE_TYPE (to_se.expr),
- from_se.expr));
-
- /* Reset _vptr component to declared type. */
- if (vtab == NULL)
- /* Unlimited polymorphic. */
- gfc_add_modify_loc (input_location, &block, from_se.expr,
- fold_convert (TREE_TYPE (from_se.expr),
- null_pointer_node));
- else
- {
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify_loc (input_location, &block, from_se.expr,
- fold_convert (TREE_TYPE (from_se.expr), tmp));
- }
- }
- else
- {
- vtab = gfc_find_vtab (&from_expr->ts);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify_loc (input_location, &block, to_se.expr,
- fold_convert (TREE_TYPE (to_se.expr), tmp));
- }
- }
-
- if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
- {
- gfc_add_modify_loc (input_location, &block, to_se.string_length,
- fold_convert (TREE_TYPE (to_se.string_length),
- from_se.string_length));
- if (from_expr->ts.deferred)
- gfc_add_modify_loc (input_location, &block, from_se.string_length,
- build_int_cst (TREE_TYPE (from_se.string_length), 0));
+ gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
+ if (from_is_class)
+ gfc_reset_vptr (&block, from_expr);
}
- return gfc_finish_block (&block);
- }
-
- /* Update _vptr component. */
- if (to_expr->ts.type == BT_CLASS)
- {
- gfc_symbol *vtab;
-
- to_se.want_pointer = 1;
- to_expr2 = gfc_copy_expr (to_expr);
- gfc_add_vptr_component (to_expr2);
- gfc_conv_expr (&to_se, to_expr2);
-
- if (from_expr->ts.type == BT_CLASS)
+ if (from_is_scalar)
{
- if (UNLIMITED_POLY (from_expr))
- vtab = NULL;
- else
+ if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
{
- vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
- gcc_assert (vtab);
+ gfc_add_modify_loc (input_location, &block, to_se.string_length,
+ fold_convert (TREE_TYPE (to_se.string_length),
+ from_se.string_length));
+ if (from_expr->ts.deferred)
+ gfc_add_modify_loc (
+ input_location, &block, from_se.string_length,
+ build_int_cst (TREE_TYPE (from_se.string_length), 0));
}
- from_se.want_pointer = 1;
- from_expr2 = gfc_copy_expr (from_expr);
- gfc_add_vptr_component (from_expr2);
- gfc_conv_expr (&from_se, from_expr2);
- gfc_add_modify_loc (input_location, &block, to_se.expr,
- fold_convert (TREE_TYPE (to_se.expr),
- from_se.expr));
-
- /* Reset _vptr component to declared type. */
- if (vtab == NULL)
- /* Unlimited polymorphic. */
- gfc_add_modify_loc (input_location, &block, from_se.expr,
- fold_convert (TREE_TYPE (from_se.expr),
- null_pointer_node));
- else
- {
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify_loc (input_location, &block, from_se.expr,
- fold_convert (TREE_TYPE (from_se.expr), tmp));
- }
- }
- else
- {
- vtab = gfc_find_vtab (&from_expr->ts);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify_loc (input_location, &block, to_se.expr,
- fold_convert (TREE_TYPE (to_se.expr), tmp));
+ return gfc_finish_block (&block);
}
- gfc_free_expr (to_expr2);
gfc_init_se (&to_se, NULL);
-
- if (from_expr->ts.type == BT_CLASS)
- {
- gfc_free_expr (from_expr2);
- gfc_init_se (&from_se, NULL);
- }
+ gfc_init_se (&from_se, NULL);
}
-
/* Deallocate "to". */
if (from_expr->rank == 0)
{
@@ -454,6 +454,8 @@ tree gfc_vptr_deallocate_get (tree);
void
gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE,
gfc_symbol * = nullptr);
+void
+gfc_class_set_vptr (stmtblock_t *, tree, tree);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
tree gfc_get_class_from_gfc_expr (gfc_expr *);
tree gfc_get_class_from_expr (tree);
@@ -10,4 +10,4 @@
call move_alloc(a,c)
end
-! { dg-final { scan-tree-dump "\\(struct __vtype__STAR \\*\\) c._vptr = \\(struct __vtype__STAR \\*\\) a._vptr;" "original" } }
+! { dg-final { scan-tree-dump "c._vptr = a._vptr;" "original" } }
--
2.45.1