https://gcc.gnu.org/g:b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
commit b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Dec 18 19:04:41 2024 +0100
Utilisation de la méthode de nullification pour nullifier un pointeur
Correction régression modifiable_p
Correction dump
Ajout assertion
Correction assertion même type
Diff:
---
gcc/fortran/trans-array.cc | 96 ++++++++++++++++++-------
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 35 ++++++++-
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 106 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cdbff27d82ca..4c237b561aa6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -545,9 +545,9 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
static int
-get_type_info (const gfc_typespec &ts)
+get_type_info (const bt &type)
{
- switch (ts.type)
+ switch (type)
{
case BT_INTEGER:
case BT_LOGICAL:
@@ -558,7 +558,7 @@ get_type_info (const gfc_typespec &ts)
case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
- return ts.type;
+ return type;
case BT_PROCEDURE:
case BT_ASSUMED:
@@ -613,11 +613,34 @@ get_size_info (gfc_typespec &ts)
}
-class init_info
+class modify_info
{
public:
+ virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
virtual tree get_data_value () const { return NULL_TREE; }
+};
+
+class nullification : public modify_info
+{
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ /*
+private:
+ gfc_typespec &ts;
+
+public:
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+ */
+};
+
+class init_info : public modify_info
+{
+public:
+ virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
};
@@ -638,13 +661,13 @@ public:
}
};
-class nullification : public init_info
+class null_init : public init_info
{
private:
gfc_typespec &ts;
public:
- nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const { return null_pointer_node; }
virtual gfc_typespec *get_type () const { return &ts; }
@@ -700,13 +723,12 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (type_info->type != BT_CLASS)
- {
- tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
- tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (*type_info));
- CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
- }
+ tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
+ tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
+ get_type_info (type_info->type == BT_CLASS
+ ? BT_DERIVED
+ : type_info->type));
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
}
@@ -715,8 +737,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
/* Build a null array descriptor constructor. */
vec<constructor_elt, va_gc> *
-get_descriptor_init (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr, const init_info &init)
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+ const symbol_attribute *attr, const modify_info &init)
{
vec<constructor_elt, va_gc> *v = nullptr;
@@ -732,11 +754,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int
rank,
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
- tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (ts, rank, attr, init);
- CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ if (init.is_initialization ())
+ {
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = build_dtype (*ts, rank, *attr,
+ static_cast<const init_info &> (init));
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ }
- if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
{
/* Declare the variable static so its array descriptor stays present
after leaving the scope. It may still be accessed through another
@@ -759,7 +785,7 @@ get_default_array_descriptor_init (tree type, gfc_typespec
&ts, int rank,
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (DATA_FIELD == 0);
- return get_descriptor_init (type, ts, rank, attr, default_init (attr));
+ return get_descriptor_init (type, &ts, rank, &attr, default_init (attr));
}
@@ -767,7 +793,14 @@ vec<constructor_elt, va_gc> *
get_null_array_descriptor_init (tree type, gfc_typespec &ts, int rank,
const symbol_attribute &attr)
{
- return get_descriptor_init (type, ts, rank, attr, nullification (ts));
+ return get_descriptor_init (type, &ts, rank, &attr, null_init (ts));
+}
+
+
+vec<constructor_elt, va_gc> *
+get_null_array_descriptor (tree type, const symbol_attribute &attr)
+{
+ return get_descriptor_init (type, nullptr, 0, &attr, nullification ());
}
@@ -778,7 +811,7 @@ gfc_build_default_array_descriptor (tree type, gfc_typespec
&ts, int rank,
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
return build_constructor (type,
- get_descriptor_init (type, ts, rank, attr,
+ get_descriptor_init (type, &ts, rank, &attr,
default_init (attr)));
}
@@ -901,6 +934,9 @@ modifiable_p (tree data_ref)
{
switch (TREE_CODE (data_ref))
{
+ case INDIRECT_REF:
+ return true;
+
case CONST_DECL:
return false;
@@ -1056,6 +1092,18 @@ gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*sym, tree descriptor)
}
+void
+gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *expr, tree descriptor)
+{
+ symbol_attribute attr;
+
+ attr = gfc_expr_attr (expr);
+
+ init_struct (block, descriptor,
+ get_null_array_descriptor (TREE_TYPE (descriptor), attr));
+}
+
+
void
gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym,
gfc_expr *expr, tree descriptor)
@@ -1088,8 +1136,8 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree
descriptor,
attr = gfc_symbol_attr (sym);
init_struct (block, descriptor,
- get_descriptor_init (TREE_TYPE (descriptor), sym->ts, 0,
- attr, scalar_value (expr->ts, value)));
+ get_descriptor_init (TREE_TYPE (descriptor), &sym->ts, 0,
+ &attr, scalar_value (expr->ts, value)));
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3b05a2eb197a..8df55c2c00a5 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -142,6 +142,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss
*, gfc_ss *);
tree gfc_build_null_descriptor (tree);
tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, tree);
+void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1de4a73974d6..003754cdad6f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -828,9 +828,27 @@ gfc_get_vptr_from_expr (tree expr)
return NULL_TREE;
}
+
+static int
+descriptor_rank (tree descriptor)
+{
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+ return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
void
gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
- bool lhs_type)
+ bool)
{
tree tmp, tmp2, type;
@@ -846,7 +864,18 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
tmp = gfc_get_descriptor_dimension (lhs_desc);
tmp2 = gfc_get_descriptor_dimension (rhs_desc);
- type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+ int rank = descriptor_rank (lhs_desc);
+ int rank2 = descriptor_rank (rhs_desc);
+ if (rank == GFC_MAX_DIMENSIONS && rank2 != GFC_MAX_DIMENSIONS)
+ type = TREE_TYPE (tmp2);
+ else if (rank2 == GFC_MAX_DIMENSIONS && rank != GFC_MAX_DIMENSIONS)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
+
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
gfc_index_zero_node, NULL_TREE, NULL_TREE);
tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
@@ -10904,7 +10933,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
if (expr2->expr_type == EXPR_NULL)
{
/* Just set the data pointer to null. */
- gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
+ gfc_nullify_descriptor (&lse.pre, expr1, lse.expr);
}
else if (rank_remap)
{
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90
b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
index 01f02ab6e47a..d938d2536980 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, .dtype={.version=0, .rank=1}}, ._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, .type=5}},
._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" } }
